diff options
| author | David Bremner <bremner@debian.org> | 2021-04-08 19:43:28 -0300 |
|---|---|---|
| committer | David Bremner <bremner@debian.org> | 2021-04-08 19:43:28 -0300 |
| commit | 17233c0bf6ddcf1a1a8d68edef2f2604d03cf4ea (patch) | |
| tree | 64e0e99a9442597c3d6a84a0a4a166504654de6e /src/ChezScheme | |
| parent | 0711bec8db66440c043a1817fa9ecdf3e1da0658 (diff) | |
| parent | 4a79ca9db0b9b086e74e6a05b64239082bf24252 (diff) | |
Merge tag 'upstream/8.0' into dfsg
downloaded from racket-lang.org, via uscan
Diffstat (limited to 'src/ChezScheme')
174 files changed, 11726 insertions, 7332 deletions
diff --git a/src/ChezScheme/BUILDING b/src/ChezScheme/BUILDING index 8a291bf22d..074b2c092c 100644 --- a/src/ChezScheme/BUILDING +++ b/src/ChezScheme/BUILDING @@ -46,26 +46,33 @@ VIA SHELL section later in this file. Otherwise, to get further instructions, try running ./configure - make <machine type> - -The output will either suggest using Racket as - - racket rktboot/main.rkt --machine <machine type> + make -or using the pb boot files with +The output will either suggest using using the pb boot files with ./configure --pb make <machine type>.bootquick -and then trying again with `./configure`. +or Racket as -If you plan to build on multiple different machines, then it may be a -good idea to generate pb boot files via Racket: + racket rktboot/main.rkt --machine <machine type> + +and then trying again with `./configure`. In the former case, you can +use "auto.bootquick" instead of "<machine type>.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 +via Racket: racket rktboot/main.rkt --machine pb -Then, you can use the ob boot files on different machines instead of -having to install Racket on each machine. +Then, you can use the pb boot files on different machines instead of +having to install Racket on each machine. Alternatively, after you +have a Chez Scheme build on one machine, you can use use + + make <machine type>.boot + +to more quickly create boot files for any <machine type>. CONFIGURING AND BUILDING diff --git a/src/ChezScheme/IMPLEMENTATION.md b/src/ChezScheme/IMPLEMENTATION.md index 9c6043c8f2..623dd7ec2f 100644 --- a/src/ChezScheme/IMPLEMENTATION.md +++ b/src/ChezScheme/IMPLEMENTATION.md @@ -1,4 +1,4 @@ -# Getting Started +# Implementation Overview The majority of the Chez Scheme compiler and libraries are implemented in Scheme and can be found in the "s" (for Scheme) subdirectory. The @@ -9,7 +9,8 @@ found in the "c" directory. Some key files in "s": - * "cmacro.ss": object layouts and other global constants + * "cmacro.ss": object layouts and other global constants, including + constants that are needed by both the compiler and the kernel * "syntax.ss": the macro expander @@ -64,10 +65,15 @@ that particular machine. This is the script that "configure" runs when configuring for doing the build, but you can also run the "workarea" script on your own, supplying the machine type you'd like to build. -If you have a working Chez Scheme build and you want to cross-compile -to generate *machine-type* boot and header files, the easiest approach -is `make` *machine-type*`.boot`. The output is written to the -"boot/*machine-type*" directory. +Bootstrap from scratch by running the Racket program +"rktboot/main.rkt", which should work even with a relatively old +version of Racket. Output is written directly to a "boot" +subdirectory. + +If you have a working Chez Scheme build for the current sources and +you want to cross-compile to generate *machine-type* boot and header +files, the fastest approach is `make` *machine-type*`.boot`. The +output is written to the "boot/*machine-type*" directory. # Porting to a New Platform @@ -98,6 +104,66 @@ similar supported oerating system, but building a new backend for a new processor requires much more understanding of the compiler and runtime system. +# Adding Functionality + +If new functionality can be implemented in terms of existing +functionality, then you don't have to understand too much about the +compiler internals. Just write Scheme code, and put it in a reasonable +existing "s/*...*.ss" file. + +The main catch is that all bindings have to be declared in +"primdata.ss". The declarations are organized by exporting library and +functions versus non-functions. Unless you're also changing a +standard, your addition will go in one of the sets that is declared +with `[libraries]`, meaning that the binding is in the `chezscheme` +library. + +When a helper function needs to be a different source file than the +place where it's used, so it can't just be locally defined, prefix the +helper function name with `$` and register it in the `[flags system +proc]` group in "primdata.ss". + +There's usually not much of a bootstrapping problem with new bindings, +since you can add declarations in "primdata.ss" and implement them any +time afterward. If you get into a bad state, however, you can always +bootstrap from scratch using "rktboot/main.rkt". In the rare case that +your new functionality is needed to compile Chez Scheme itself, you'll +have to implement a copy of the functionality (or enough of it) in +"rktboot". + +Take care to implement and new functionality as safe, which means +checking arguments fully. Keep in mind that your implementation tself +will be compiled as unsafe. While testing and debugging your +additions, however, you'll probably want to use `make o=0` in the +"*machine-type*/s" workarea space, which compiles in safe mode. + +Tests go in "mats/*...*.ms". In "*machine-type*/mats", you can use +`make 7.mo` to build and run `7.ms`. Remove `7.mo` to re-run without +changing `7.ms`. Makefile variables like `o` control the way tests +are run; for example, use `make o=3 7.mo` to test in unsafe mode. + +# Compiled Files and Boot Files + +A Scheme file conventionally uses the suffix ".ss" and it's compiled +form uses the suffix ".so". The format of a compiled file is closely +related to the fasl format that is exposed by `fasl-write` and +`fasl-read`, but you can't compile Scheme code to some value that is +written with `fasl-write`. Instead, `compile-file` and related +functions directly generate compiled code in a fasled form that +includes needed linking information. + +A boot file, usually with the suffix ".boot", has the same format as a +compiled file, but with an extra header that identifies it as a boot +file and takes care of some singleton objects, such as `#!base-rtd` +and the stub to invoke compiled code. + +The vfasl format is used for the same purposes as the fasl format, but +mostly for boot files. It is always platform-specific and its content +is very close to the form that the content will take when loaded into +memory. It can load especially quickly with streamlined linking and +interning of symbols and record types, especially in uncompressed +form. The build scripts do not convert boot files to vfasl format. + # Scheme Objects A Scheme object is represented at run time by a pointer. The low bits @@ -169,6 +235,13 @@ contain the value `type-inexactnum`. The `iptr` type for `type` means "a pointer-sized signed integer". The `ptr` type for `real` and `imag` means "pointer" or "Scheme object". +If you create a new type of object, then several pieces need to be +updated: the garbage collector (in "mkgc.ss" and "gc.c"), the compiler +to implement primitives that generate the kind of objects, the fasl +writer (in "fasl.ss"), the fasl reader (in "fasl.c"), the fasl reader +used by `strip-fasl-file` and `vfasl-convert-file` (in "strip.ss"), +the vfasl writer (in "vfasl.ss"), and the inspector (in "inspect.ss"). + # Functions and Calls Scheme code does not use the C stack, except to the degree that it @@ -283,6 +356,91 @@ So, when you disassemble code generated by the Chez Scheme compiler, you may see garbage instructions mingled with the well-formed instructions, but the garbage will always be jumped over. +# Primitives, Library Entries, and C Entries + +Chez Scheme functions are mostly implemented in Chez Scheme, but some +primitives are hand-coded within the compiler, and some primitives are +implemented or supported by C code in the kernel. + +For example, the definition of `set-car!` is in "prims.ss" is + +```scheme +(define set-car! + (lambda (p v) + (#2%set-car! p v))) +``` + +This turns out not to be a circular definition, because the compiler +recogizes an immediate application of the `set-car!` primitive and +inlines its implementation. The `#2%` prefix instructs the compiler to +inline the safe implementation of `set-car!`, which checks whether its +first argument is a pair. Look for `define-inline 2 set-car!` in +"cpnanopass.ss" for that part of the compiler. The content of +"prims.ss" is compiled in unsafe mode, so that's why safe mode needs +to be selected explicitly when needed. + +What if the argument to `set-car!` is not a pair? The implementation +of inline `set-car!` in "cpnanopass.ss" includes + +```scheme +(build-libcall #t src sexpr set-car! e-pair e-new) +``` + +which calls a `set-car!` *library function*. That's defined in +"library.ss" by + +```scheme +(define-library-entry (set-car! x y) (pair-oops 'set-car! x)) +``` + +That is, the `set-car!` library function always reports an error, +because that's the only reason the library function is called. Some +other library functions implement the slow path for functions where +the compiler inlines only a fast path. + +Every library function has to be declared in "cmacros.ss" in the +`declare-library-entries` form. That form declares a vector of +*library entries*, which the linker uses to replace an address stub +(as inserted into machine code via `build-libcall`) with the run-time +address of the library function. The vector is filled in by loading +"library.ss". Since some library functions can refer to others, the +order is important; the linker encouters the forms of "library.ss" one +at a time, and a library entry must be registered before it is +referenced. + +Some functions or other pointers, such as the thread-context mutex, +are created by the kernel in C. Those pointers are stored in an array +of *C entries* that is used by the linker. The kernel registers C +entries with `S_install_c_entry` in "prim.c". Machine code that refer +to a C entry is generated in the compiler with `(make-info-literal #f +'entry (lookup-c-entry ....) ....)`. All C entries are also declared +in "cmacros.ss" with `declare-c-entries`. + +Adding a new library entry or C entry shifts indices that are +generated by the Scheme compiler. If you change the set of entries, +it's usually easiest to re-bootstrap from scratch using +"rktboot/main.rkt". To avoid confusion, be sure to change the version +number first (see "Changing the Version Number" below). + +Some primitives are implemented directly in the compiler but should +not be inlined. Those functions are implemented with a `$hand-coded` +form. For example, `list` is implemented in "prims.ss" as + +```scheme +(define list ($hand-coded 'list-procedure)) +``` + +Look for `list-procedure` in "cpnanopass.ss" to see the +implementation. + +Finally, some primitives in "prims.ss" are implemented in the kernel +and simply accessed with `foreign-procedure`. Other parts of the +implementation also use `foreign-procedure` instead of having a +defintion in "prims.ss". + +If you're looking for math primitives, see "mathprims.ss" instead of +"prims.ss". + # Compilation Pipeline Compilation @@ -842,7 +1000,7 @@ handling in "compile.ss", and the update routine in "fasl.c". Support for foreign procedures and callables in Chez Scheme boils down to foriegn calls and callable stubs for the backend. A backend's -`asm-foreign-call` and `asm-forieng-callbable` function receives an +`asm-foreign-call` and `asm-foreign-callbable` function receives an `info-foreign` record, which describes the argument and result types in relatively primitive forms: @@ -950,3 +1108,39 @@ The `asm-foreign-callable` function returns 4 values: Generate the code for a C return, including any teardown needed to balance `c-init`. + +# Cross Compilation and Compile-Time Constants + +When cross compiling, there are two notions of quantities/properties +like the size of pointers or endianness: the host notion and the +target platform's notion. A function like `(native-endianness)` always +reports the host's notion. A constant like `(constant +native-endianness)` refers to the target machine notion. + +Cross compilation works by starting with a Chez Scheme that runs on +the host machine and then re-compiling a subset of the Chez Scheme +implementation to run on the host machine but with `constant` values +suitable for the target machine. The recompiled parts are assembled +into an `xpatch` file that can be loaded to replace functions like +`compile-file` and `vfasl-convert-file` with ones that use the +target-machine constants. Loading an `xpatch` file tends to make +compilation or fasl operations for the host machine inaccessible, so a +given Chez Scheme process is only good for targeting one particular +platform. + +When working on the compiler or fasl-related tools, take care to use +the right notion of a quantity or property. If you need the host +value, then there must be some function that provides the value. If +you need the target machine's value, then it must be accessed using +`constant`. + +# Changing the Version Number + +To change the version number: + + * Edit the `version` definition in "cmacro.ss" + + * Edit the `Version` macro in "makefiles/Mf-install" + +After changing the version number, re-bootstrap from scratch using +"rktboot/main.rkt". diff --git a/src/ChezScheme/LOG b/src/ChezScheme/LOG index 7355622865..c6b587e543 100644 --- a/src/ChezScheme/LOG +++ b/src/ChezScheme/LOG @@ -2116,3 +2116,5 @@ i3nt/ti3nt. more recent versions of gcc sometimes generate sse instructions that require 16-byte stack alignment. x86.ss +- add special case in cpnanopass.ss for (eq? (ftype-pointer-address x) 0) + cpnanopass.ss diff --git a/src/ChezScheme/NOTICE b/src/ChezScheme/NOTICE index a2067d8388..9fa93e4587 100644 --- a/src/ChezScheme/NOTICE +++ b/src/ChezScheme/NOTICE @@ -28,3 +28,6 @@ Builds of this product incorporate separately copyrighted code from: * the Zlib compression library, developed by Jean-loup Gailly and Mark Adler + +* the LZ4 compression library, developed by Yann Collet and + contributors. diff --git a/src/ChezScheme/README.md b/src/ChezScheme/README.md index 2163f6ecaf..5821dd3495 100644 --- a/src/ChezScheme/README.md +++ b/src/ChezScheme/README.md @@ -3,6 +3,16 @@ that language, with supporting tools and documentation. This variant of Chez Scheme is extended to support the implementation of [Racket](https://racket-lang.org/). +Supported platforms: + + * Windows: x86, x86_64 + * Mac OS: x86, x86_64, AArch64, PowerPC32 + * Linux: x86, x86_64, ARMv6, AArch64, PowerPC32 + * FreeBSD: x86, x86_64 + * OpenBSD: x86, x86_64 + * NetBSD: x86, x86_64 + * Solaris: x86, x86_64 + As a superset of the language described in the [Revised<sup>6</sup> Report on the Algorithmic Language Scheme](http://www.r6rs.org) (R6RS), Chez Scheme supports all standard features of Scheme, @@ -57,4 +67,27 @@ starting point. Get started with Chez Scheme by [Building Chez Scheme](BUILDING). -For more information see the [Chez Scheme Project Page](https://cisco.github.io/ChezScheme/). +For more information about the implementation and a guide to modifying +Chez Scheme, see [implementation notes](IMPLEMENTATION.md). + +For more information on Chez Scheme, see the [Chez Scheme Project Page](https://cisco.github.io/ChezScheme/). + +Major additions to Chez Scheme in the Racket variant: + + * AArch64 support + + * pb (Portable bytecode) support, which is mainly useful for + bootstrapping a build on any supported platform + + * Unboxed floating-point arithmetic and flvectors + + * Type reconstruction during optimization (especially for safe code) + + * Continuation attachments + + * Parallel garbage collection, in-place garbage collection for + old-generation objects (instead of always copying), and + reachability-based memory accounting + + * Ordered finalization, immobile (but collectable) objects, and + weak/ephemeron generic hash tables diff --git a/src/ChezScheme/boot/pb/equates.h b/src/ChezScheme/boot/pb/equates.h index e3b9a51867..4a3c9d3cbd 100644 --- a/src/ChezScheme/boot/pb/equates.h +++ b/src/ChezScheme/boot/pb/equates.h @@ -1,4 +1,4 @@ -/* equates.h for Chez Scheme Version 9.5.3.39 */ +/* equates.h for Chez Scheme Version 9.5.3.58 */ /* Do not edit this file. It is automatically generated and */ /* specifically tailored to the version of Chez Scheme named */ @@ -89,6 +89,8 @@ typedef uint64_t U64; #define box_ref_disp 0x9 #define box_type_disp 0x1 #define byte_alignment 0x10 +#define byte_bits 0x8 +#define byte_bytes 0x1 #define byte_constant_mask 0xFFFFFFFFFFFFFFFF #define bytes_per_card 0x200 #define bytes_per_segment 0x4000 @@ -97,8 +99,8 @@ typedef uint64_t U64; #define bytevector_length_factor 0x8 #define bytevector_length_offset 0x3 #define bytevector_type_disp 0x1 -#define c_entry_name_vector #(thread-context get-thread-context handle-apply-overflood handle-docall-error handle-overflow handle-overflood handle-nonprocedure-symbol thread-list split-and-resize raw-collect-cond raw-collect-thread0-cond raw-tc-mutex activate-thread deactivate-thread unactivate-thread handle-values-error handle-mvlet-error handle-arg-error handle-event-detour foreign-entry install-library-entry get-more-room scan-remembered-set instantiate-code-object Sreturn Scall-one-result Scall-any-results segment-info bignum-mask-test flfloor flceiling flround fltruncate flsin flcos fltan flasin flacos flatan flatan2 flexp fllog fllog2 flexpt flsqrt) -#define c_entry_vector_size 0x2D +#define c_entry_name_vector #(thread-context get-thread-context handle-apply-overflood handle-docall-error handle-overflow handle-overflood handle-nonprocedure-symbol thread-list split-and-resize raw-collect-cond raw-collect-thread0-cond raw-tc-mutex raw-terminated-cond activate-thread deactivate-thread unactivate-thread handle-values-error handle-mvlet-error handle-arg-error handle-event-detour foreign-entry install-library-entry get-more-room scan-remembered-set instantiate-code-object Sreturn Scall-one-result Scall-any-results segment-info bignum-mask-test flfloor flceiling flround fltruncate flsin flcos fltan flasin flacos flatan flatan2 flexp fllog fllog2 flexpt flsqrt null-immutable-vector null-immutable-bytevector null-immutable-string) +#define c_entry_vector_size 0x31 #define cached_stack_link_disp 0x8 #define cached_stack_size_disp 0x0 #define card_offset_bits 0x9 @@ -113,6 +115,7 @@ typedef uint64_t U64; #define code_flag_arity_in_closure 0x20 #define code_flag_continuation 0x2 #define code_flag_guardian 0x8 +#define code_flag_lift_barrier 0x80 #define code_flag_mutable_closure 0x10 #define code_flag_single_valued 0x40 #define code_flag_system 0x1 @@ -151,6 +154,7 @@ typedef uint64_t U64; #define countof_ephemeron 0x19 #define countof_exactnum 0x8 #define countof_flonum 0x2 +#define countof_flvector 0x1D #define countof_fxvector 0x14 #define countof_guardian 0x17 #define countof_inexactnum 0x7 @@ -169,7 +173,7 @@ typedef uint64_t U64; #define countof_symbol 0x1 #define countof_thread 0xC #define countof_tlc 0xD -#define countof_types 0x1D +#define countof_types 0x1E #define countof_vector 0x12 #define countof_weakpair 0x11 #define default_collect_trip_bytes 0x800000 @@ -177,6 +181,7 @@ typedef uint64_t U64; #define default_max_nonstatic_generation 0x4 #define default_stack_size 0xFFF0 #define default_timer_ticks 0x3E8 +#define double_bytes 0x8 #define dtvec_hour 0x3 #define dtvec_isdst 0x9 #define dtvec_mday 0x4 @@ -228,6 +233,7 @@ typedef uint64_t U64; #define fasl_type_exactnum 0x14 #define fasl_type_fasl 0x64 #define fasl_type_flonum 0x8 +#define fasl_type_flvector 0x27 #define fasl_type_fxvector 0x1B #define fasl_type_gensym 0x13 #define fasl_type_graph 0x10 @@ -238,7 +244,6 @@ typedef uint64_t U64; #define fasl_type_immediate 0xC #define fasl_type_immutable_box 0x29 #define fasl_type_immutable_bytevector 0x28 -#define fasl_type_immutable_fxvector 0x27 #define fasl_type_immutable_string 0x26 #define fasl_type_immutable_vector 0x25 #define fasl_type_inexactnum 0x5 @@ -272,13 +277,17 @@ typedef uint64_t U64; #define fld_mutablep_index 0x2 #define fld_name_index 0x1 #define fld_type_index 0x3 +#define flonum_bytes 0x8 #define flonum_data_disp 0x6 +#define flvector_data_disp 0x9 +#define flvector_length_factor 0x10 +#define flvector_length_offset 0x4 +#define flvector_type_disp 0x1 #define forward_address_disp 0x8 #define forward_marker (ptr)0x2E #define forward_marker_disp 0x0 #define ftype_guardian_rep (ptr)0x56 #define fxvector_data_disp 0x9 -#define fxvector_immutable_flag 0x8 #define fxvector_length_factor 0x10 #define fxvector_length_offset 0x4 #define fxvector_type_disp 0x1 @@ -293,6 +302,7 @@ typedef uint64_t U64; #define header_size_bytevector 0x8 #define header_size_closure 0x8 #define header_size_code 0x40 +#define header_size_flvector 0x8 #define header_size_fxvector 0x8 #define header_size_record 0x8 #define header_size_reloc_table 0x10 @@ -308,7 +318,7 @@ typedef uint64_t U64; #define int_bits 0x20 #define integer_divide_instruction 1 #define keyboard_interrupt_index 0x3 -#define library_entry_vector_size 0x25E +#define library_entry_vector_size 0x26C #define libspec_closure_index 0xD #define libspec_does_not_expect_headroom_index 0x0 #define libspec_error_index 0xE @@ -323,51 +333,56 @@ typedef uint64_t U64; #define libspec_interface_size 0x3 #define libspec_name_index 0x1 #define list_bits_mask 0x3 +#define log2_byte_bits 0x3 #define log2_ptr_bytes 0x3 #define long_bits 0x40 #define long_long_bits 0x40 -#define machine_type 0x25 -#define machine_type_a6fb 0x15 -#define machine_type_a6le 0xB -#define machine_type_a6nb 0x19 -#define machine_type_a6nt 0x1B -#define machine_type_a6ob 0xF -#define machine_type_a6osx 0xD -#define machine_type_a6s2 0x11 -#define machine_type_alist ((0 . any) (1 . i3le) (2 . ti3le) (3 . i3nt) (4 . ti3nt) (5 . i3fb) (6 . ti3fb) (7 . i3ob) (8 . ti3ob) (9 . i3osx) (10 . ti3osx) (11 . a6le) (12 . ta6le) (13 . a6osx) (14 . ta6osx) (15 . a6ob) (16 . ta6ob) (17 . a6s2) (18 . ta6s2) (19 . i3s2) (20 . ti3s2) (21 . a6fb) (22 . ta6fb) (23 . i3nb) (24 . ti3nb) (25 . a6nb) (26 . ta6nb) (27 . a6nt) (28 . ta6nt) (29 . i3qnx) (30 . ti3qnx) (31 . arm32le) (32 . tarm32le) (33 . ppc32le) (34 . tppc32le) (35 . arm64le) (36 . tarm64le) (37 . pb)) +#define machine_type 0x1 +#define machine_type_a6fb 0x16 +#define machine_type_a6le 0xC +#define machine_type_a6nb 0x1A +#define machine_type_a6nt 0x1C +#define machine_type_a6ob 0x10 +#define machine_type_a6osx 0xE +#define machine_type_a6s2 0x12 +#define machine_type_alist ((0 . any) (1 . pb) (2 . i3le) (3 . ti3le) (4 . i3nt) (5 . ti3nt) (6 . i3fb) (7 . ti3fb) (8 . i3ob) (9 . ti3ob) (10 . i3osx) (11 . ti3osx) (12 . a6le) (13 . ta6le) (14 . a6osx) (15 . ta6osx) (16 . a6ob) (17 . ta6ob) (18 . a6s2) (19 . ta6s2) (20 . i3s2) (21 . ti3s2) (22 . a6fb) (23 . ta6fb) (24 . i3nb) (25 . ti3nb) (26 . a6nb) (27 . ta6nb) (28 . a6nt) (29 . ta6nt) (30 . i3qnx) (31 . ti3qnx) (32 . arm32le) (33 . tarm32le) (34 . ppc32le) (35 . tppc32le) (36 . arm64le) (37 . tarm64le) (38 . arm64osx) (39 . tarm64osx) (40 . ppc32osx) (41 . tppc32osx)) #define machine_type_any 0x0 -#define machine_type_arm32le 0x1F -#define machine_type_arm64le 0x23 -#define machine_type_i3fb 0x5 -#define machine_type_i3le 0x1 -#define machine_type_i3nb 0x17 -#define machine_type_i3nt 0x3 -#define machine_type_i3ob 0x7 -#define machine_type_i3osx 0x9 -#define machine_type_i3qnx 0x1D -#define machine_type_i3s2 0x13 -#define machine_type_limit 0x26 +#define machine_type_arm32le 0x20 +#define machine_type_arm64le 0x24 +#define machine_type_arm64osx 0x26 +#define machine_type_i3fb 0x6 +#define machine_type_i3le 0x2 +#define machine_type_i3nb 0x18 +#define machine_type_i3nt 0x4 +#define machine_type_i3ob 0x8 +#define machine_type_i3osx 0xA +#define machine_type_i3qnx 0x1E +#define machine_type_i3s2 0x14 +#define machine_type_limit 0x2A #define machine_type_name pb -#define machine_type_pb 0x25 -#define machine_type_ppc32le 0x21 -#define machine_type_ta6fb 0x16 -#define machine_type_ta6le 0xC -#define machine_type_ta6nb 0x1A -#define machine_type_ta6nt 0x1C -#define machine_type_ta6ob 0x10 -#define machine_type_ta6osx 0xE -#define machine_type_ta6s2 0x12 -#define machine_type_tarm32le 0x20 -#define machine_type_tarm64le 0x24 -#define machine_type_ti3fb 0x6 -#define machine_type_ti3le 0x2 -#define machine_type_ti3nb 0x18 -#define machine_type_ti3nt 0x4 -#define machine_type_ti3ob 0x8 -#define machine_type_ti3osx 0xA -#define machine_type_ti3qnx 0x1E -#define machine_type_ti3s2 0x14 -#define machine_type_tppc32le 0x22 +#define machine_type_pb 0x1 +#define machine_type_ppc32le 0x22 +#define machine_type_ppc32osx 0x28 +#define machine_type_ta6fb 0x17 +#define machine_type_ta6le 0xD +#define machine_type_ta6nb 0x1B +#define machine_type_ta6nt 0x1D +#define machine_type_ta6ob 0x11 +#define machine_type_ta6osx 0xF +#define machine_type_ta6s2 0x13 +#define machine_type_tarm32le 0x21 +#define machine_type_tarm64le 0x25 +#define machine_type_tarm64osx 0x27 +#define machine_type_ti3fb 0x7 +#define machine_type_ti3le 0x3 +#define machine_type_ti3nb 0x19 +#define machine_type_ti3nt 0x5 +#define machine_type_ti3ob 0x9 +#define machine_type_ti3osx 0xB +#define machine_type_ti3qnx 0x1F +#define machine_type_ti3s2 0x15 +#define machine_type_tppc32le 0x23 +#define machine_type_tppc32osx 0x29 #define mask_bignum 0x1F #define mask_bignum_sign 0x20 #define mask_binary_input_port 0x5FF @@ -389,14 +404,14 @@ typedef uint64_t U64; #define mask_false 0xFFFFFFFFFFFFFFFF #define mask_fixnum 0x7 #define mask_flonum 0x7 -#define mask_fxvector 0x7 +#define mask_flvector 0xF +#define mask_fxvector 0xF #define mask_guardian_code 0x8FF #define mask_immediate 0x7 #define mask_inexactnum 0xFFFFFFFFFFFFFFFF #define mask_input_port 0x1FF #define mask_mutable_box 0xFFFFFFFFFFFFFFFF #define mask_mutable_bytevector 0x7 -#define mask_mutable_fxvector 0xF #define mask_mutable_string 0xF #define mask_mutable_vector 0xF #define mask_nil 0xFFFFFFFFFFFFFFFF @@ -429,6 +444,7 @@ typedef uint64_t U64; #define max_sweep_space 0xF #define maximum_bignum_length (iptr)0x3FFFFFFFFFFFFFF #define maximum_bytevector_length (iptr)0xFFFFFFFFFFFFFFF +#define maximum_flvector_length (iptr)0xFFFFFFFFFFFFFFF #define maximum_fxvector_length (iptr)0xFFFFFFFFFFFFFFF #define maximum_interrupt_index 0x4 #define maximum_parallel_collect_threads 0x10 @@ -439,6 +455,7 @@ typedef uint64_t U64; #define most_positive_fixnum (iptr)0xFFFFFFFFFFFFFFF #define nan_single_comparison_truep 1 #define native_endianness unknown +#define never_immutable_flag 0x0 #define one_shot_headroom 0xC00 #define open_fd_append 0x8 #define open_fd_compressed 0x40 @@ -454,126 +471,130 @@ typedef uint64_t U64; #define pair_shift 0x4 #define pb_ab 0xA #define pb_add 0x0 -#define pb_adr 0xCF +#define pb_adr 0xD5 #define pb_always 0x4 -#define pb_and 0xA +#define pb_and 0xC #define pb_argument_types (#f pb-register pb-immediate) -#define pb_asr 0x14 -#define pb_bs_op 0xCA -#define pb_bs_op_pb_immediate 0xCB -#define pb_bs_op_pb_register 0xCA -#define pb_b_op 0xC4 -#define pb_b_op_pb_always_pb_immediate 0xC9 -#define pb_b_op_pb_always_pb_register 0xC8 -#define pb_b_op_pb_fals_pb_immediate 0xC5 -#define pb_b_op_pb_fals_pb_register 0xC4 -#define pb_b_op_pb_true_pb_immediate 0xC7 -#define pb_b_op_pb_true_pb_register 0xC6 +#define pb_asr 0x16 +#define pb_bs_op 0xD0 +#define pb_bs_op_pb_immediate 0xD1 +#define pb_bs_op_pb_register 0xD0 +#define pb_b_op 0xCA +#define pb_b_op_pb_always_pb_immediate 0xCF +#define pb_b_op_pb_always_pb_register 0xCE +#define pb_b_op_pb_fals_pb_immediate 0xCB +#define pb_b_op_pb_fals_pb_register 0xCA +#define pb_b_op_pb_true_pb_immediate 0xCD +#define pb_b_op_pb_true_pb_register 0xCC #define pb_bin_op 0x14 #define pb_bin_op_pb_no_signal_pb_add_pb_immediate 0x15 #define pb_bin_op_pb_no_signal_pb_add_pb_register 0x14 -#define pb_bin_op_pb_no_signal_pb_and_pb_immediate 0x1F -#define pb_bin_op_pb_no_signal_pb_and_pb_register 0x1E -#define pb_bin_op_pb_no_signal_pb_asr_pb_immediate 0x29 -#define pb_bin_op_pb_no_signal_pb_asr_pb_register 0x28 +#define pb_bin_op_pb_no_signal_pb_and_pb_immediate 0x21 +#define pb_bin_op_pb_no_signal_pb_and_pb_register 0x20 +#define pb_bin_op_pb_no_signal_pb_asr_pb_immediate 0x2B +#define pb_bin_op_pb_no_signal_pb_asr_pb_register 0x2A #define pb_bin_op_pb_no_signal_pb_div_pb_immediate 0x1B #define pb_bin_op_pb_no_signal_pb_div_pb_register 0x1A -#define pb_bin_op_pb_no_signal_pb_ior_pb_immediate 0x21 -#define pb_bin_op_pb_no_signal_pb_ior_pb_register 0x20 -#define pb_bin_op_pb_no_signal_pb_lsl_pb_immediate 0x25 -#define pb_bin_op_pb_no_signal_pb_lsl_pb_register 0x24 -#define pb_bin_op_pb_no_signal_pb_lslo_pb_immediate 0x2B -#define pb_bin_op_pb_no_signal_pb_lslo_pb_register 0x2A -#define pb_bin_op_pb_no_signal_pb_lsr_pb_immediate 0x27 -#define pb_bin_op_pb_no_signal_pb_lsr_pb_register 0x26 +#define pb_bin_op_pb_no_signal_pb_ior_pb_immediate 0x23 +#define pb_bin_op_pb_no_signal_pb_ior_pb_register 0x22 +#define pb_bin_op_pb_no_signal_pb_lsl_pb_immediate 0x27 +#define pb_bin_op_pb_no_signal_pb_lsl_pb_register 0x26 +#define pb_bin_op_pb_no_signal_pb_lslo_pb_immediate 0x2D +#define pb_bin_op_pb_no_signal_pb_lslo_pb_register 0x2C +#define pb_bin_op_pb_no_signal_pb_lsr_pb_immediate 0x29 +#define pb_bin_op_pb_no_signal_pb_lsr_pb_register 0x28 #define pb_bin_op_pb_no_signal_pb_mul_pb_immediate 0x19 #define pb_bin_op_pb_no_signal_pb_mul_pb_register 0x18 #define pb_bin_op_pb_no_signal_pb_sub_pb_immediate 0x17 #define pb_bin_op_pb_no_signal_pb_sub_pb_register 0x16 +#define pb_bin_op_pb_no_signal_pb_subp_pb_immediate 0x1F +#define pb_bin_op_pb_no_signal_pb_subp_pb_register 0x1E #define pb_bin_op_pb_no_signal_pb_subz_pb_immediate 0x1D #define pb_bin_op_pb_no_signal_pb_subz_pb_register 0x1C -#define pb_bin_op_pb_no_signal_pb_xor_pb_immediate 0x23 -#define pb_bin_op_pb_no_signal_pb_xor_pb_register 0x22 -#define pb_bin_op_pb_signal_pb_add_pb_immediate 0x2D -#define pb_bin_op_pb_signal_pb_add_pb_register 0x2C -#define pb_bin_op_pb_signal_pb_and_pb_immediate 0x37 -#define pb_bin_op_pb_signal_pb_and_pb_register 0x36 -#define pb_bin_op_pb_signal_pb_asr_pb_immediate 0x41 -#define pb_bin_op_pb_signal_pb_asr_pb_register 0x40 -#define pb_bin_op_pb_signal_pb_div_pb_immediate 0x33 -#define pb_bin_op_pb_signal_pb_div_pb_register 0x32 -#define pb_bin_op_pb_signal_pb_ior_pb_immediate 0x39 -#define pb_bin_op_pb_signal_pb_ior_pb_register 0x38 -#define pb_bin_op_pb_signal_pb_lsl_pb_immediate 0x3D -#define pb_bin_op_pb_signal_pb_lsl_pb_register 0x3C -#define pb_bin_op_pb_signal_pb_lslo_pb_immediate 0x43 -#define pb_bin_op_pb_signal_pb_lslo_pb_register 0x42 -#define pb_bin_op_pb_signal_pb_lsr_pb_immediate 0x3F -#define pb_bin_op_pb_signal_pb_lsr_pb_register 0x3E -#define pb_bin_op_pb_signal_pb_mul_pb_immediate 0x31 -#define pb_bin_op_pb_signal_pb_mul_pb_register 0x30 -#define pb_bin_op_pb_signal_pb_sub_pb_immediate 0x2F -#define pb_bin_op_pb_signal_pb_sub_pb_register 0x2E -#define pb_bin_op_pb_signal_pb_subz_pb_immediate 0x35 -#define pb_bin_op_pb_signal_pb_subz_pb_register 0x34 -#define pb_bin_op_pb_signal_pb_xor_pb_immediate 0x3B -#define pb_bin_op_pb_signal_pb_xor_pb_register 0x3A -#define pb_binaries (pb-argument-types pb-add pb-sub pb-mul pb-div pb-subz pb-and pb-ior pb-xor pb-lsl pb-lsr pb-asr pb-lslo) +#define pb_bin_op_pb_no_signal_pb_xor_pb_immediate 0x25 +#define pb_bin_op_pb_no_signal_pb_xor_pb_register 0x24 +#define pb_bin_op_pb_signal_pb_add_pb_immediate 0x2F +#define pb_bin_op_pb_signal_pb_add_pb_register 0x2E +#define pb_bin_op_pb_signal_pb_and_pb_immediate 0x3B +#define pb_bin_op_pb_signal_pb_and_pb_register 0x3A +#define pb_bin_op_pb_signal_pb_asr_pb_immediate 0x45 +#define pb_bin_op_pb_signal_pb_asr_pb_register 0x44 +#define pb_bin_op_pb_signal_pb_div_pb_immediate 0x35 +#define pb_bin_op_pb_signal_pb_div_pb_register 0x34 +#define pb_bin_op_pb_signal_pb_ior_pb_immediate 0x3D +#define pb_bin_op_pb_signal_pb_ior_pb_register 0x3C +#define pb_bin_op_pb_signal_pb_lsl_pb_immediate 0x41 +#define pb_bin_op_pb_signal_pb_lsl_pb_register 0x40 +#define pb_bin_op_pb_signal_pb_lslo_pb_immediate 0x47 +#define pb_bin_op_pb_signal_pb_lslo_pb_register 0x46 +#define pb_bin_op_pb_signal_pb_lsr_pb_immediate 0x43 +#define pb_bin_op_pb_signal_pb_lsr_pb_register 0x42 +#define pb_bin_op_pb_signal_pb_mul_pb_immediate 0x33 +#define pb_bin_op_pb_signal_pb_mul_pb_register 0x32 +#define pb_bin_op_pb_signal_pb_sub_pb_immediate 0x31 +#define pb_bin_op_pb_signal_pb_sub_pb_register 0x30 +#define pb_bin_op_pb_signal_pb_subp_pb_immediate 0x39 +#define pb_bin_op_pb_signal_pb_subp_pb_register 0x38 +#define pb_bin_op_pb_signal_pb_subz_pb_immediate 0x37 +#define pb_bin_op_pb_signal_pb_subz_pb_register 0x36 +#define pb_bin_op_pb_signal_pb_xor_pb_immediate 0x3F +#define pb_bin_op_pb_signal_pb_xor_pb_register 0x3E +#define pb_binaries (pb-argument-types pb-add pb-sub pb-mul pb-div pb-subz pb-subp pb-and pb-ior pb-xor pb-lsl pb-lsr pb-asr pb-lslo) #define pb_bl 0xC #define pb_branches (pb-argument-types pb-fals pb-true pb-always) -#define pb_call 0xCC +#define pb_call 0xD2 #define pb_call_double_double 0x1B #define pb_call_double_double_double 0x1D #define pb_call_double_uptr 0x1C #define pb_call_int32 0xE #define pb_call_int32_double_double_double_double_double_double 0x18 -#define pb_call_int32_int32 0x1E +#define pb_call_int32_int32 0xF #define pb_call_int32_int32_int32 0x15 -#define pb_call_int32_int32_uptr 0x1F +#define pb_call_int32_int32_uptr 0x12 #define pb_call_int32_int32_voids 0x16 #define pb_call_int32_uptr 0x10 #define pb_call_int32_uptr_int32 0x13 #define pb_call_int32_uptr_uptr 0x14 -#define pb_call_int32_uptr_uptr_uptr_uptr_uptr 0x20 +#define pb_call_int32_uptr_uptr_uptr_uptr_uptr 0x1E #define pb_call_int32_voids 0x11 #define pb_call_int32_voids_int32 0x17 #define pb_call_int32_voids_voids_voids_voids_uptr 0x19 #define pb_call_uint32 0x1A -#define pb_call_uptr 0x21 -#define pb_call_uptr_double_double_double_double_double_double 0x40 -#define pb_call_uptr_int32 0x23 -#define pb_call_uptr_int32_int32_int32_uptr 0x37 -#define pb_call_uptr_int32_int32_uptr 0x30 -#define pb_call_uptr_int32_int32_uptr_uptr 0x34 -#define pb_call_uptr_int32_uptr 0x27 -#define pb_call_uptr_int32_uptr_uptr_uptr 0x33 -#define pb_call_uptr_int32_voids_uptr_uptr 0x35 -#define pb_call_uptr_uptr 0x22 -#define pb_call_uptr_uptr_int32 0x26 -#define pb_call_uptr_uptr_int32_int32 0x2D -#define pb_call_uptr_uptr_int32_uptr_uptr_uptr_uptr 0x3C -#define pb_call_uptr_uptr_int64 0x28 -#define pb_call_uptr_uptr_uptr 0x25 -#define pb_call_uptr_uptr_uptr_int32 0x2E -#define pb_call_uptr_uptr_uptr_uptr 0x2F -#define pb_call_uptr_uptr_uptr_uptr_uptr 0x36 -#define pb_call_uptr_uptr_uptr_uptr_uptr_int32 0x39 -#define pb_call_uptr_uptr_uptr_uptr_uptr_uptr 0x3A -#define pb_call_uptr_uptr_uptr_uptr_uptr_uptr_uptr 0x3D -#define pb_call_uptr_uptr_uptr_uptr_uptr_uptr_uptr_int32 0x3E -#define pb_call_uptr_uptr_uptr_uptr_uptr_uptr_uptr_uptr 0x3F -#define pb_call_uptr_uptr_voids 0x29 -#define pb_call_uptr_uptr_voids_uptr_uptr 0x38 -#define pb_call_uptr_voids 0x24 -#define pb_call_uptr_voids_int32 0x2B -#define pb_call_uptr_voids_int32_int32 0x31 -#define pb_call_uptr_voids_uptr 0x2A -#define pb_call_uptr_voids_uptr_uptr 0x32 -#define pb_call_uptr_voids_voids 0x2C -#define pb_call_uptr_voids_voids_voids_voids_uptr 0x3B +#define pb_call_uptr 0x1F +#define pb_call_uptr_double_double_double_double_double_double 0x3E +#define pb_call_uptr_int32 0x21 +#define pb_call_uptr_int32_int32_int32_uptr 0x35 +#define pb_call_uptr_int32_int32_uptr 0x2E +#define pb_call_uptr_int32_int32_uptr_uptr 0x32 +#define pb_call_uptr_int32_uptr 0x25 +#define pb_call_uptr_int32_uptr_uptr_uptr 0x31 +#define pb_call_uptr_int32_voids_uptr_uptr 0x33 +#define pb_call_uptr_uptr 0x20 +#define pb_call_uptr_uptr_int32 0x24 +#define pb_call_uptr_uptr_int32_int32 0x2B +#define pb_call_uptr_uptr_int32_uptr_uptr_uptr_uptr 0x3A +#define pb_call_uptr_uptr_int64 0x26 +#define pb_call_uptr_uptr_uptr 0x23 +#define pb_call_uptr_uptr_uptr_int32 0x2C +#define pb_call_uptr_uptr_uptr_uptr 0x2D +#define pb_call_uptr_uptr_uptr_uptr_uptr 0x34 +#define pb_call_uptr_uptr_uptr_uptr_uptr_int32 0x37 +#define pb_call_uptr_uptr_uptr_uptr_uptr_uptr 0x38 +#define pb_call_uptr_uptr_uptr_uptr_uptr_uptr_uptr 0x3B +#define pb_call_uptr_uptr_uptr_uptr_uptr_uptr_uptr_int32 0x3C +#define pb_call_uptr_uptr_uptr_uptr_uptr_uptr_uptr_uptr 0x3D +#define pb_call_uptr_uptr_voids 0x27 +#define pb_call_uptr_uptr_voids_uptr_uptr 0x36 +#define pb_call_uptr_voids 0x22 +#define pb_call_uptr_voids_int32 0x29 +#define pb_call_uptr_voids_int32_int32 0x2F +#define pb_call_uptr_voids_uptr 0x28 +#define pb_call_uptr_voids_uptr_uptr 0x30 +#define pb_call_uptr_voids_voids 0x2A +#define pb_call_uptr_voids_voids_voids_voids_uptr 0x39 #define pb_call_void 0x0 -#define pb_call_voids 0x41 -#define pb_call_voids_uptr 0x42 +#define pb_call_voids 0x3F +#define pb_call_voids_uptr 0x40 #define pb_call_void_int32 0x2 #define pb_call_void_int32_int32 0x7 #define pb_call_void_int32_uptr 0x6 @@ -587,27 +608,27 @@ typedef uint64_t U64; #define pb_call_void_uptr_voids 0xA #define pb_call_void_voids 0x4 #define pb_call_void_voids_voids 0xB -#define pb_cas 0xD3 +#define pb_cas 0xD9 #define pb_cc 0x10 -#define pb_cmp_op 0x44 -#define pb_cmp_op_pb_ab_pb_immediate 0x4F -#define pb_cmp_op_pb_ab_pb_register 0x4E -#define pb_cmp_op_pb_bl_pb_immediate 0x51 -#define pb_cmp_op_pb_bl_pb_register 0x50 -#define pb_cmp_op_pb_cc_pb_immediate 0x55 -#define pb_cmp_op_pb_cc_pb_register 0x54 -#define pb_cmp_op_pb_cs_pb_immediate 0x53 -#define pb_cmp_op_pb_cs_pb_register 0x52 -#define pb_cmp_op_pb_eq_pb_immediate 0x45 -#define pb_cmp_op_pb_eq_pb_register 0x44 -#define pb_cmp_op_pb_ge_pb_immediate 0x4D -#define pb_cmp_op_pb_ge_pb_register 0x4C -#define pb_cmp_op_pb_gt_pb_immediate 0x49 -#define pb_cmp_op_pb_gt_pb_register 0x48 -#define pb_cmp_op_pb_le_pb_immediate 0x4B -#define pb_cmp_op_pb_le_pb_register 0x4A -#define pb_cmp_op_pb_lt_pb_immediate 0x47 -#define pb_cmp_op_pb_lt_pb_register 0x46 +#define pb_cmp_op 0x48 +#define pb_cmp_op_pb_ab_pb_immediate 0x53 +#define pb_cmp_op_pb_ab_pb_register 0x52 +#define pb_cmp_op_pb_bl_pb_immediate 0x55 +#define pb_cmp_op_pb_bl_pb_register 0x54 +#define pb_cmp_op_pb_cc_pb_immediate 0x59 +#define pb_cmp_op_pb_cc_pb_register 0x58 +#define pb_cmp_op_pb_cs_pb_immediate 0x57 +#define pb_cmp_op_pb_cs_pb_register 0x56 +#define pb_cmp_op_pb_eq_pb_immediate 0x49 +#define pb_cmp_op_pb_eq_pb_register 0x48 +#define pb_cmp_op_pb_ge_pb_immediate 0x51 +#define pb_cmp_op_pb_ge_pb_register 0x50 +#define pb_cmp_op_pb_gt_pb_immediate 0x4D +#define pb_cmp_op_pb_gt_pb_register 0x4C +#define pb_cmp_op_pb_le_pb_immediate 0x4F +#define pb_cmp_op_pb_le_pb_register 0x4E +#define pb_cmp_op_pb_lt_pb_immediate 0x4B +#define pb_cmp_op_pb_lt_pb_register 0x4A #define pb_compares (pb-argument-types pb-eq pb-lt pb-gt pb-le pb-ge pb-ab pb-bl pb-cs pb-cc) #define pb_cs 0xE #define pb_d_d 0x1 @@ -621,55 +642,57 @@ typedef uint64_t U64; #define pb_double 0x12 #define pb_eq 0x0 #define pb_fals 0x0 -#define pb_fp_bin_op 0x56 -#define pb_fp_bin_op_pb_add_pb_immediate 0x57 -#define pb_fp_bin_op_pb_add_pb_register 0x56 -#define pb_fp_bin_op_pb_and_pb_immediate 0x61 -#define pb_fp_bin_op_pb_and_pb_register 0x60 -#define pb_fp_bin_op_pb_asr_pb_immediate 0x6B -#define pb_fp_bin_op_pb_asr_pb_register 0x6A -#define pb_fp_bin_op_pb_div_pb_immediate 0x5D -#define pb_fp_bin_op_pb_div_pb_register 0x5C -#define pb_fp_bin_op_pb_ior_pb_immediate 0x63 -#define pb_fp_bin_op_pb_ior_pb_register 0x62 -#define pb_fp_bin_op_pb_lsl_pb_immediate 0x67 -#define pb_fp_bin_op_pb_lsl_pb_register 0x66 -#define pb_fp_bin_op_pb_lslo_pb_immediate 0x6D -#define pb_fp_bin_op_pb_lslo_pb_register 0x6C -#define pb_fp_bin_op_pb_lsr_pb_immediate 0x69 -#define pb_fp_bin_op_pb_lsr_pb_register 0x68 -#define pb_fp_bin_op_pb_mul_pb_immediate 0x5B -#define pb_fp_bin_op_pb_mul_pb_register 0x5A -#define pb_fp_bin_op_pb_sub_pb_immediate 0x59 -#define pb_fp_bin_op_pb_sub_pb_register 0x58 -#define pb_fp_bin_op_pb_subz_pb_immediate 0x5F -#define pb_fp_bin_op_pb_subz_pb_register 0x5E -#define pb_fp_bin_op_pb_xor_pb_immediate 0x65 -#define pb_fp_bin_op_pb_xor_pb_register 0x64 -#define pb_fp_cmp_op 0x76 -#define pb_fp_cmp_op_pb_ab_pb_immediate 0x81 -#define pb_fp_cmp_op_pb_ab_pb_register 0x80 -#define pb_fp_cmp_op_pb_bl_pb_immediate 0x83 -#define pb_fp_cmp_op_pb_bl_pb_register 0x82 -#define pb_fp_cmp_op_pb_cc_pb_immediate 0x87 -#define pb_fp_cmp_op_pb_cc_pb_register 0x86 -#define pb_fp_cmp_op_pb_cs_pb_immediate 0x85 -#define pb_fp_cmp_op_pb_cs_pb_register 0x84 -#define pb_fp_cmp_op_pb_eq_pb_immediate 0x77 -#define pb_fp_cmp_op_pb_eq_pb_register 0x76 -#define pb_fp_cmp_op_pb_ge_pb_immediate 0x7F -#define pb_fp_cmp_op_pb_ge_pb_register 0x7E -#define pb_fp_cmp_op_pb_gt_pb_immediate 0x7B -#define pb_fp_cmp_op_pb_gt_pb_register 0x7A -#define pb_fp_cmp_op_pb_le_pb_immediate 0x7D -#define pb_fp_cmp_op_pb_le_pb_register 0x7C -#define pb_fp_cmp_op_pb_lt_pb_immediate 0x79 -#define pb_fp_cmp_op_pb_lt_pb_register 0x78 -#define pb_fp_un_op 0x72 -#define pb_fp_un_op_pb_not_pb_immediate 0x73 -#define pb_fp_un_op_pb_not_pb_register 0x72 -#define pb_fp_un_op_pb_sqrt_pb_immediate 0x75 -#define pb_fp_un_op_pb_sqrt_pb_register 0x74 +#define pb_fp_bin_op 0x5A +#define pb_fp_bin_op_pb_add_pb_immediate 0x5B +#define pb_fp_bin_op_pb_add_pb_register 0x5A +#define pb_fp_bin_op_pb_and_pb_immediate 0x67 +#define pb_fp_bin_op_pb_and_pb_register 0x66 +#define pb_fp_bin_op_pb_asr_pb_immediate 0x71 +#define pb_fp_bin_op_pb_asr_pb_register 0x70 +#define pb_fp_bin_op_pb_div_pb_immediate 0x61 +#define pb_fp_bin_op_pb_div_pb_register 0x60 +#define pb_fp_bin_op_pb_ior_pb_immediate 0x69 +#define pb_fp_bin_op_pb_ior_pb_register 0x68 +#define pb_fp_bin_op_pb_lsl_pb_immediate 0x6D +#define pb_fp_bin_op_pb_lsl_pb_register 0x6C +#define pb_fp_bin_op_pb_lslo_pb_immediate 0x73 +#define pb_fp_bin_op_pb_lslo_pb_register 0x72 +#define pb_fp_bin_op_pb_lsr_pb_immediate 0x6F +#define pb_fp_bin_op_pb_lsr_pb_register 0x6E +#define pb_fp_bin_op_pb_mul_pb_immediate 0x5F +#define pb_fp_bin_op_pb_mul_pb_register 0x5E +#define pb_fp_bin_op_pb_sub_pb_immediate 0x5D +#define pb_fp_bin_op_pb_sub_pb_register 0x5C +#define pb_fp_bin_op_pb_subp_pb_immediate 0x65 +#define pb_fp_bin_op_pb_subp_pb_register 0x64 +#define pb_fp_bin_op_pb_subz_pb_immediate 0x63 +#define pb_fp_bin_op_pb_subz_pb_register 0x62 +#define pb_fp_bin_op_pb_xor_pb_immediate 0x6B +#define pb_fp_bin_op_pb_xor_pb_register 0x6A +#define pb_fp_cmp_op 0x7C +#define pb_fp_cmp_op_pb_ab_pb_immediate 0x87 +#define pb_fp_cmp_op_pb_ab_pb_register 0x86 +#define pb_fp_cmp_op_pb_bl_pb_immediate 0x89 +#define pb_fp_cmp_op_pb_bl_pb_register 0x88 +#define pb_fp_cmp_op_pb_cc_pb_immediate 0x8D +#define pb_fp_cmp_op_pb_cc_pb_register 0x8C +#define pb_fp_cmp_op_pb_cs_pb_immediate 0x8B +#define pb_fp_cmp_op_pb_cs_pb_register 0x8A +#define pb_fp_cmp_op_pb_eq_pb_immediate 0x7D +#define pb_fp_cmp_op_pb_eq_pb_register 0x7C +#define pb_fp_cmp_op_pb_ge_pb_immediate 0x85 +#define pb_fp_cmp_op_pb_ge_pb_register 0x84 +#define pb_fp_cmp_op_pb_gt_pb_immediate 0x81 +#define pb_fp_cmp_op_pb_gt_pb_register 0x80 +#define pb_fp_cmp_op_pb_le_pb_immediate 0x83 +#define pb_fp_cmp_op_pb_le_pb_register 0x82 +#define pb_fp_cmp_op_pb_lt_pb_immediate 0x7F +#define pb_fp_cmp_op_pb_lt_pb_register 0x7E +#define pb_fp_un_op 0x78 +#define pb_fp_un_op_pb_not_pb_immediate 0x79 +#define pb_fp_un_op_pb_not_pb_register 0x78 +#define pb_fp_un_op_pb_sqrt_pb_immediate 0x7B +#define pb_fp_un_op_pb_sqrt_pb_register 0x7A #define pb_ge 0x8 #define pb_gt 0x4 #define pb_i_d 0x2 @@ -677,42 +700,42 @@ typedef uint64_t U64; #define pb_i_bits_d_bits 0x7 #define pb_i_i_bits_d_bits 0x9 #define pb_immediate 0x1 -#define pb_inc 0xD0 -#define pb_inc_pb_immediate 0xD1 -#define pb_inc_pb_register 0xD0 +#define pb_inc 0xD6 +#define pb_inc_pb_immediate 0xD7 +#define pb_inc_pb_register 0xD6 #define pb_int16 0x4 #define pb_int32 0x8 #define pb_int64 0xC #define pb_int8 0x0 -#define pb_interp 0xCE -#define pb_ior 0xC +#define pb_interp 0xD4 +#define pb_ior 0xE #define pb_keep_bits 0x4 -#define pb_ld_op 0x9C -#define pb_ld_op_pb_double_pb_immediate 0xAF -#define pb_ld_op_pb_double_pb_register 0xAE -#define pb_ld_op_pb_int16_pb_immediate 0xA1 -#define pb_ld_op_pb_int16_pb_register 0xA0 -#define pb_ld_op_pb_int32_pb_immediate 0xA5 -#define pb_ld_op_pb_int32_pb_register 0xA4 -#define pb_ld_op_pb_int64_pb_immediate 0xA9 -#define pb_ld_op_pb_int64_pb_register 0xA8 -#define pb_ld_op_pb_int8_pb_immediate 0x9D -#define pb_ld_op_pb_int8_pb_register 0x9C -#define pb_ld_op_pb_single_pb_immediate 0xAD -#define pb_ld_op_pb_single_pb_register 0xAC -#define pb_ld_op_pb_uint16_pb_immediate 0xA3 -#define pb_ld_op_pb_uint16_pb_register 0xA2 -#define pb_ld_op_pb_uint32_pb_immediate 0xA7 -#define pb_ld_op_pb_uint32_pb_register 0xA6 -#define pb_ld_op_pb_uint64_pb_immediate 0xAB -#define pb_ld_op_pb_uint64_pb_register 0xAA -#define pb_ld_op_pb_uint8_pb_immediate 0x9F -#define pb_ld_op_pb_uint8_pb_register 0x9E +#define pb_ld_op 0xA2 +#define pb_ld_op_pb_double_pb_immediate 0xB5 +#define pb_ld_op_pb_double_pb_register 0xB4 +#define pb_ld_op_pb_int16_pb_immediate 0xA7 +#define pb_ld_op_pb_int16_pb_register 0xA6 +#define pb_ld_op_pb_int32_pb_immediate 0xAB +#define pb_ld_op_pb_int32_pb_register 0xAA +#define pb_ld_op_pb_int64_pb_immediate 0xAF +#define pb_ld_op_pb_int64_pb_register 0xAE +#define pb_ld_op_pb_int8_pb_immediate 0xA3 +#define pb_ld_op_pb_int8_pb_register 0xA2 +#define pb_ld_op_pb_single_pb_immediate 0xB3 +#define pb_ld_op_pb_single_pb_register 0xB2 +#define pb_ld_op_pb_uint16_pb_immediate 0xA9 +#define pb_ld_op_pb_uint16_pb_register 0xA8 +#define pb_ld_op_pb_uint32_pb_immediate 0xAD +#define pb_ld_op_pb_uint32_pb_register 0xAC +#define pb_ld_op_pb_uint64_pb_immediate 0xB1 +#define pb_ld_op_pb_uint64_pb_register 0xB0 +#define pb_ld_op_pb_uint8_pb_immediate 0xA5 +#define pb_ld_op_pb_uint8_pb_register 0xA4 #define pb_le 0x6 -#define pb_lock 0xD2 -#define pb_lsl 0x10 -#define pb_lslo 0x16 -#define pb_lsr 0x12 +#define pb_lock 0xD8 +#define pb_lsl 0x12 +#define pb_lslo 0x18 +#define pb_lsr 0x14 #define pb_lt 0x2 #define pb_mov 0x8 #define pb_mov_pb_d_d 0x9 @@ -740,76 +763,77 @@ typedef uint64_t U64; #define pb_mul 0x4 #define pb_no_signal 0x0 #define pb_not 0x0 -#define pb_prototype_table (((void* uptr) . 66) ((void*) . 65) ((uptr double double double double double double) . 64) ((uptr uptr uptr uptr uptr uptr uptr uptr) . 63) ((uptr uptr uptr uptr uptr uptr uptr int32) . 62) ((uptr uptr uptr uptr uptr uptr uptr) . 61) ((uptr uptr int32 uptr uptr uptr uptr) . 60) ((uptr void* void* void* void* uptr) . 59) ((uptr uptr uptr uptr uptr uptr) . 58) ((uptr uptr uptr uptr uptr int32) . 57) ((uptr uptr void* uptr uptr) . 56) ((uptr int32 int32 int32 uptr) . 55) ((uptr uptr uptr uptr uptr) . 54) ((uptr int32 void* uptr uptr) . 53) ((uptr int32 int32 uptr uptr) . 52) ((uptr int32 uptr uptr uptr) . 51) ((uptr void* uptr uptr) . 50) ((uptr void* int32 int32) . 49) ((uptr int32 int32 uptr) . 48) ((uptr uptr uptr uptr) . 47) ((uptr uptr uptr int32) . 46) ((uptr uptr int32 int32) . 45) ((uptr void* void*) . 44) ((uptr void* int32) . 43) ((uptr void* uptr) . 42) ((uptr uptr void*) . 41) ((uptr uptr int64) . 40) ((uptr int32 uptr) . 39) ((uptr uptr int32) . 38) ((uptr uptr uptr) . 37) ((uptr void*) . 36) ((uptr int32) . 35) ((uptr uptr) . 34) ((uptr) . 33) ((int32 uptr uptr uptr uptr uptr) . 32) ((int32 int32 uptr) . 31) ((int32 int32) . 30) ((double double double) . 29) ((double uptr) . 28) ((double double) . 27) ((uint32) . 26) ((int32 void* void* void* void* uptr) . 25) ((int32 double double double double double double) . 24) ((int32 void* int32) . 23) ((int32 int32 void*) . 22) ((int32 int32 int32) . 21) ((int32 uptr uptr) . 20) ((int32 uptr int32) . 19) ((int32 int32 uptr) . 18) ((int32 void*) . 17) ((int32 uptr) . 16) ((int32 int32) . 15) ((int32) . 14) ((void uptr uptr uptr uptr uptr) . 13) ((void uptr uptr uptr) . 12) ((void void* void*) . 11) ((void uptr void*) . 10) ((void int32 void*) . 9) ((void uptr uptr) . 8) ((void int32 int32) . 7) ((void int32 uptr) . 6) ((void uptr uint32) . 5) ((void void*) . 4) ((void uint32) . 3) ((void int32) . 2) ((void uptr) . 1) ((void) . 0)) +#define pb_prototype_table (((void* uptr) . 64) ((void*) . 63) ((uptr double double double double double double) . 62) ((uptr uptr uptr uptr uptr uptr uptr uptr) . 61) ((uptr uptr uptr uptr uptr uptr uptr int32) . 60) ((uptr uptr uptr uptr uptr uptr uptr) . 59) ((uptr uptr int32 uptr uptr uptr uptr) . 58) ((uptr void* void* void* void* uptr) . 57) ((uptr uptr uptr uptr uptr uptr) . 56) ((uptr uptr uptr uptr uptr int32) . 55) ((uptr uptr void* uptr uptr) . 54) ((uptr int32 int32 int32 uptr) . 53) ((uptr uptr uptr uptr uptr) . 52) ((uptr int32 void* uptr uptr) . 51) ((uptr int32 int32 uptr uptr) . 50) ((uptr int32 uptr uptr uptr) . 49) ((uptr void* uptr uptr) . 48) ((uptr void* int32 int32) . 47) ((uptr int32 int32 uptr) . 46) ((uptr uptr uptr uptr) . 45) ((uptr uptr uptr int32) . 44) ((uptr uptr int32 int32) . 43) ((uptr void* void*) . 42) ((uptr void* int32) . 41) ((uptr void* uptr) . 40) ((uptr uptr void*) . 39) ((uptr uptr int64) . 38) ((uptr int32 uptr) . 37) ((uptr uptr int32) . 36) ((uptr uptr uptr) . 35) ((uptr void*) . 34) ((uptr int32) . 33) ((uptr uptr) . 32) ((uptr) . 31) ((int32 uptr uptr uptr uptr uptr) . 30) ((double double double) . 29) ((double uptr) . 28) ((double double) . 27) ((uint32) . 26) ((int32 void* void* void* void* uptr) . 25) ((int32 double double double double double double) . 24) ((int32 void* int32) . 23) ((int32 int32 void*) . 22) ((int32 int32 int32) . 21) ((int32 uptr uptr) . 20) ((int32 uptr int32) . 19) ((int32 int32 uptr) . 18) ((int32 void*) . 17) ((int32 uptr) . 16) ((int32 int32) . 15) ((int32) . 14) ((void uptr uptr uptr uptr uptr) . 13) ((void uptr uptr uptr) . 12) ((void void* void*) . 11) ((void uptr void*) . 10) ((void int32 void*) . 9) ((void uptr uptr) . 8) ((void int32 int32) . 7) ((void int32 uptr) . 6) ((void uptr uint32) . 5) ((void void*) . 4) ((void uint32) . 3) ((void int32) . 2) ((void uptr) . 1) ((void) . 0)) #define pb_register 0x0 -#define pb_return 0xCD -#define pb_rev_op 0x88 -#define pb_rev_op_pb_double_pb_immediate 0x9B -#define pb_rev_op_pb_double_pb_register 0x9A -#define pb_rev_op_pb_int16_pb_immediate 0x8D -#define pb_rev_op_pb_int16_pb_register 0x8C -#define pb_rev_op_pb_int32_pb_immediate 0x91 -#define pb_rev_op_pb_int32_pb_register 0x90 -#define pb_rev_op_pb_int64_pb_immediate 0x95 -#define pb_rev_op_pb_int64_pb_register 0x94 -#define pb_rev_op_pb_int8_pb_immediate 0x89 -#define pb_rev_op_pb_int8_pb_register 0x88 -#define pb_rev_op_pb_single_pb_immediate 0x99 -#define pb_rev_op_pb_single_pb_register 0x98 -#define pb_rev_op_pb_uint16_pb_immediate 0x8F -#define pb_rev_op_pb_uint16_pb_register 0x8E -#define pb_rev_op_pb_uint32_pb_immediate 0x93 -#define pb_rev_op_pb_uint32_pb_register 0x92 -#define pb_rev_op_pb_uint64_pb_immediate 0x97 -#define pb_rev_op_pb_uint64_pb_register 0x96 -#define pb_rev_op_pb_uint8_pb_immediate 0x8B -#define pb_rev_op_pb_uint8_pb_register 0x8A +#define pb_return 0xD3 +#define pb_rev_op 0x8E +#define pb_rev_op_pb_double_pb_immediate 0xA1 +#define pb_rev_op_pb_double_pb_register 0xA0 +#define pb_rev_op_pb_int16_pb_immediate 0x93 +#define pb_rev_op_pb_int16_pb_register 0x92 +#define pb_rev_op_pb_int32_pb_immediate 0x97 +#define pb_rev_op_pb_int32_pb_register 0x96 +#define pb_rev_op_pb_int64_pb_immediate 0x9B +#define pb_rev_op_pb_int64_pb_register 0x9A +#define pb_rev_op_pb_int8_pb_immediate 0x8F +#define pb_rev_op_pb_int8_pb_register 0x8E +#define pb_rev_op_pb_single_pb_immediate 0x9F +#define pb_rev_op_pb_single_pb_register 0x9E +#define pb_rev_op_pb_uint16_pb_immediate 0x95 +#define pb_rev_op_pb_uint16_pb_register 0x94 +#define pb_rev_op_pb_uint32_pb_immediate 0x99 +#define pb_rev_op_pb_uint32_pb_register 0x98 +#define pb_rev_op_pb_uint64_pb_immediate 0x9D +#define pb_rev_op_pb_uint64_pb_register 0x9C +#define pb_rev_op_pb_uint8_pb_immediate 0x91 +#define pb_rev_op_pb_uint8_pb_register 0x90 #define pb_s_d 0x4 #define pb_shift0 0x0 #define pb_shift1 0x1 #define pb_shift2 0x2 #define pb_shift3 0x3 #define pb_shifts (#f pb-shift0 pb-shift1 pb-shift2 pb-shift3) -#define pb_signal 0x18 +#define pb_signal 0x1A #define pb_signals (pb-binaries pb-no-signal pb-signal) #define pb_single 0x10 #define pb_sizes (pb-argument-types pb-int8 pb-uint8 pb-int16 pb-uint16 pb-int32 pb-uint32 pb-int64 pb-uint64 pb-single pb-double) #define pb_sqrt 0x2 -#define pb_st_op 0xB0 -#define pb_st_op_pb_double_pb_immediate 0xC3 -#define pb_st_op_pb_double_pb_register 0xC2 -#define pb_st_op_pb_int16_pb_immediate 0xB5 -#define pb_st_op_pb_int16_pb_register 0xB4 -#define pb_st_op_pb_int32_pb_immediate 0xB9 -#define pb_st_op_pb_int32_pb_register 0xB8 -#define pb_st_op_pb_int64_pb_immediate 0xBD -#define pb_st_op_pb_int64_pb_register 0xBC -#define pb_st_op_pb_int8_pb_immediate 0xB1 -#define pb_st_op_pb_int8_pb_register 0xB0 -#define pb_st_op_pb_single_pb_immediate 0xC1 -#define pb_st_op_pb_single_pb_register 0xC0 -#define pb_st_op_pb_uint16_pb_immediate 0xB7 -#define pb_st_op_pb_uint16_pb_register 0xB6 -#define pb_st_op_pb_uint32_pb_immediate 0xBB -#define pb_st_op_pb_uint32_pb_register 0xBA -#define pb_st_op_pb_uint64_pb_immediate 0xBF -#define pb_st_op_pb_uint64_pb_register 0xBE -#define pb_st_op_pb_uint8_pb_immediate 0xB3 -#define pb_st_op_pb_uint8_pb_register 0xB2 +#define pb_st_op 0xB6 +#define pb_st_op_pb_double_pb_immediate 0xC9 +#define pb_st_op_pb_double_pb_register 0xC8 +#define pb_st_op_pb_int16_pb_immediate 0xBB +#define pb_st_op_pb_int16_pb_register 0xBA +#define pb_st_op_pb_int32_pb_immediate 0xBF +#define pb_st_op_pb_int32_pb_register 0xBE +#define pb_st_op_pb_int64_pb_immediate 0xC3 +#define pb_st_op_pb_int64_pb_register 0xC2 +#define pb_st_op_pb_int8_pb_immediate 0xB7 +#define pb_st_op_pb_int8_pb_register 0xB6 +#define pb_st_op_pb_single_pb_immediate 0xC7 +#define pb_st_op_pb_single_pb_register 0xC6 +#define pb_st_op_pb_uint16_pb_immediate 0xBD +#define pb_st_op_pb_uint16_pb_register 0xBC +#define pb_st_op_pb_uint32_pb_immediate 0xC1 +#define pb_st_op_pb_uint32_pb_register 0xC0 +#define pb_st_op_pb_uint64_pb_immediate 0xC5 +#define pb_st_op_pb_uint64_pb_register 0xC4 +#define pb_st_op_pb_uint8_pb_immediate 0xB9 +#define pb_st_op_pb_uint8_pb_register 0xB8 #define pb_sub 0x2 +#define pb_subp 0xA #define pb_subz 0x8 #define pb_true 0x2 #define pb_uint16 0x6 #define pb_uint32 0xA #define pb_uint64 0xE #define pb_uint8 0x2 -#define pb_un_op 0x6E -#define pb_un_op_pb_not_pb_immediate 0x6F -#define pb_un_op_pb_not_pb_register 0x6E -#define pb_un_op_pb_sqrt_pb_immediate 0x71 -#define pb_un_op_pb_sqrt_pb_register 0x70 +#define pb_un_op 0x74 +#define pb_un_op_pb_not_pb_immediate 0x75 +#define pb_un_op_pb_not_pb_register 0x74 +#define pb_un_op_pb_sqrt_pb_immediate 0x77 +#define pb_un_op_pb_sqrt_pb_register 0x76 #define pb_unaries (pb-argument-types pb-not pb-sqrt) -#define pb_xor 0xE +#define pb_xor 0x10 #define pb_zero_bits 0x0 #define phantom_length_disp 0x9 #define phantom_type_disp 0x1 @@ -856,13 +880,13 @@ typedef uint64_t U64; #define ratnum_type_disp 0x1 #define real_space_alist ((new . 0) (impure . 1) (symbol . 2) (port . 3) (weakpair . 4) (ephemeron . 5) (pure . 6) (continuation . 7) (code . 8) (pure-typed-object . 9) (impure-record . 10) (impure-typed-object . 11) (closure . 12) (immobile-impure . 13) (count-pure . 14) (count-impure . 15) (data . 16) (immobile-data . 17)) #define record_data_disp 0x9 +#define record_type_ancestry_disp 0x9 #define record_type_counts_disp 0x49 #define record_type_disp 0x1 #define record_type_flags_disp 0x39 #define record_type_flds_disp 0x31 #define record_type_mpm_disp 0x21 #define record_type_name_disp 0x29 -#define record_type_parent_disp 0x9 #define record_type_pm_disp 0x19 #define record_type_size_disp 0x11 #define record_type_type_disp 0x1 @@ -902,7 +926,7 @@ typedef uint64_t U64; #define rtd_sealed 0x4 #define sbwp (ptr)0x4E #define scaled_shot_1_shot_flag -0x8 -#define scheme_version 0x9050327 +#define scheme_version 0x905033A #define seginfo_generation_disp 0x1 #define seginfo_list_bits_disp 0x8 #define seginfo_space_disp 0x0 @@ -916,6 +940,21 @@ typedef uint64_t U64; #define sfalse (ptr)0x6 #define short_bits 0x10 #define signal_interrupt_index 0x4 +#define singleton_eq 0x9 +#define singleton_equal 0xB +#define singleton_eqv 0xA +#define singleton_not_a_singleton 0x0 +#define singleton_null_bytevector 0x5 +#define singleton_null_flvector 0x4 +#define singleton_null_fxvector 0x3 +#define singleton_null_immutable_bytevector 0x8 +#define singleton_null_immutable_string 0x6 +#define singleton_null_immutable_vector 0x7 +#define singleton_null_string 0x1 +#define singleton_null_vector 0x2 +#define singleton_symbol_ht_rtd 0xE +#define singleton_symbol_symbol 0xD +#define singleton_symboleqlp 0xC #define size_box 0x10 #define size_cached_stack 0x10 #define size_continuation 0x40 @@ -934,10 +973,11 @@ typedef uint64_t U64; #define size_rp_header 0x20 #define size_rtd_counts 0x810 #define size_symbol 0x30 -#define size_tc 0x320 +#define size_tc 0x300 #define size_thread 0x10 #define size_tlc 0x20 #define size_typed_object 0x10 +#define size_vfasl_header 0x70 #define size_t_bits 0x40 #define snil (ptr)0x26 #define space_char_list (#\n #\i #\x #\q #\w #\e #\p #\k #\c #\r #\s #\t #\l #\I #\y #\z #\d #\D #\e) @@ -986,8 +1026,8 @@ typedef uint64_t U64; #define symbol_pvalue_disp 0xD #define symbol_splist_disp 0x25 #define symbol_value_disp 0x5 -#define tc_DSTBV_disp 0x2C8 -#define tc_SRCBV_disp 0x2D0 +#define tc_DSTBV_disp 0x2A8 +#define tc_SRCBV_disp 0x2B0 #define tc_U_disp 0x180 #define tc_V_disp 0x188 #define tc_W_disp 0x190 @@ -996,7 +1036,7 @@ typedef uint64_t U64; #define tc_ac0_disp 0x38 #define tc_ac1_disp 0x40 #define tc_active_disp 0x144 -#define tc_alloc_counter_disp 0x2B8 +#define tc_alloc_counter_disp 0x298 #define tc_ap_disp 0x60 #define tc_arg_regs_disp 0x0 #define tc_attachments_disp 0x170 @@ -1004,37 +1044,33 @@ typedef uint64_t U64; #define tc_cached_frame_disp 0x178 #define tc_cchain_disp 0x130 #define tc_code_ranges_to_flush_disp 0x138 -#define tc_compile_profile_disp 0x250 -#define tc_compress_format_disp 0x298 -#define tc_compress_level_disp 0x2A0 +#define tc_compile_profile_disp 0x230 +#define tc_compress_format_disp 0x278 +#define tc_compress_level_disp 0x280 #define tc_cp_disp 0x50 #define tc_current_error_disp 0x1F0 #define tc_current_input_disp 0x1E0 #define tc_current_mso_disp 0x208 #define tc_current_output_disp 0x1E8 -#define tc_default_record_equal_procedure_disp 0x288 -#define tc_default_record_hash_procedure_disp 0x290 +#define tc_default_record_equal_procedure_disp 0x268 +#define tc_default_record_hash_procedure_disp 0x270 #define tc_disable_count_disp 0x1B8 #define tc_eap_disp 0x68 #define tc_esp_disp 0x58 -#define tc_fpregs_disp 0x2D8 +#define tc_fpregs_disp 0x2B8 #define tc_fxfirst_bit_set_bv_disp 0x220 #define tc_fxlength_bv_disp 0x218 -#define tc_gc_data_disp 0x318 -#define tc_generate_inspector_information_disp 0x258 -#define tc_generate_procedure_source_information_disp 0x260 -#define tc_generate_profile_forms_disp 0x268 +#define tc_gc_data_disp 0x2F8 +#define tc_generate_inspector_information_disp 0x238 +#define tc_generate_procedure_source_information_disp 0x240 +#define tc_generate_profile_forms_disp 0x248 #define tc_guardian_entries_disp 0x128 -#define tc_instr_counter_disp 0x2B0 +#define tc_instr_counter_disp 0x290 #define tc_keyboard_interrupt_pending_disp 0x1D0 -#define tc_lz4_out_buffer_disp 0x2A8 -#define tc_meta_level_disp 0x248 -#define tc_null_immutable_bytevector_disp 0x238 -#define tc_null_immutable_fxvector_disp 0x230 -#define tc_null_immutable_string_disp 0x240 -#define tc_null_immutable_vector_disp 0x228 -#define tc_optimize_level_disp 0x270 -#define tc_parameters_disp 0x2C0 +#define tc_lz4_out_buffer_disp 0x288 +#define tc_meta_level_disp 0x228 +#define tc_optimize_level_disp 0x250 +#define tc_parameters_disp 0x2A0 #define tc_random_seed_disp 0x140 #define tc_real_eap_disp 0xA0 #define tc_ret_disp 0x70 @@ -1047,8 +1083,8 @@ typedef uint64_t U64; #define tc_something_pending_disp 0x1A8 #define tc_stack_cache_disp 0x150 #define tc_stack_link_disp 0x158 -#define tc_subset_mode_disp 0x278 -#define tc_suppress_primitive_inlining_disp 0x280 +#define tc_subset_mode_disp 0x258 +#define tc_suppress_primitive_inlining_disp 0x260 #define tc_target_machine_disp 0x210 #define tc_td_disp 0x98 #define tc_threadno_disp 0x1D8 @@ -1093,12 +1129,12 @@ typedef uint64_t U64; #define type_exactnum 0x56 #define type_fixnum 0x0 #define type_flonum 0x2 +#define type_flvector 0xB #define type_fxvector 0x3 #define type_guardian_code 0x83E #define type_immediate 0x6 #define type_immutable_box 0x8E #define type_immutable_bytevector 0x5 -#define type_immutable_fxvector 0xB #define type_immutable_string 0xA #define type_immutable_vector 0x8 #define type_inexactnum 0x36 @@ -1106,7 +1142,6 @@ typedef uint64_t U64; #define type_io_port 0x3CE #define type_mutable_box 0xE #define type_mutable_bytevector 0x1 -#define type_mutable_fxvector 0x3 #define type_mutable_string 0x2 #define type_mutable_vector 0x0 #define type_negative_bignum 0x26 @@ -1155,55 +1190,84 @@ typedef uint64_t U64; #define vector_length_factor 0x10 #define vector_length_offset 0x4 #define vector_type_disp 0x1 +#define vfasl_header_data_size_disp 0x0 +#define vfasl_header_result_offset_disp 0x10 +#define vfasl_header_rtdref_count_disp 0x60 +#define vfasl_header_singletonref_count_disp 0x68 +#define vfasl_header_symref_count_disp 0x58 +#define vfasl_header_table_size_disp 0x8 +#define vfasl_header_vspace_rel_offsets_disp 0x18 +#define vfasl_reloc_c_entry_tag 0x1 +#define vfasl_reloc_library_entry_code_tag 0x3 +#define vfasl_reloc_library_entry_tag 0x2 +#define vfasl_reloc_not_a_tag 0x0 +#define vfasl_reloc_singleton_tag 0x5 +#define vfasl_reloc_symbol_tag 0x4 +#define vfasl_reloc_tag_bits 0x3 #define virtual_register_count 0x10 +#define vspace_closure 0x2 +#define vspace_code 0x6 +#define vspace_data 0x7 +#define vspace_impure 0x3 +#define vspace_impure_record 0x5 +#define vspace_pure_typed 0x4 +#define vspace_reloc 0x8 +#define vspace_rtd 0x1 +#define vspace_symbol 0x0 +#define vspaces_count 0x9 +#define vspaces_offsets_count 0x8 #define wchar_bits 0x20 /* constants from declare-c-entries */ -#define CENTRY_Scall_any_results 26 -#define CENTRY_Scall_one_result 25 -#define CENTRY_Sreturn 24 -#define CENTRY_activate_thread 12 -#define CENTRY_bignum_mask_test 28 -#define CENTRY_deactivate_thread 13 -#define CENTRY_flacos 37 -#define CENTRY_flasin 36 -#define CENTRY_flatan 38 -#define CENTRY_flatan2 39 -#define CENTRY_flceiling 30 -#define CENTRY_flcos 34 -#define CENTRY_flexp 40 -#define CENTRY_flexpt 43 -#define CENTRY_flfloor 29 -#define CENTRY_fllog 41 -#define CENTRY_fllog2 42 -#define CENTRY_flround 31 -#define CENTRY_flsin 33 -#define CENTRY_flsqrt 44 -#define CENTRY_fltan 35 -#define CENTRY_fltruncate 32 -#define CENTRY_foreign_entry 19 -#define CENTRY_get_more_room 21 +#define CENTRY_Scall_any_results 27 +#define CENTRY_Scall_one_result 26 +#define CENTRY_Sreturn 25 +#define CENTRY_activate_thread 13 +#define CENTRY_bignum_mask_test 29 +#define CENTRY_deactivate_thread 14 +#define CENTRY_flacos 38 +#define CENTRY_flasin 37 +#define CENTRY_flatan 39 +#define CENTRY_flatan2 40 +#define CENTRY_flceiling 31 +#define CENTRY_flcos 35 +#define CENTRY_flexp 41 +#define CENTRY_flexpt 44 +#define CENTRY_flfloor 30 +#define CENTRY_fllog 42 +#define CENTRY_fllog2 43 +#define CENTRY_flround 32 +#define CENTRY_flsin 34 +#define CENTRY_flsqrt 45 +#define CENTRY_fltan 36 +#define CENTRY_fltruncate 33 +#define CENTRY_foreign_entry 20 +#define CENTRY_get_more_room 22 #define CENTRY_get_thread_context 1 #define CENTRY_handle_apply_overflood 2 -#define CENTRY_handle_arg_error 17 +#define CENTRY_handle_arg_error 18 #define CENTRY_handle_docall_error 3 -#define CENTRY_handle_event_detour 18 -#define CENTRY_handle_mvlet_error 16 +#define CENTRY_handle_event_detour 19 +#define CENTRY_handle_mvlet_error 17 #define CENTRY_handle_nonprocedure_symbol 6 #define CENTRY_handle_overflood 5 #define CENTRY_handle_overflow 4 -#define CENTRY_handle_values_error 15 -#define CENTRY_install_library_entry 20 -#define CENTRY_instantiate_code_object 23 +#define CENTRY_handle_values_error 16 +#define CENTRY_install_library_entry 21 +#define CENTRY_instantiate_code_object 24 +#define CENTRY_null_immutable_bytevector 47 +#define CENTRY_null_immutable_string 48 +#define CENTRY_null_immutable_vector 46 #define CENTRY_raw_collect_cond 9 #define CENTRY_raw_collect_thread0_cond 10 #define CENTRY_raw_tc_mutex 11 -#define CENTRY_scan_remembered_set 22 -#define CENTRY_segment_info 27 +#define CENTRY_raw_terminated_cond 12 +#define CENTRY_scan_remembered_set 23 +#define CENTRY_segment_info 28 #define CENTRY_split_and_resize 8 #define CENTRY_thread_context 0 #define CENTRY_thread_list 7 -#define CENTRY_unactivate_thread 14 +#define CENTRY_unactivate_thread 15 /* displacements for records */ #define eq_hashtable_rtd_disp 1 @@ -1279,6 +1343,8 @@ typedef uint64_t U64; #define SETVECTIT(x,i,y) DIRTYSET((((ptr *)TO_VOIDP((uptr)(x)+9))+i),(y)) #define FXVECTOR_TYPE(x) (*((iptr *)TO_VOIDP((uptr)(x)+1))) #define FXVECTIT(x,i) (((ptr *)TO_VOIDP((uptr)(x)+9))[i]) +#define FLVECTOR_TYPE(x) (*((iptr *)TO_VOIDP((uptr)(x)+1))) +#define FLVECTIT(x,i) (((double *)TO_VOIDP((uptr)(x)+9))[i]) #define BYTEVECTOR_TYPE(x) (*((iptr *)TO_VOIDP((uptr)(x)+1))) #define BVIT(x,i) (((octet *)TO_VOIDP((uptr)(x)+9))[i]) #define STENVECTTYPE(x) (*((iptr *)TO_VOIDP((uptr)(x)+1))) @@ -1334,7 +1400,7 @@ typedef uint64_t U64; #define RTDCOUNTSTYPE(x) (*((iptr *)TO_VOIDP((uptr)(x)+1))) #define RTDCOUNTSTIMESTAMP(x) (*((U64 *)TO_VOIDP((uptr)(x)+9))) #define RTDCOUNTSIT(x,i) (((uptr *)TO_VOIDP((uptr)(x)+17))[i]) -#define RECORDDESCPARENT(x) (*((ptr *)TO_VOIDP((uptr)(x)+9))) +#define RECORDDESCANCESTRY(x) (*((ptr *)TO_VOIDP((uptr)(x)+9))) #define RECORDDESCSIZE(x) (*((ptr *)TO_VOIDP((uptr)(x)+17))) #define RECORDDESCPM(x) (*((ptr *)TO_VOIDP((uptr)(x)+25))) #define RECORDDESCMPM(x) (*((ptr *)TO_VOIDP((uptr)(x)+33))) @@ -1376,9 +1442,16 @@ typedef uint64_t U64; #define RPHEADERTOPLINK(x) (*((uptr *)TO_VOIDP((uptr)(x)+0))) #define RPCOMPACTHEADERMASKANDSIZE(x) (*((iptr *)TO_VOIDP((uptr)(x)+8))) #define RPCOMPACTHEADERTOPLINK(x) (*((uptr *)TO_VOIDP((uptr)(x)+0))) +#define VFASLHEADER_DATA_SIZE(x) (*((uptr *)TO_VOIDP((uptr)(x)+0))) +#define VFASLHEADER_TABLE_SIZE(x) (*((uptr *)TO_VOIDP((uptr)(x)+8))) +#define VFASLHEADER_RESULT_OFFSET(x) (*((uptr *)TO_VOIDP((uptr)(x)+16))) +#define VFASLHEADER_VSPACE_REL_OFFSETS(x,i) (((uptr *)TO_VOIDP((uptr)(x)+24))[i]) +#define VFASLHEADER_SYMREF_COUNT(x) (*((uptr *)TO_VOIDP((uptr)(x)+88))) +#define VFASLHEADER_RTDREF_COUNT(x) (*((uptr *)TO_VOIDP((uptr)(x)+96))) +#define VFASLHEADER_SINGLETONREF_COUNT(x) (*((uptr *)TO_VOIDP((uptr)(x)+104))) /* machine types */ -#define machine_type_names {"any", "i3le", "ti3le", "i3nt", "ti3nt", "i3fb", "ti3fb", "i3ob", "ti3ob", "i3osx", "ti3osx", "a6le", "ta6le", "a6osx", "ta6osx", "a6ob", "ta6ob", "a6s2", "ta6s2", "i3s2", "ti3s2", "a6fb", "ta6fb", "i3nb", "ti3nb", "a6nb", "ta6nb", "a6nt", "ta6nt", "i3qnx", "ti3qnx", "arm32le", "tarm32le", "ppc32le", "tppc32le", "arm64le", "tarm64le", "pb"} +#define machine_type_names {"any", "pb", "i3le", "ti3le", "i3nt", "ti3nt", "i3fb", "ti3fb", "i3ob", "ti3ob", "i3osx", "ti3osx", "a6le", "ta6le", "a6osx", "ta6osx", "a6ob", "ta6ob", "a6s2", "ta6s2", "i3s2", "ti3s2", "a6fb", "ta6fb", "i3nb", "ti3nb", "a6nb", "ta6nb", "a6nt", "ta6nt", "i3qnx", "ti3qnx", "arm32le", "tarm32le", "ppc32le", "tppc32le", "arm64le", "tarm64le", "arm64osx", "tarm64osx", "ppc32osx", "tppc32osx"} /* allocation-space names */ #define alloc_space_names "new", "impure", "symbol", "port", "weakpr", "emph", "pure", "cont", "code", "p-tobj", "ip-rec", "ip-tobj", "closure", "im-impure", "cnt-pure", "cnt-impure", "data", "im-data", "empty" @@ -1391,8 +1464,8 @@ typedef uint64_t U64; #define THREADTC(x) (*((uptr *)TO_VOIDP((uptr)(x)+9))) /* thread-context data */ -#define DSTBV(x) (*((ptr *)TO_VOIDP((uptr)(x)+712))) -#define SRCBV(x) (*((ptr *)TO_VOIDP((uptr)(x)+720))) +#define DSTBV(x) (*((ptr *)TO_VOIDP((uptr)(x)+680))) +#define SRCBV(x) (*((ptr *)TO_VOIDP((uptr)(x)+688))) #define U(x) (*((ptr *)TO_VOIDP((uptr)(x)+384))) #define V(x) (*((ptr *)TO_VOIDP((uptr)(x)+392))) #define W(x) (*((ptr *)TO_VOIDP((uptr)(x)+400))) @@ -1401,7 +1474,7 @@ typedef uint64_t U64; #define AC0(x) (*((xptr *)TO_VOIDP((uptr)(x)+56))) #define AC1(x) (*((xptr *)TO_VOIDP((uptr)(x)+64))) #define ACTIVE(x) (*((I32 *)TO_VOIDP((uptr)(x)+324))) -#define ALLOCCOUNTER(x) (*((U64 *)TO_VOIDP((uptr)(x)+696))) +#define ALLOCCOUNTER(x) (*((U64 *)TO_VOIDP((uptr)(x)+664))) #define AP(x) (*((xptr *)TO_VOIDP((uptr)(x)+96))) #define ARGREGS(x,i) (((xptr *)TO_VOIDP((uptr)(x)+0))[i]) #define ATTACHMENTS(x) (*((ptr *)TO_VOIDP((uptr)(x)+368))) @@ -1409,37 +1482,33 @@ typedef uint64_t U64; #define CACHEDFRAME(x) (*((ptr *)TO_VOIDP((uptr)(x)+376))) #define CCHAIN(x) (*((ptr *)TO_VOIDP((uptr)(x)+304))) #define CODERANGESTOFLUSH(x) (*((ptr *)TO_VOIDP((uptr)(x)+312))) -#define COMPILEPROFILE(x) (*((ptr *)TO_VOIDP((uptr)(x)+592))) -#define COMPRESSFORMAT(x) (*((ptr *)TO_VOIDP((uptr)(x)+664))) -#define COMPRESSLEVEL(x) (*((ptr *)TO_VOIDP((uptr)(x)+672))) +#define COMPILEPROFILE(x) (*((ptr *)TO_VOIDP((uptr)(x)+560))) +#define COMPRESSFORMAT(x) (*((ptr *)TO_VOIDP((uptr)(x)+632))) +#define COMPRESSLEVEL(x) (*((ptr *)TO_VOIDP((uptr)(x)+640))) #define CP(x) (*((xptr *)TO_VOIDP((uptr)(x)+80))) #define CURRENTERROR(x) (*((ptr *)TO_VOIDP((uptr)(x)+496))) #define CURRENTINPUT(x) (*((ptr *)TO_VOIDP((uptr)(x)+480))) #define CURRENTMSO(x) (*((ptr *)TO_VOIDP((uptr)(x)+520))) #define CURRENTOUTPUT(x) (*((ptr *)TO_VOIDP((uptr)(x)+488))) -#define DEFAULTRECORDEQUALPROCEDURE(x) (*((ptr *)TO_VOIDP((uptr)(x)+648))) -#define DEFAULTRECORDHASHPROCEDURE(x) (*((ptr *)TO_VOIDP((uptr)(x)+656))) +#define DEFAULTRECORDEQUALPROCEDURE(x) (*((ptr *)TO_VOIDP((uptr)(x)+616))) +#define DEFAULTRECORDHASHPROCEDURE(x) (*((ptr *)TO_VOIDP((uptr)(x)+624))) #define DISABLECOUNT(x) (*((ptr *)TO_VOIDP((uptr)(x)+440))) #define EAP(x) (*((xptr *)TO_VOIDP((uptr)(x)+104))) #define ESP(x) (*((xptr *)TO_VOIDP((uptr)(x)+88))) -#define FPREGS(x,i) (((double *)TO_VOIDP((uptr)(x)+728))[i]) +#define FPREGS(x,i) (((double *)TO_VOIDP((uptr)(x)+696))[i]) #define FXFIRSTBITSETBV(x) (*((ptr *)TO_VOIDP((uptr)(x)+544))) #define FXLENGTHBV(x) (*((ptr *)TO_VOIDP((uptr)(x)+536))) -#define GCDATA(x) (*((xptr *)TO_VOIDP((uptr)(x)+792))) -#define GENERATEINSPECTORINFORMATION(x) (*((ptr *)TO_VOIDP((uptr)(x)+600))) -#define GENERATEPROCEDURESOURCEINFORMATION(x) (*((ptr *)TO_VOIDP((uptr)(x)+608))) -#define GENERATEPROFILEFORMS(x) (*((ptr *)TO_VOIDP((uptr)(x)+616))) +#define GCDATA(x) (*((xptr *)TO_VOIDP((uptr)(x)+760))) +#define GENERATEINSPECTORINFORMATION(x) (*((ptr *)TO_VOIDP((uptr)(x)+568))) +#define GENERATEPROCEDURESOURCEINFORMATION(x) (*((ptr *)TO_VOIDP((uptr)(x)+576))) +#define GENERATEPROFILEFORMS(x) (*((ptr *)TO_VOIDP((uptr)(x)+584))) #define GUARDIANENTRIES(x) (*((ptr *)TO_VOIDP((uptr)(x)+296))) -#define INSTRCOUNTER(x) (*((U64 *)TO_VOIDP((uptr)(x)+688))) +#define INSTRCOUNTER(x) (*((U64 *)TO_VOIDP((uptr)(x)+656))) #define KEYBOARDINTERRUPTPENDING(x) (*((ptr *)TO_VOIDP((uptr)(x)+464))) -#define LZ4OUTBUFFER(x) (*((xptr *)TO_VOIDP((uptr)(x)+680))) -#define METALEVEL(x) (*((ptr *)TO_VOIDP((uptr)(x)+584))) -#define NULLIMMUTABLEBYTEVECTOR(x) (*((ptr *)TO_VOIDP((uptr)(x)+568))) -#define NULLIMMUTABLEFXVECTOR(x) (*((ptr *)TO_VOIDP((uptr)(x)+560))) -#define NULLIMMUTABLESTRING(x) (*((ptr *)TO_VOIDP((uptr)(x)+576))) -#define NULLIMMUTABLEVECTOR(x) (*((ptr *)TO_VOIDP((uptr)(x)+552))) -#define OPTIMIZELEVEL(x) (*((ptr *)TO_VOIDP((uptr)(x)+624))) -#define PARAMETERS(x) (*((ptr *)TO_VOIDP((uptr)(x)+704))) +#define LZ4OUTBUFFER(x) (*((xptr *)TO_VOIDP((uptr)(x)+648))) +#define METALEVEL(x) (*((ptr *)TO_VOIDP((uptr)(x)+552))) +#define OPTIMIZELEVEL(x) (*((ptr *)TO_VOIDP((uptr)(x)+592))) +#define PARAMETERS(x) (*((ptr *)TO_VOIDP((uptr)(x)+672))) #define RANDOMSEED(x) (*((U32 *)TO_VOIDP((uptr)(x)+320))) #define REAL_EAP(x) (*((xptr *)TO_VOIDP((uptr)(x)+160))) #define RET(x) (*((xptr *)TO_VOIDP((uptr)(x)+112))) @@ -1452,8 +1521,8 @@ typedef uint64_t U64; #define SOMETHINGPENDING(x) (*((ptr *)TO_VOIDP((uptr)(x)+424))) #define STACKCACHE(x) (*((ptr *)TO_VOIDP((uptr)(x)+336))) #define STACKLINK(x) (*((ptr *)TO_VOIDP((uptr)(x)+344))) -#define SUBSETMODE(x) (*((ptr *)TO_VOIDP((uptr)(x)+632))) -#define SUPPRESSPRIMITIVEINLINING(x) (*((ptr *)TO_VOIDP((uptr)(x)+640))) +#define SUBSETMODE(x) (*((ptr *)TO_VOIDP((uptr)(x)+600))) +#define SUPPRESSPRIMITIVEINLINING(x) (*((ptr *)TO_VOIDP((uptr)(x)+608))) #define TARGETMACHINE(x) (*((ptr *)TO_VOIDP((uptr)(x)+528))) #define TD(x) (*((xptr *)TO_VOIDP((uptr)(x)+152))) #define THREADNO(x) (*((ptr *)TO_VOIDP((uptr)(x)+472))) @@ -1470,5 +1539,5 @@ typedef uint64_t U64; /* library entries we access from C code */ #define library_nonprocedure_code 156 #define library_dounderflow 158 -#define library_popcount_slow 602 -#define library_cpu_features 604 +#define library_popcount_slow 616 +#define library_cpu_features 618 diff --git a/src/ChezScheme/boot/pb/gc-ocd.inc b/src/ChezScheme/boot/pb/gc-ocd.inc index 3f4494017e..8d8f066307 100644 --- a/src/ChezScheme/boot/pb/gc-ocd.inc +++ b/src/ChezScheme/boot/pb/gc-ocd.inc @@ -103,6 +103,18 @@ static IGEN copy(thread_gc *tgc, ptr p, seginfo *si, ptr *dest) } } } + else if (TYPEP(tf, mask_flvector, type_flvector)) + { + ISPC p_spc = space_data; + { + uptr sz = size_flvector((Sflvector_length(p))); + { + uptr p_sz = sz; + find_gc_room(tgc, p_spc, tg, type_typed_object, p_sz, new_p); + memcpy_aligned(&FLVECTOR_TYPE(new_p), &FLVECTOR_TYPE(p), sz); + } + } + } else if (TYPEP(tf, mask_bytevector, type_bytevector)) { ISPC p_spc = space_data; @@ -131,9 +143,9 @@ static IGEN copy(thread_gc *tgc, ptr p, seginfo *si, ptr *dest) INITTLCKEYVAL(new_p) = keyval; if ((next != Sfalse) && (OLDSPACE(keyval))) { - GC_TC_MUTEX_ACQUIRE(); + GC_MUTEX_ACQUIRE(); tlcs_to_rehash = S_cons_in(tgc -> tc, space_new, 0, new_p, tlcs_to_rehash); - GC_TC_MUTEX_RELEASE(); + GC_MUTEX_RELEASE(); } } } @@ -160,12 +172,12 @@ static IGEN copy(thread_gc *tgc, ptr p, seginfo *si, ptr *dest) RATTYPE(new_p) = type_ratnum; { ptr tmp_p = RATNUM(p); - relocate_pure(&tmp_p, p, SIZE); + relocate_pure(&tmp_p); RATNUM(new_p) = tmp_p; } { ptr tmp_p = RATDEN(p); - relocate_pure(&tmp_p, p, SIZE); + relocate_pure(&tmp_p); RATDEN(new_p) = tmp_p; } } @@ -179,12 +191,12 @@ static IGEN copy(thread_gc *tgc, ptr p, seginfo *si, ptr *dest) EXACTNUM_TYPE(new_p) = type_exactnum; { ptr tmp_p = EXACTNUM_REAL_PART(p); - relocate_pure(&tmp_p, p, SIZE); + relocate_pure(&tmp_p); EXACTNUM_REAL_PART(new_p) = tmp_p; } { ptr tmp_p = EXACTNUM_IMAG_PART(p); - relocate_pure(&tmp_p, p, SIZE); + relocate_pure(&tmp_p); EXACTNUM_IMAG_PART(new_p) = tmp_p; } } @@ -289,9 +301,9 @@ static IGEN copy(thread_gc *tgc, ptr p, seginfo *si, ptr *dest) find_gc_room(tgc, p_spc, tg, type_typed_object, p_sz, new_p); PHANTOMTYPE(new_p) = type_phantom; PHANTOMLEN(new_p) = PHANTOMLEN(p); - GC_TC_MUTEX_ACQUIRE(); + GC_MUTEX_ACQUIRE(); (S_G.bytesof[tg])[countof_phantom] += PHANTOMLEN(p); - GC_TC_MUTEX_RELEASE(); + GC_MUTEX_RELEASE(); } } else @@ -376,7 +388,7 @@ static IGEN copy(thread_gc *tgc, ptr p, seginfo *si, ptr *dest) else if (t == type_closure) { ptr code = CLOSCODE(p); - relocate_pure(&code, p, SIZE); + relocate_pure(&code); if ((CODETYPE(code)) & (code_flag_continuation << code_flags_offset)) { ISPC p_spc = space_continuation; @@ -387,9 +399,9 @@ static IGEN copy(thread_gc *tgc, ptr p, seginfo *si, ptr *dest) if ((CONTLENGTH(p)) == opportunistic_1_shot_flag) { CONTLENGTH(new_p) = CONTCLENGTH(p); - GC_TC_MUTEX_ACQUIRE(); + GC_MUTEX_ACQUIRE(); conts_to_promote = S_cons_in(tgc -> tc, space_new, 0, new_p, conts_to_promote); - GC_TC_MUTEX_RELEASE(); + GC_MUTEX_RELEASE(); } else { @@ -472,6 +484,7 @@ static IGEN copy(thread_gc *tgc, ptr p, seginfo *si, ptr *dest) static void sweep(thread_gc *tgc, ptr p, IGEN from_g) { + FLUSH_REMOTE_BLOCK { ITYPE t = TYPEBITS(p); if (t == type_typed_object) @@ -479,7 +492,7 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) ptr tf = TYPEFIELD(p); if (TYPEP(tf, mask_record, type_record)) { - relocate_pure(&RECORDINSTTYPE(p), p, size_record_inst((UNFIX((RECORDDESCSIZE(RECORDINSTTYPE(p))))))); + relocate_pure(&RECORDINSTTYPE(p)); { ptr rtd = RECORDINSTTYPE(p); { @@ -497,7 +510,7 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) ptr* ppend = ((ptr*)(TO_VOIDP((((uptr)(TO_PTR(pp))) + len)))) - 1; while (pp < ppend) { - relocate_impure(&(*(pp)), from_g, p, SIZE); + relocate_impure(&(*(pp)), from_g); pp += 1; } } @@ -508,7 +521,7 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) { if (mask & 1) { - relocate_impure(&(*(pp)), from_g, p, SIZE); + relocate_impure(&(*(pp)), from_g); } mask >>= 1; pp += 1; @@ -518,7 +531,7 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) } else { - relocate_pure(&(RECORDDESCPM(rtd)), p, SIZE); + relocate_pure(&(RECORDDESCPM(rtd))); num = RECORDDESCPM(rtd); { iptr index = (BIGLEN(num)) - 1; @@ -530,7 +543,7 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) { if (mask & 1) { - relocate_impure(&(*(pp)), from_g, p, SIZE); + relocate_impure(&(*(pp)), from_g); } mask >>= 1; pp += 1; @@ -559,7 +572,7 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) ptr *p_p = &INITVECTIT(p, 0); for (idx = 0; idx < p_len; idx++) { - relocate_impure(&(p_p[idx]), from_g, p, SIZE); + relocate_impure(&(p_p[idx]), from_g); } } } @@ -571,7 +584,7 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) ptr *p_p = &INITSTENVECTIT(p, 0); for (idx = 0; idx < p_len; idx++) { - relocate_impure(&(p_p[idx]), from_g, p, SIZE); + relocate_impure(&(p_p[idx]), from_g); } } } @@ -581,28 +594,31 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) else if (TYPEP(tf, mask_fxvector, type_fxvector)) { } + else if (TYPEP(tf, mask_flvector, type_flvector)) + { + } else if (TYPEP(tf, mask_bytevector, type_bytevector)) { } else if ((iptr)tf == type_tlc) { - relocate_impure(&INITTLCHT(p), from_g, p, SIZE); - relocate_impure(&INITTLCKEYVAL(p), from_g, p, SIZE); - relocate_impure(&INITTLCNEXT(p), from_g, p, SIZE); + relocate_impure(&INITTLCHT(p), from_g); + relocate_impure(&INITTLCKEYVAL(p), from_g); + relocate_impure(&INITTLCNEXT(p), from_g); } else if (TYPEP(tf, mask_box, type_box)) { - relocate_impure(&INITBOXREF(p), from_g, p, SIZE); + relocate_impure(&INITBOXREF(p), from_g); } else if ((iptr)tf == type_ratnum) { - relocate_pure(&RATNUM(p), p, SIZE); - relocate_pure(&RATDEN(p), p, SIZE); + relocate_pure(&RATNUM(p)); + relocate_pure(&RATDEN(p)); } else if ((iptr)tf == type_exactnum) { - relocate_pure(&EXACTNUM_REAL_PART(p), p, SIZE); - relocate_pure(&EXACTNUM_IMAG_PART(p), p, SIZE); + relocate_pure(&EXACTNUM_REAL_PART(p)); + relocate_pure(&EXACTNUM_IMAG_PART(p)); } else if ((iptr)tf == type_inexactnum) { @@ -612,28 +628,28 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) } else if (TYPEP(tf, mask_port, type_port)) { - relocate_impure(&PORTHANDLER(p), from_g, p, SIZE); + relocate_impure(&PORTHANDLER(p), from_g); if (((uptr)tf) & PORT_FLAG_OUTPUT) { iptr n = ((iptr)(PORTOLAST(p))) - ((iptr)(PORTOBUF(p))); - relocate_impure(&PORTOBUF(p), from_g, p, SIZE); + relocate_impure(&PORTOBUF(p), from_g); PORTOLAST(p) = (ptr)(((iptr)(PORTOBUF(p))) + n); } if (((uptr)tf) & PORT_FLAG_INPUT) { iptr n = ((iptr)(PORTILAST(p))) - ((iptr)(PORTIBUF(p))); - relocate_impure(&PORTIBUF(p), from_g, p, SIZE); + relocate_impure(&PORTIBUF(p), from_g); PORTILAST(p) = (ptr)(((iptr)(PORTIBUF(p))) + n); } - relocate_impure(&PORTINFO(p), from_g, p, SIZE); - relocate_impure(&PORTNAME(p), from_g, p, SIZE); + relocate_impure(&PORTINFO(p), from_g); + relocate_impure(&PORTNAME(p), from_g); } else if (TYPEP(tf, mask_code, type_code)) { - relocate_pure(&CODENAME(p), p, SIZE); - relocate_pure(&CODEARITYMASK(p), p, SIZE); - relocate_pure(&CODEINFO(p), p, SIZE); - relocate_pure(&CODEPINFOS(p), p, SIZE); + relocate_pure(&CODENAME(p)); + relocate_pure(&CODEARITYMASK(p)); + relocate_pure(&CODEINFO(p)); + relocate_pure(&CODEPINFOS(p)); { ptr t = CODERELOC(p); { @@ -670,7 +686,7 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) a = a + code_off; { ptr obj = S_get_code_obj(RELOC_TYPE(entry), oldco, a, item_off); - relocate_pure(&obj, p, SIZE); + relocate_pure(&obj); S_set_code_obj("gc", RELOC_TYPE(entry), p, a, obj, item_off); } } @@ -706,7 +722,7 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) } else { - RECORD_REMOTE_RANGE(tgc, p, SIZE, t_si); + RECORD_REMOTE(t_si); } } } @@ -739,10 +755,10 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) } } STACKCACHE(tc) = Snil; - relocate_pure(&(CCHAIN(tc)), p, SIZE); - relocate_pure(&(STACKLINK(tc)), p, SIZE); - relocate_pure(&(WINDERS(tc)), p, SIZE); - relocate_pure(&(ATTACHMENTS(tc)), p, SIZE); + relocate_pure(&(CCHAIN(tc))); + relocate_pure(&(STACKLINK(tc))); + relocate_pure(&(WINDERS(tc))); + relocate_pure(&(ATTACHMENTS(tc))); CACHEDFRAME(tc) = Sfalse; { ptr xcp = FRAME(tc, 0); @@ -754,7 +770,7 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) seginfo* x_si = SegInfo((ptr_get_segment(c_p))); if (x_si -> old_space) { - relocate_code(c_p, x_si, p, SIZE); + relocate_code(c_p, x_si); FRAME(tc, 0) = (ptr)(((uptr)c_p) + co); } { @@ -784,7 +800,7 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) seginfo* x_si = SegInfo((ptr_get_segment(c_p))); if (x_si -> old_space) { - relocate_code(c_p, x_si, p, SIZE); + relocate_code(c_p, x_si); *(pp) = (ptr)(((uptr)c_p) + co); } { @@ -798,7 +814,7 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) pp += 1; if (mask & 1) { - relocate_pure(&(*(pp)), p, SIZE); + relocate_pure(&(*(pp))); } mask >>= 1; } @@ -812,12 +828,12 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) } else if (SEGMENT_IS_LOCAL(n_si, num)) { - relocate_pure(&(*((ENTRYNONCOMPACTLIVEMASKADDR(oldret)))), p, SIZE); + relocate_pure(&(*((ENTRYNONCOMPACTLIVEMASKADDR(oldret))))); num = ENTRYLIVEMASK(oldret); } else { - RECORD_REMOTE_RANGE(tgc, p, SIZE, n_si); + RECORD_REMOTE(n_si); num = S_G.zero_length_bignum; } { @@ -834,7 +850,7 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) pp += 1; if (mask & 1) { - relocate_pure(&(*(pp)), p, SIZE); + relocate_pure(&(*(pp))); } mask >>= 1; } @@ -854,33 +870,29 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) W(tc) = 0; X(tc) = 0; Y(tc) = 0; - relocate_pure(&(THREADNO(tc)), p, SIZE); - relocate_pure(&(CURRENTINPUT(tc)), p, SIZE); - relocate_pure(&(CURRENTOUTPUT(tc)), p, SIZE); - relocate_pure(&(CURRENTERROR(tc)), p, SIZE); - relocate_pure(&(SFD(tc)), p, SIZE); - relocate_pure(&(CURRENTMSO(tc)), p, SIZE); - relocate_pure(&(TARGETMACHINE(tc)), p, SIZE); - relocate_pure(&(FXLENGTHBV(tc)), p, SIZE); - relocate_pure(&(FXFIRSTBITSETBV(tc)), p, SIZE); - relocate_pure(&(NULLIMMUTABLEVECTOR(tc)), p, SIZE); - relocate_pure(&(NULLIMMUTABLEFXVECTOR(tc)), p, SIZE); - relocate_pure(&(NULLIMMUTABLEBYTEVECTOR(tc)), p, SIZE); - relocate_pure(&(NULLIMMUTABLESTRING(tc)), p, SIZE); - relocate_pure(&(COMPILEPROFILE(tc)), p, SIZE); - relocate_pure(&(SUBSETMODE(tc)), p, SIZE); - relocate_pure(&(DEFAULTRECORDEQUALPROCEDURE(tc)), p, SIZE); - relocate_pure(&(DEFAULTRECORDHASHPROCEDURE(tc)), p, SIZE); - relocate_pure(&(COMPRESSFORMAT(tc)), p, SIZE); - relocate_pure(&(COMPRESSLEVEL(tc)), p, SIZE); - relocate_pure(&(PARAMETERS(tc)), p, SIZE); + relocate_pure(&(THREADNO(tc))); + relocate_pure(&(CURRENTINPUT(tc))); + relocate_pure(&(CURRENTOUTPUT(tc))); + relocate_pure(&(CURRENTERROR(tc))); + relocate_pure(&(SFD(tc))); + relocate_pure(&(CURRENTMSO(tc))); + relocate_pure(&(TARGETMACHINE(tc))); + relocate_pure(&(FXLENGTHBV(tc))); + relocate_pure(&(FXFIRSTBITSETBV(tc))); + relocate_pure(&(COMPILEPROFILE(tc))); + relocate_pure(&(SUBSETMODE(tc))); + relocate_pure(&(DEFAULTRECORDEQUALPROCEDURE(tc))); + relocate_pure(&(DEFAULTRECORDHASHPROCEDURE(tc))); + relocate_pure(&(COMPRESSFORMAT(tc))); + relocate_pure(&(COMPRESSLEVEL(tc))); + relocate_pure(&(PARAMETERS(tc))); DSTBV(tc) = Sfalse; SRCBV(tc) = Sfalse; { INT i = 0; while (i < virtual_register_count) { - relocate_pure(&(VIRTREG(tc, i)), p, SIZE); + relocate_pure(&(VIRTREG(tc, i))); i += 1; } } @@ -915,24 +927,24 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) } else if (p_at_spc == space_weakpair) { - relocate_impure(&INITCDR(p), from_g, p, SIZE); + relocate_impure(&INITCDR(p), from_g); } else { - relocate_impure(&INITCAR(p), from_g, p, SIZE); - relocate_impure(&INITCDR(p), from_g, p, SIZE); + relocate_impure(&INITCAR(p), from_g); + relocate_impure(&INITCDR(p), from_g); } } } else if (t == type_closure) { ptr code = CLOSCODE(p); - relocate_pure(&code, p, SIZE); + relocate_pure(&code); if ((CODETYPE(code)) & (code_flag_continuation << code_flags_offset)) { SETCLOSCODE(p, code); - relocate_pure(&CONTWINDERS(p), p, SIZE); - relocate_impure(&CONTATTACHMENTS(p), from_g, p, SIZE); + relocate_pure(&CONTWINDERS(p)); + relocate_impure(&CONTATTACHMENTS(p), from_g); if ((CONTLENGTH(p)) == scaled_shot_1_shot_flag) { } @@ -945,14 +957,14 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) { if (!(SEGMENT_IS_LOCAL(s_si, stk))) { - RECORD_REMOTE_RANGE(tgc, p, SIZE, s_si); + RECORD_REMOTE(s_si); } else { CONTSTACK(p) = copy_stack(tgc, CONTSTACK(p), &(CONTLENGTH(p)), CONTCLENGTH(p)); } } - relocate_pure(&CONTLINK(p), p, SIZE); + relocate_pure(&CONTLINK(p)); { ptr xcp = CONTRET(p); { @@ -963,7 +975,7 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) seginfo* x_si = SegInfo((ptr_get_segment(c_p))); if (x_si -> old_space) { - relocate_code(c_p, x_si, p, SIZE); + relocate_code(c_p, x_si); CONTRET(p) = (ptr)(((uptr)c_p) + co); } { @@ -995,7 +1007,7 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) seginfo* x_si = SegInfo((ptr_get_segment(c_p))); if (x_si -> old_space) { - relocate_code(c_p, x_si, p, SIZE); + relocate_code(c_p, x_si); *(pp) = (ptr)(((uptr)c_p) + co); } { @@ -1009,7 +1021,7 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) pp += 1; if (mask & 1) { - relocate_pure(&(*(pp)), p, SIZE); + relocate_pure(&(*(pp))); } mask >>= 1; } @@ -1023,12 +1035,12 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) } else if (SEGMENT_IS_LOCAL(n_si, num)) { - relocate_pure(&(*((ENTRYNONCOMPACTLIVEMASKADDR(oldret)))), p, SIZE); + relocate_pure(&(*((ENTRYNONCOMPACTLIVEMASKADDR(oldret))))); num = ENTRYLIVEMASK(oldret); } else { - RECORD_REMOTE_RANGE(tgc, p, SIZE, n_si); + RECORD_REMOTE(n_si); num = S_G.zero_length_bignum; } { @@ -1045,7 +1057,7 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) pp += 1; if (mask & 1) { - relocate_pure(&(*(pp)), p, SIZE); + relocate_pure(&(*(pp))); } mask >>= 1; } @@ -1082,7 +1094,7 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) ptr *p_p = &CLOSIT(p, 0); for (idx = 0; idx < p_len; idx++) { - relocate_impure(&(p_p[idx]), from_g, p, SIZE); + relocate_impure(&(p_p[idx]), from_g); } } } @@ -1094,7 +1106,7 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) ptr *p_p = &CLOSIT(p, 0); for (idx = 0; idx < p_len; idx++) { - relocate_pure(&(p_p[idx]), p, SIZE); + relocate_pure(&(p_p[idx])); } } } @@ -1102,19 +1114,19 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) } else if (t == type_symbol) { - relocate_impure(&INITSYMVAL(p), from_g, p, SIZE); + relocate_impure(&INITSYMVAL(p), from_g); { ptr val = INITSYMVAL(p); { ptr code = ((Sprocedurep(val)) ? (CLOSCODE(val)) : (SYMCODE(p))); - relocate_pure(&code, p, SIZE); + relocate_pure(&code); INITSYMCODE(p, code); - relocate_impure(&INITSYMPLIST(p), from_g, p, SIZE); - relocate_impure(&INITSYMNAME(p), from_g, p, SIZE); - relocate_impure(&INITSYMSPLIST(p), from_g, p, SIZE); - relocate_impure(&INITSYMHASH(p), from_g, p, SIZE); + relocate_impure(&INITSYMPLIST(p), from_g); + relocate_impure(&INITSYMNAME(p), from_g); + relocate_impure(&INITSYMSPLIST(p), from_g); + relocate_impure(&INITSYMHASH(p), from_g); } } } @@ -1126,204 +1138,211 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) S_error_abort("sweep: illegal type"); } } + FLUSH_REMOTE(tgc, p); } static void sweep_object_in_old(thread_gc *tgc, ptr p) { - ITYPE t = TYPEBITS(p); - if (t == type_typed_object) + FLUSH_REMOTE_BLOCK { - ptr tf = TYPEFIELD(p); - if (TYPEP(tf, mask_record, type_record)) + ITYPE t = TYPEBITS(p); + if (t == type_typed_object) { - relocate_pure(&RECORDINSTTYPE(p), p, size_record_inst((UNFIX((RECORDDESCSIZE(RECORDINSTTYPE(p))))))); + ptr tf = TYPEFIELD(p); + if (TYPEP(tf, mask_record, type_record)) { - ptr rtd = RECORDINSTTYPE(p); + relocate_pure(&RECORDINSTTYPE(p)); { - uptr len = UNFIX((RECORDDESCSIZE(rtd))); + ptr rtd = RECORDINSTTYPE(p); { - ptr num = RECORDDESCPM(rtd); - ptr* pp = &(RECORDINSTIT(p, 0)); - if (Sfixnump(num)) + uptr len = UNFIX((RECORDDESCSIZE(rtd))); { + ptr num = RECORDDESCPM(rtd); + ptr* pp = &(RECORDINSTIT(p, 0)); + if (Sfixnump(num)) { - uptr mask = ((uptr)(UNFIX(num))) >> 1; - if (mask == (((uptr)-1) >> 1)) { + uptr mask = ((uptr)(UNFIX(num))) >> 1; + if (mask == (((uptr)-1) >> 1)) { - ptr* ppend = ((ptr*)(TO_VOIDP((((uptr)(TO_PTR(pp))) + len)))) - 1; - while (pp < ppend) { - relocate_indirect((*(pp)), p, SIZE); - pp += 1; + ptr* ppend = ((ptr*)(TO_VOIDP((((uptr)(TO_PTR(pp))) + len)))) - 1; + while (pp < ppend) + { + relocate_indirect((*(pp))); + pp += 1; + } } } - } - else - { - while (mask != 0) + else { - if (mask & 1) + while (mask != 0) { - relocate_indirect((*(pp)), p, SIZE); + if (mask & 1) + { + relocate_indirect((*(pp))); + } + mask >>= 1; + pp += 1; } - mask >>= 1; - pp += 1; } } } - } - else - { - relocate_pure(&(RECORDDESCPM(rtd)), p, SIZE); - num = RECORDDESCPM(rtd); + else { - iptr index = (BIGLEN(num)) - 1; - bigit mask = (BIGIT(num, index)) >> 1; - INT bits = bigit_bits - 1; - while (1) + relocate_pure(&(RECORDDESCPM(rtd))); + num = RECORDDESCPM(rtd); { - do + iptr index = (BIGLEN(num)) - 1; + bigit mask = (BIGIT(num, index)) >> 1; + INT bits = bigit_bits - 1; + while (1) { - if (mask & 1) + do { - relocate_indirect((*(pp)), p, SIZE); + if (mask & 1) + { + relocate_indirect((*(pp))); + } + mask >>= 1; + pp += 1; + bits -= 1; } - mask >>= 1; - pp += 1; - bits -= 1; - } - while (bits > 0); - if (index == 0) - { - break; + while (bits > 0); + if (index == 0) + { + break; + } + index -= 1; + mask = BIGIT(num, index); + bits = bigit_bits; } - index -= 1; - mask = BIGIT(num, index); - bits = bigit_bits; } } } } } } - } - else if (TYPEP(tf, mask_vector, type_vector)) - { - uptr len = Svector_length(p); + else if (TYPEP(tf, mask_vector, type_vector)) { - uptr idx, p_len = len; - ptr *p_p = &INITVECTIT(p, 0); - for (idx = 0; idx < p_len; idx++) + uptr len = Svector_length(p); { - relocate_indirect((p_p[idx]), p, SIZE); + uptr idx, p_len = len; + ptr *p_p = &INITVECTIT(p, 0); + for (idx = 0; idx < p_len; idx++) + { + relocate_indirect((p_p[idx])); + } } } - } - else if (TYPEP(tf, mask_stencil_vector, type_stencil_vector)) - { - uptr len = Sstencil_vector_length(p); + else if (TYPEP(tf, mask_stencil_vector, type_stencil_vector)) { - uptr idx, p_len = len; - ptr *p_p = &INITSTENVECTIT(p, 0); - for (idx = 0; idx < p_len; idx++) + uptr len = Sstencil_vector_length(p); { - relocate_indirect((p_p[idx]), p, SIZE); + uptr idx, p_len = len; + ptr *p_p = &INITSTENVECTIT(p, 0); + for (idx = 0; idx < p_len; idx++) + { + relocate_indirect((p_p[idx])); + } } } - } - else if (TYPEP(tf, mask_string, type_string)) - { - } - else if (TYPEP(tf, mask_fxvector, type_fxvector)) - { - } - else if (TYPEP(tf, mask_bytevector, type_bytevector)) - { - } - else if ((iptr)tf == type_tlc) - { - relocate_indirect(INITTLCHT(p), p, SIZE); - relocate_indirect(INITTLCKEYVAL(p), p, SIZE); - relocate_indirect(INITTLCNEXT(p), p, SIZE); - } - else if (TYPEP(tf, mask_box, type_box)) - { - relocate_indirect(INITBOXREF(p), p, SIZE); - } - else if ((iptr)tf == type_ratnum) - { - relocate_pure(&RATNUM(p), p, SIZE); - relocate_pure(&RATDEN(p), p, SIZE); - } - else if ((iptr)tf == type_exactnum) - { - relocate_pure(&EXACTNUM_REAL_PART(p), p, SIZE); - relocate_pure(&EXACTNUM_IMAG_PART(p), p, SIZE); - } - else if ((iptr)tf == type_inexactnum) - { - } - else if (TYPEP(tf, mask_bignum, type_bignum)) - { - } - else if (TYPEP(tf, mask_port, type_port)) - { - relocate_indirect(PORTHANDLER(p), p, SIZE); - if (((uptr)tf) & PORT_FLAG_OUTPUT) + else if (TYPEP(tf, mask_string, type_string)) { - relocate_indirect(PORTOBUF(p), p, SIZE); } - if (((uptr)tf) & PORT_FLAG_INPUT) + else if (TYPEP(tf, mask_fxvector, type_fxvector)) { - relocate_indirect(PORTIBUF(p), p, SIZE); } - relocate_indirect(PORTINFO(p), p, SIZE); - relocate_indirect(PORTNAME(p), p, SIZE); - } - else if (TYPEP(tf, mask_code, type_code)) - { - relocate_pure(&CODENAME(p), p, SIZE); - relocate_pure(&CODEARITYMASK(p), p, SIZE); - relocate_pure(&CODEINFO(p), p, SIZE); - relocate_pure(&CODEPINFOS(p), p, SIZE); + else if (TYPEP(tf, mask_flvector, type_flvector)) + { + } + else if (TYPEP(tf, mask_bytevector, type_bytevector)) + { + } + else if ((iptr)tf == type_tlc) + { + relocate_indirect(INITTLCHT(p)); + relocate_indirect(INITTLCKEYVAL(p)); + relocate_indirect(INITTLCNEXT(p)); + } + else if (TYPEP(tf, mask_box, type_box)) + { + relocate_indirect(INITBOXREF(p)); + } + else if ((iptr)tf == type_ratnum) + { + relocate_pure(&RATNUM(p)); + relocate_pure(&RATDEN(p)); + } + else if ((iptr)tf == type_exactnum) + { + relocate_pure(&EXACTNUM_REAL_PART(p)); + relocate_pure(&EXACTNUM_IMAG_PART(p)); + } + else if ((iptr)tf == type_inexactnum) + { + } + else if (TYPEP(tf, mask_bignum, type_bignum)) { - ptr t = CODERELOC(p); + } + else if (TYPEP(tf, mask_port, type_port)) + { + relocate_indirect(PORTHANDLER(p)); + if (((uptr)tf) & PORT_FLAG_OUTPUT) { - iptr m = (t - ? (RELOCSIZE(t)) - : 0); + relocate_indirect(PORTOBUF(p)); + } + if (((uptr)tf) & PORT_FLAG_INPUT) + { + relocate_indirect(PORTIBUF(p)); + } + relocate_indirect(PORTINFO(p)); + relocate_indirect(PORTNAME(p)); + } + else if (TYPEP(tf, mask_code, type_code)) + { + relocate_pure(&CODENAME(p)); + relocate_pure(&CODEARITYMASK(p)); + relocate_pure(&CODEINFO(p)); + relocate_pure(&CODEPINFOS(p)); + { + ptr t = CODERELOC(p); { - ptr oldco = (t - ? (RELOCCODE(t)) - : 0); + iptr m = (t + ? (RELOCSIZE(t)) + : 0); { - iptr a = 0; + ptr oldco = (t + ? (RELOCCODE(t)) + : 0); { - iptr n = 0; - while (n < m) + iptr a = 0; { + iptr n = 0; + while (n < m) { - uptr entry = RELOCIT(t, n); - uptr item_off = 0; - uptr code_off = 0; - n = n + 1; - if (RELOC_EXTENDED_FORMAT(entry)) { - item_off = RELOCIT(t, n); - n = n + 1; - code_off = RELOCIT(t, n); + uptr entry = RELOCIT(t, n); + uptr item_off = 0; + uptr code_off = 0; n = n + 1; - } - else - { - item_off = RELOC_ITEM_OFFSET(entry); - code_off = RELOC_CODE_OFFSET(entry); - } - a = a + code_off; - { - ptr obj = S_get_code_obj(RELOC_TYPE(entry), oldco, a, item_off); - relocate_pure(&obj, p, SIZE); + if (RELOC_EXTENDED_FORMAT(entry)) + { + item_off = RELOCIT(t, n); + n = n + 1; + code_off = RELOCIT(t, n); + n = n + 1; + } + else + { + item_off = RELOC_ITEM_OFFSET(entry); + code_off = RELOC_CODE_OFFSET(entry); + } + a = a + code_off; + { + ptr obj = S_get_code_obj(RELOC_TYPE(entry), oldco, a, item_off); + relocate_pure(&obj); + } } } } @@ -1332,109 +1351,109 @@ static void sweep_object_in_old(thread_gc *tgc, ptr p) } } } - } - else if ((iptr)tf == type_thread) - { + else if ((iptr)tf == type_thread) { - ptr tc = (ptr)(THREADTC(p)); - if (tc != ((ptr)0)) { - STACKCACHE(tc) = Snil; - relocate_pure(&(CCHAIN(tc)), p, SIZE); - relocate_pure(&(STACKLINK(tc)), p, SIZE); - relocate_pure(&(WINDERS(tc)), p, SIZE); - relocate_pure(&(ATTACHMENTS(tc)), p, SIZE); + ptr tc = (ptr)(THREADTC(p)); + if (tc != ((ptr)0)) { - ptr xcp = FRAME(tc, 0); + STACKCACHE(tc) = Snil; + relocate_pure(&(CCHAIN(tc))); + relocate_pure(&(STACKLINK(tc))); + relocate_pure(&(WINDERS(tc))); + relocate_pure(&(ATTACHMENTS(tc))); { - iptr co = (ENTRYOFFSET(xcp)) + (((uptr)xcp) - ((uptr)(TO_PTR((ENTRYOFFSETADDR(xcp)))))); + ptr xcp = FRAME(tc, 0); { - ptr c_p = (ptr)(((uptr)xcp) - co); + iptr co = (ENTRYOFFSET(xcp)) + (((uptr)xcp) - ((uptr)(TO_PTR((ENTRYOFFSETADDR(xcp)))))); { - seginfo* x_si = SegInfo((ptr_get_segment(c_p))); - if (x_si -> old_space) - { - relocate_code(c_p, x_si, p, SIZE); - } + ptr c_p = (ptr)(((uptr)xcp) - co); { - uptr base = (uptr)(SCHEMESTACK(tc)); + seginfo* x_si = SegInfo((ptr_get_segment(c_p))); + if (x_si -> old_space) + { + relocate_code(c_p, x_si); + } { - uptr fp = (uptr)(SFP(tc)); + uptr base = (uptr)(SCHEMESTACK(tc)); { - uptr ret = (uptr)(FRAME(tc, 0)); - while (fp != base) + uptr fp = (uptr)(SFP(tc)); { - if (fp < base) - { - S_error_abort("sweep_stack(gc): malformed stack"); - } - fp = fp - (ENTRYFRAMESIZE(ret)); + uptr ret = (uptr)(FRAME(tc, 0)); + while (fp != base) { - ptr* pp = (ptr*)(TO_VOIDP(fp)); - iptr oldret = ret; - ret = (iptr)(*(pp)); + if (fp < base) { - ptr xcp = *(pp); + S_error_abort("sweep_stack(gc): malformed stack"); + } + fp = fp - (ENTRYFRAMESIZE(ret)); + { + ptr* pp = (ptr*)(TO_VOIDP(fp)); + iptr oldret = ret; + ret = (iptr)(*(pp)); { - iptr co = (ENTRYOFFSET(xcp)) + (((uptr)xcp) - ((uptr)(TO_PTR((ENTRYOFFSETADDR(xcp)))))); + ptr xcp = *(pp); { - ptr c_p = (ptr)(((uptr)xcp) - co); + iptr co = (ENTRYOFFSET(xcp)) + (((uptr)xcp) - ((uptr)(TO_PTR((ENTRYOFFSETADDR(xcp)))))); { - seginfo* x_si = SegInfo((ptr_get_segment(c_p))); - if (x_si -> old_space) - { - relocate_code(c_p, x_si, p, SIZE); - } + ptr c_p = (ptr)(((uptr)xcp) - co); { - ptr num = ENTRYLIVEMASK(oldret); - if (Sfixnump(num)) + seginfo* x_si = SegInfo((ptr_get_segment(c_p))); + if (x_si -> old_space) { + relocate_code(c_p, x_si); + } + { + ptr num = ENTRYLIVEMASK(oldret); + if (Sfixnump(num)) { - uptr mask = UNFIX(num); - while (mask != 0) { - pp += 1; - if (mask & 1) + uptr mask = UNFIX(num); + while (mask != 0) { - relocate_pure(&(*(pp)), p, SIZE); + pp += 1; + if (mask & 1) + { + relocate_pure(&(*(pp))); + } + mask >>= 1; } - mask >>= 1; } } - } - else - { - seginfo* n_si = SegInfo((ptr_get_segment(num))); - if (!(n_si -> old_space)) - { - } - else if (SEGMENT_IS_LOCAL(n_si, num)) - { - relocate_pure(&(*((ENTRYNONCOMPACTLIVEMASKADDR(oldret)))), p, SIZE); - num = ENTRYLIVEMASK(oldret); - } else { - RECORD_REMOTE_RANGE(tgc, p, SIZE, n_si); - num = S_G.zero_length_bignum; - } - { - iptr index = BIGLEN(num); - while (index != 0) + seginfo* n_si = SegInfo((ptr_get_segment(num))); + if (!(n_si -> old_space)) + { + } + else if (SEGMENT_IS_LOCAL(n_si, num)) + { + relocate_pure(&(*((ENTRYNONCOMPACTLIVEMASKADDR(oldret))))); + num = ENTRYLIVEMASK(oldret); + } + else { - index -= 1; + RECORD_REMOTE(n_si); + num = S_G.zero_length_bignum; + } + { + iptr index = BIGLEN(num); + while (index != 0) { - INT bits = bigit_bits; - bigit mask = BIGIT(num, index); - while (bits > 0) + index -= 1; { - bits -= 1; - pp += 1; - if (mask & 1) + INT bits = bigit_bits; + bigit mask = BIGIT(num, index); + while (bits > 0) { - relocate_pure(&(*(pp)), p, SIZE); + bits -= 1; + pp += 1; + if (mask & 1) + { + relocate_pure(&(*(pp))); + } + mask >>= 1; } - mask >>= 1; } } } @@ -1446,33 +1465,29 @@ static void sweep_object_in_old(thread_gc *tgc, ptr p) } } } - } - relocate_pure(&(THREADNO(tc)), p, SIZE); - relocate_pure(&(CURRENTINPUT(tc)), p, SIZE); - relocate_pure(&(CURRENTOUTPUT(tc)), p, SIZE); - relocate_pure(&(CURRENTERROR(tc)), p, SIZE); - relocate_pure(&(SFD(tc)), p, SIZE); - relocate_pure(&(CURRENTMSO(tc)), p, SIZE); - relocate_pure(&(TARGETMACHINE(tc)), p, SIZE); - relocate_pure(&(FXLENGTHBV(tc)), p, SIZE); - relocate_pure(&(FXFIRSTBITSETBV(tc)), p, SIZE); - relocate_pure(&(NULLIMMUTABLEVECTOR(tc)), p, SIZE); - relocate_pure(&(NULLIMMUTABLEFXVECTOR(tc)), p, SIZE); - relocate_pure(&(NULLIMMUTABLEBYTEVECTOR(tc)), p, SIZE); - relocate_pure(&(NULLIMMUTABLESTRING(tc)), p, SIZE); - relocate_pure(&(COMPILEPROFILE(tc)), p, SIZE); - relocate_pure(&(SUBSETMODE(tc)), p, SIZE); - relocate_pure(&(DEFAULTRECORDEQUALPROCEDURE(tc)), p, SIZE); - relocate_pure(&(DEFAULTRECORDHASHPROCEDURE(tc)), p, SIZE); - relocate_pure(&(COMPRESSFORMAT(tc)), p, SIZE); - relocate_pure(&(COMPRESSLEVEL(tc)), p, SIZE); - relocate_pure(&(PARAMETERS(tc)), p, SIZE); - { - INT i = 0; - while (i < virtual_register_count) + relocate_pure(&(THREADNO(tc))); + relocate_pure(&(CURRENTINPUT(tc))); + relocate_pure(&(CURRENTOUTPUT(tc))); + relocate_pure(&(CURRENTERROR(tc))); + relocate_pure(&(SFD(tc))); + relocate_pure(&(CURRENTMSO(tc))); + relocate_pure(&(TARGETMACHINE(tc))); + relocate_pure(&(FXLENGTHBV(tc))); + relocate_pure(&(FXFIRSTBITSETBV(tc))); + relocate_pure(&(COMPILEPROFILE(tc))); + relocate_pure(&(SUBSETMODE(tc))); + relocate_pure(&(DEFAULTRECORDEQUALPROCEDURE(tc))); + relocate_pure(&(DEFAULTRECORDHASHPROCEDURE(tc))); + relocate_pure(&(COMPRESSFORMAT(tc))); + relocate_pure(&(COMPRESSLEVEL(tc))); + relocate_pure(&(PARAMETERS(tc))); { - relocate_pure(&(VIRTREG(tc, i)), p, SIZE); - i += 1; + INT i = 0; + while (i < virtual_register_count) + { + relocate_pure(&(VIRTREG(tc, i))); + i += 1; + } } } } @@ -1484,144 +1499,144 @@ static void sweep_object_in_old(thread_gc *tgc, ptr p) } } } - } - else if ((iptr)tf == type_rtd_counts) - { - } - else if ((iptr)tf == type_phantom) - { - } - else - { - S_error_abort("sweep-in-old: illegal typed object type"); - } - } - else if (t == type_pair) - { - { - ISPC p_at_spc = SPACE(p); - if (p_at_spc == space_ephemeron) + else if ((iptr)tf == type_rtd_counts) { } - else if (p_at_spc == space_weakpair) + else if ((iptr)tf == type_phantom) { - relocate_indirect(INITCDR(p), p, SIZE); } else { - relocate_indirect(INITCAR(p), p, SIZE); - relocate_indirect(INITCDR(p), p, SIZE); + S_error_abort("sweep-in-old: illegal typed object type"); } } - } - else if (t == type_closure) - { - ptr code = CLOSCODE(p); - relocate_pure(&code, p, SIZE); - if ((CODETYPE(code)) & (code_flag_continuation << code_flags_offset)) + else if (t == type_pair) { - SETCLOSCODE(p, code); - relocate_pure(&CONTWINDERS(p), p, SIZE); - relocate_indirect(CONTATTACHMENTS(p), p, SIZE); - if ((CONTLENGTH(p)) == scaled_shot_1_shot_flag) { + ISPC p_at_spc = SPACE(p); + if (p_at_spc == space_ephemeron) + { + } + else if (p_at_spc == space_weakpair) + { + relocate_indirect(INITCDR(p)); + } + else + { + relocate_indirect(INITCAR(p)); + relocate_indirect(INITCDR(p)); + } } - else + } + else if (t == type_closure) + { + ptr code = CLOSCODE(p); + relocate_pure(&code); + if ((CODETYPE(code)) & (code_flag_continuation << code_flags_offset)) { - relocate_pure(&CONTLINK(p), p, SIZE); + SETCLOSCODE(p, code); + relocate_pure(&CONTWINDERS(p)); + relocate_indirect(CONTATTACHMENTS(p)); + if ((CONTLENGTH(p)) == scaled_shot_1_shot_flag) { - ptr xcp = CONTRET(p); + } + else + { + relocate_pure(&CONTLINK(p)); { - iptr co = (ENTRYOFFSET(xcp)) + (((uptr)xcp) - ((uptr)(TO_PTR((ENTRYOFFSETADDR(xcp)))))); + ptr xcp = CONTRET(p); { - ptr c_p = (ptr)(((uptr)xcp) - co); + iptr co = (ENTRYOFFSET(xcp)) + (((uptr)xcp) - ((uptr)(TO_PTR((ENTRYOFFSETADDR(xcp)))))); { - seginfo* x_si = SegInfo((ptr_get_segment(c_p))); - if (x_si -> old_space) - { - relocate_code(c_p, x_si, p, SIZE); - } + ptr c_p = (ptr)(((uptr)xcp) - co); { - uptr stack = (uptr)(CONTSTACK(p)); + seginfo* x_si = SegInfo((ptr_get_segment(c_p))); + if (x_si -> old_space) + { + relocate_code(c_p, x_si); + } { - uptr base = stack; + uptr stack = (uptr)(CONTSTACK(p)); { - uptr fp = stack + (CONTCLENGTH(p)); + uptr base = stack; { - uptr ret = (uptr)(CONTRET(p)); - while (fp != base) + uptr fp = stack + (CONTCLENGTH(p)); { - if (fp < base) - { - S_error_abort("sweep_stack(gc): malformed stack"); - } - fp = fp - (ENTRYFRAMESIZE(ret)); + uptr ret = (uptr)(CONTRET(p)); + while (fp != base) { - ptr* pp = (ptr*)(TO_VOIDP(fp)); - iptr oldret = ret; - ret = (iptr)(*(pp)); + if (fp < base) { - ptr xcp = *(pp); + S_error_abort("sweep_stack(gc): malformed stack"); + } + fp = fp - (ENTRYFRAMESIZE(ret)); + { + ptr* pp = (ptr*)(TO_VOIDP(fp)); + iptr oldret = ret; + ret = (iptr)(*(pp)); { - iptr co = (ENTRYOFFSET(xcp)) + (((uptr)xcp) - ((uptr)(TO_PTR((ENTRYOFFSETADDR(xcp)))))); + ptr xcp = *(pp); { - ptr c_p = (ptr)(((uptr)xcp) - co); + iptr co = (ENTRYOFFSET(xcp)) + (((uptr)xcp) - ((uptr)(TO_PTR((ENTRYOFFSETADDR(xcp)))))); { - seginfo* x_si = SegInfo((ptr_get_segment(c_p))); - if (x_si -> old_space) - { - relocate_code(c_p, x_si, p, SIZE); - } + ptr c_p = (ptr)(((uptr)xcp) - co); { - ptr num = ENTRYLIVEMASK(oldret); - if (Sfixnump(num)) + seginfo* x_si = SegInfo((ptr_get_segment(c_p))); + if (x_si -> old_space) + { + relocate_code(c_p, x_si); + } { + ptr num = ENTRYLIVEMASK(oldret); + if (Sfixnump(num)) { - uptr mask = UNFIX(num); - while (mask != 0) { - pp += 1; - if (mask & 1) + uptr mask = UNFIX(num); + while (mask != 0) { - relocate_pure(&(*(pp)), p, SIZE); + pp += 1; + if (mask & 1) + { + relocate_pure(&(*(pp))); + } + mask >>= 1; } - mask >>= 1; } } - } - else - { - seginfo* n_si = SegInfo((ptr_get_segment(num))); - if (!(n_si -> old_space)) - { - } - else if (SEGMENT_IS_LOCAL(n_si, num)) - { - relocate_pure(&(*((ENTRYNONCOMPACTLIVEMASKADDR(oldret)))), p, SIZE); - num = ENTRYLIVEMASK(oldret); - } else { - RECORD_REMOTE_RANGE(tgc, p, SIZE, n_si); - num = S_G.zero_length_bignum; - } - { - iptr index = BIGLEN(num); - while (index != 0) + seginfo* n_si = SegInfo((ptr_get_segment(num))); + if (!(n_si -> old_space)) + { + } + else if (SEGMENT_IS_LOCAL(n_si, num)) + { + relocate_pure(&(*((ENTRYNONCOMPACTLIVEMASKADDR(oldret))))); + num = ENTRYLIVEMASK(oldret); + } + else { - index -= 1; + RECORD_REMOTE(n_si); + num = S_G.zero_length_bignum; + } + { + iptr index = BIGLEN(num); + while (index != 0) { - INT bits = bigit_bits; - bigit mask = BIGIT(num, index); - while (bits > 0) + index -= 1; { - bits -= 1; - pp += 1; - if (mask & 1) + INT bits = bigit_bits; + bigit mask = BIGIT(num, index); + while (bits > 0) { - relocate_pure(&(*(pp)), p, SIZE); + bits -= 1; + pp += 1; + if (mask & 1) + { + relocate_pure(&(*(pp))); + } + mask >>= 1; } - mask >>= 1; } } } @@ -1643,65 +1658,67 @@ static void sweep_object_in_old(thread_gc *tgc, ptr p) } } } - } - else - { - uptr len = CODEFREE(code); - if ((CODETYPE(code)) & (code_flag_mutable_closure << code_flags_offset)) + else { - SETCLOSCODE(p, code); + uptr len = CODEFREE(code); + if ((CODETYPE(code)) & (code_flag_mutable_closure << code_flags_offset)) { - uptr idx, p_len = len; - ptr *p_p = &CLOSIT(p, 0); - for (idx = 0; idx < p_len; idx++) + SETCLOSCODE(p, code); { - relocate_indirect((p_p[idx]), p, SIZE); + uptr idx, p_len = len; + ptr *p_p = &CLOSIT(p, 0); + for (idx = 0; idx < p_len; idx++) + { + relocate_indirect((p_p[idx])); + } } } - } - else - { - SETCLOSCODE(p, code); + else { - uptr idx, p_len = len; - ptr *p_p = &CLOSIT(p, 0); - for (idx = 0; idx < p_len; idx++) + SETCLOSCODE(p, code); { - relocate_pure(&(p_p[idx]), p, SIZE); + uptr idx, p_len = len; + ptr *p_p = &CLOSIT(p, 0); + for (idx = 0; idx < p_len; idx++) + { + relocate_pure(&(p_p[idx])); + } } } } } - } - else if (t == type_symbol) - { - relocate_indirect(INITSYMVAL(p), p, SIZE); + else if (t == type_symbol) { - ptr val = INITSYMVAL(p); + relocate_indirect(INITSYMVAL(p)); { - ptr code = ((Sprocedurep(val)) - ? (CLOSCODE(val)) - : (SYMCODE(p))); - relocate_pure(&code, p, SIZE); - INITSYMCODE(p, code); - relocate_indirect(INITSYMPLIST(p), p, SIZE); - relocate_indirect(INITSYMNAME(p), p, SIZE); - relocate_indirect(INITSYMSPLIST(p), p, SIZE); - relocate_indirect(INITSYMHASH(p), p, SIZE); + ptr val = INITSYMVAL(p); + { + ptr code = ((Sprocedurep(val)) + ? (CLOSCODE(val)) + : (SYMCODE(p))); + relocate_pure(&code); + INITSYMCODE(p, code); + relocate_indirect(INITSYMPLIST(p)); + relocate_indirect(INITSYMNAME(p)); + relocate_indirect(INITSYMSPLIST(p)); + relocate_indirect(INITSYMHASH(p)); + } } } + else if (t == type_flonum) + { + } + else + { + S_error_abort("sweep-in-old: illegal type"); + } } - else if (t == type_flonum) - { - } - else - { - S_error_abort("sweep-in-old: illegal type"); - } + ASSERT_EMPTY_FLUSH_REMOTE(); } static IGEN sweep_dirty_object(thread_gc *tgc, ptr p, IGEN youngest) { + FLUSH_REMOTE_BLOCK { ITYPE t = TYPEBITS(p); if (t == type_typed_object) @@ -1722,7 +1739,7 @@ static IGEN sweep_dirty_object(thread_gc *tgc, ptr p, IGEN youngest) { if (mask & 1) { - relocate_dirty(&(*(pp)), youngest, p, SIZE); + relocate_dirty(&(*(pp)), youngest); } mask >>= 1; pp += 1; @@ -1741,7 +1758,7 @@ static IGEN sweep_dirty_object(thread_gc *tgc, ptr p, IGEN youngest) { if (mask & 1) { - relocate_dirty(&(*(pp)), youngest, p, SIZE); + relocate_dirty(&(*(pp)), youngest); } mask >>= 1; pp += 1; @@ -1769,7 +1786,7 @@ static IGEN sweep_dirty_object(thread_gc *tgc, ptr p, IGEN youngest) ptr *p_p = &INITVECTIT(p, 0); for (idx = 0; idx < p_len; idx++) { - relocate_dirty(&(p_p[idx]), youngest, p, SIZE); + relocate_dirty(&(p_p[idx]), youngest); } } } @@ -1781,7 +1798,7 @@ static IGEN sweep_dirty_object(thread_gc *tgc, ptr p, IGEN youngest) ptr *p_p = &INITSTENVECTIT(p, 0); for (idx = 0; idx < p_len; idx++) { - relocate_dirty(&(p_p[idx]), youngest, p, SIZE); + relocate_dirty(&(p_p[idx]), youngest); } } } @@ -1791,18 +1808,21 @@ static IGEN sweep_dirty_object(thread_gc *tgc, ptr p, IGEN youngest) else if (TYPEP(tf, mask_fxvector, type_fxvector)) { } + else if (TYPEP(tf, mask_flvector, type_flvector)) + { + } else if (TYPEP(tf, mask_bytevector, type_bytevector)) { } else if ((iptr)tf == type_tlc) { - relocate_dirty(&INITTLCHT(p), youngest, p, SIZE); - relocate_dirty(&INITTLCKEYVAL(p), youngest, p, SIZE); - relocate_dirty(&INITTLCNEXT(p), youngest, p, SIZE); + relocate_dirty(&INITTLCHT(p), youngest); + relocate_dirty(&INITTLCKEYVAL(p), youngest); + relocate_dirty(&INITTLCNEXT(p), youngest); } else if (TYPEP(tf, mask_box, type_box)) { - relocate_dirty(&INITBOXREF(p), youngest, p, SIZE); + relocate_dirty(&INITBOXREF(p), youngest); } else if ((iptr)tf == type_ratnum) { @@ -1818,21 +1838,21 @@ static IGEN sweep_dirty_object(thread_gc *tgc, ptr p, IGEN youngest) } else if (TYPEP(tf, mask_port, type_port)) { - relocate_dirty(&PORTHANDLER(p), youngest, p, SIZE); + relocate_dirty(&PORTHANDLER(p), youngest); if (((uptr)tf) & PORT_FLAG_OUTPUT) { iptr n = ((iptr)(PORTOLAST(p))) - ((iptr)(PORTOBUF(p))); - relocate_dirty(&PORTOBUF(p), youngest, p, SIZE); + relocate_dirty(&PORTOBUF(p), youngest); PORTOLAST(p) = (ptr)(((iptr)(PORTOBUF(p))) + n); } if (((uptr)tf) & PORT_FLAG_INPUT) { iptr n = ((iptr)(PORTILAST(p))) - ((iptr)(PORTIBUF(p))); - relocate_dirty(&PORTIBUF(p), youngest, p, SIZE); + relocate_dirty(&PORTIBUF(p), youngest); PORTILAST(p) = (ptr)(((iptr)(PORTIBUF(p))) + n); } - relocate_dirty(&PORTINFO(p), youngest, p, SIZE); - relocate_dirty(&PORTNAME(p), youngest, p, SIZE); + relocate_dirty(&PORTINFO(p), youngest); + relocate_dirty(&PORTNAME(p), youngest); } else if (TYPEP(tf, mask_code, type_code)) { @@ -1861,12 +1881,12 @@ static IGEN sweep_dirty_object(thread_gc *tgc, ptr p, IGEN youngest) } else if (p_at_spc == space_weakpair) { - relocate_dirty(&INITCDR(p), youngest, p, SIZE); + relocate_dirty(&INITCDR(p), youngest); } else { - relocate_dirty(&INITCAR(p), youngest, p, SIZE); - relocate_dirty(&INITCDR(p), youngest, p, SIZE); + relocate_dirty(&INITCAR(p), youngest); + relocate_dirty(&INITCDR(p), youngest); } } } @@ -1882,7 +1902,7 @@ static IGEN sweep_dirty_object(thread_gc *tgc, ptr p, IGEN youngest) ptr *p_p = &CLOSIT(p, 0); for (idx = 0; idx < p_len; idx++) { - relocate_dirty(&(p_p[idx]), youngest, p, SIZE); + relocate_dirty(&(p_p[idx]), youngest); } } } @@ -1890,19 +1910,19 @@ static IGEN sweep_dirty_object(thread_gc *tgc, ptr p, IGEN youngest) } else if (t == type_symbol) { - relocate_dirty(&INITSYMVAL(p), youngest, p, SIZE); + relocate_dirty(&INITSYMVAL(p), youngest); { ptr val = INITSYMVAL(p); { ptr code = ((Sprocedurep(val)) ? (CLOSCODE(val)) : (SYMCODE(p))); - relocate_dirty(&code, youngest, p, SIZE); + relocate_dirty(&code, youngest); INITSYMCODE(p, code); - relocate_dirty(&INITSYMPLIST(p), youngest, p, SIZE); - relocate_dirty(&INITSYMNAME(p), youngest, p, SIZE); - relocate_dirty(&INITSYMSPLIST(p), youngest, p, SIZE); - relocate_dirty(&INITSYMHASH(p), youngest, p, SIZE); + relocate_dirty(&INITSYMPLIST(p), youngest); + relocate_dirty(&INITSYMNAME(p), youngest); + relocate_dirty(&INITSYMSPLIST(p), youngest); + relocate_dirty(&INITSYMHASH(p), youngest); } } } @@ -1914,13 +1934,15 @@ static IGEN sweep_dirty_object(thread_gc *tgc, ptr p, IGEN youngest) S_error_abort("sweep: illegal type"); } } + FLUSH_REMOTE(tgc, p); return youngest; } static void sweep_record(thread_gc *tgc, ptr p, IGEN from_g) { + FLUSH_REMOTE_BLOCK { - relocate_pure(&RECORDINSTTYPE(p), p, size_record_inst((UNFIX((RECORDDESCSIZE(RECORDINSTTYPE(p))))))); + relocate_pure(&RECORDINSTTYPE(p)); { ptr rtd = RECORDINSTTYPE(p); { @@ -1938,7 +1960,7 @@ static void sweep_record(thread_gc *tgc, ptr p, IGEN from_g) ptr* ppend = ((ptr*)(TO_VOIDP((((uptr)(TO_PTR(pp))) + len)))) - 1; while (pp < ppend) { - relocate_impure(&(*(pp)), from_g, p, SIZE); + relocate_impure(&(*(pp)), from_g); pp += 1; } } @@ -1949,7 +1971,7 @@ static void sweep_record(thread_gc *tgc, ptr p, IGEN from_g) { if (mask & 1) { - relocate_impure(&(*(pp)), from_g, p, SIZE); + relocate_impure(&(*(pp)), from_g); } mask >>= 1; pp += 1; @@ -1959,7 +1981,7 @@ static void sweep_record(thread_gc *tgc, ptr p, IGEN from_g) } else { - relocate_pure(&(RECORDDESCPM(rtd)), p, SIZE); + relocate_pure(&(RECORDDESCPM(rtd))); num = RECORDDESCPM(rtd); { iptr index = (BIGLEN(num)) - 1; @@ -1971,7 +1993,7 @@ static void sweep_record(thread_gc *tgc, ptr p, IGEN from_g) { if (mask & 1) { - relocate_impure(&(*(pp)), from_g, p, SIZE); + relocate_impure(&(*(pp)), from_g); } mask >>= 1; pp += 1; @@ -1992,10 +2014,12 @@ static void sweep_record(thread_gc *tgc, ptr p, IGEN from_g) } } } + FLUSH_REMOTE(tgc, p); } static IGEN sweep_dirty_record(thread_gc *tgc, ptr p, IGEN youngest) { + FLUSH_REMOTE_BLOCK { { ptr rtd = RECORDINSTTYPE(p); @@ -2010,7 +2034,7 @@ static IGEN sweep_dirty_record(thread_gc *tgc, ptr p, IGEN youngest) { if (mask & 1) { - relocate_dirty(&(*(pp)), youngest, p, SIZE); + relocate_dirty(&(*(pp)), youngest); } mask >>= 1; pp += 1; @@ -2029,7 +2053,7 @@ static IGEN sweep_dirty_record(thread_gc *tgc, ptr p, IGEN youngest) { if (mask & 1) { - relocate_dirty(&(*(pp)), youngest, p, SIZE); + relocate_dirty(&(*(pp)), youngest); } mask >>= 1; pp += 1; @@ -2049,58 +2073,64 @@ static IGEN sweep_dirty_record(thread_gc *tgc, ptr p, IGEN youngest) } } } + FLUSH_REMOTE(tgc, p); return youngest; } static void sweep_symbol(thread_gc *tgc, ptr p, IGEN from_g) { + FLUSH_REMOTE_BLOCK { { - relocate_impure(&INITSYMVAL(p), from_g, p, SIZE); + relocate_impure(&INITSYMVAL(p), from_g); { ptr val = INITSYMVAL(p); { ptr code = ((Sprocedurep(val)) ? (CLOSCODE(val)) : (SYMCODE(p))); - relocate_pure(&code, p, SIZE); + relocate_pure(&code); INITSYMCODE(p, code); - relocate_impure(&INITSYMPLIST(p), from_g, p, SIZE); - relocate_impure(&INITSYMNAME(p), from_g, p, SIZE); - relocate_impure(&INITSYMSPLIST(p), from_g, p, SIZE); - relocate_impure(&INITSYMHASH(p), from_g, p, SIZE); + relocate_impure(&INITSYMPLIST(p), from_g); + relocate_impure(&INITSYMNAME(p), from_g); + relocate_impure(&INITSYMSPLIST(p), from_g); + relocate_impure(&INITSYMHASH(p), from_g); } } } } + FLUSH_REMOTE(tgc, p); } static IGEN sweep_dirty_symbol(thread_gc *tgc, ptr p, IGEN youngest) { + FLUSH_REMOTE_BLOCK { { - relocate_dirty(&INITSYMVAL(p), youngest, p, SIZE); + relocate_dirty(&INITSYMVAL(p), youngest); { ptr val = INITSYMVAL(p); { ptr code = ((Sprocedurep(val)) ? (CLOSCODE(val)) : (SYMCODE(p))); - relocate_dirty(&code, youngest, p, SIZE); + relocate_dirty(&code, youngest); INITSYMCODE(p, code); - relocate_dirty(&INITSYMPLIST(p), youngest, p, SIZE); - relocate_dirty(&INITSYMNAME(p), youngest, p, SIZE); - relocate_dirty(&INITSYMSPLIST(p), youngest, p, SIZE); - relocate_dirty(&INITSYMHASH(p), youngest, p, SIZE); + relocate_dirty(&INITSYMPLIST(p), youngest); + relocate_dirty(&INITSYMNAME(p), youngest); + relocate_dirty(&INITSYMSPLIST(p), youngest); + relocate_dirty(&INITSYMHASH(p), youngest); } } } } + FLUSH_REMOTE(tgc, p); return youngest; } static void sweep_thread(thread_gc *tgc, ptr p) { + FLUSH_REMOTE_BLOCK { { ptr tc = (ptr)(THREADTC(p)); @@ -2119,10 +2149,10 @@ static void sweep_thread(thread_gc *tgc, ptr p) } } STACKCACHE(tc) = Snil; - relocate_pure(&(CCHAIN(tc)), p, SIZE); - relocate_pure(&(STACKLINK(tc)), p, SIZE); - relocate_pure(&(WINDERS(tc)), p, SIZE); - relocate_pure(&(ATTACHMENTS(tc)), p, SIZE); + relocate_pure(&(CCHAIN(tc))); + relocate_pure(&(STACKLINK(tc))); + relocate_pure(&(WINDERS(tc))); + relocate_pure(&(ATTACHMENTS(tc))); CACHEDFRAME(tc) = Sfalse; { ptr xcp = FRAME(tc, 0); @@ -2134,7 +2164,7 @@ static void sweep_thread(thread_gc *tgc, ptr p) seginfo* x_si = SegInfo((ptr_get_segment(c_p))); if (x_si -> old_space) { - relocate_code(c_p, x_si, p, SIZE); + relocate_code(c_p, x_si); FRAME(tc, 0) = (ptr)(((uptr)c_p) + co); } { @@ -2164,7 +2194,7 @@ static void sweep_thread(thread_gc *tgc, ptr p) seginfo* x_si = SegInfo((ptr_get_segment(c_p))); if (x_si -> old_space) { - relocate_code(c_p, x_si, p, SIZE); + relocate_code(c_p, x_si); *(pp) = (ptr)(((uptr)c_p) + co); } { @@ -2178,7 +2208,7 @@ static void sweep_thread(thread_gc *tgc, ptr p) pp += 1; if (mask & 1) { - relocate_pure(&(*(pp)), p, SIZE); + relocate_pure(&(*(pp))); } mask >>= 1; } @@ -2192,12 +2222,12 @@ static void sweep_thread(thread_gc *tgc, ptr p) } else if (SEGMENT_IS_LOCAL(n_si, num)) { - relocate_pure(&(*((ENTRYNONCOMPACTLIVEMASKADDR(oldret)))), p, SIZE); + relocate_pure(&(*((ENTRYNONCOMPACTLIVEMASKADDR(oldret))))); num = ENTRYLIVEMASK(oldret); } else { - RECORD_REMOTE_RANGE(tgc, p, SIZE, n_si); + RECORD_REMOTE(n_si); num = S_G.zero_length_bignum; } { @@ -2214,7 +2244,7 @@ static void sweep_thread(thread_gc *tgc, ptr p) pp += 1; if (mask & 1) { - relocate_pure(&(*(pp)), p, SIZE); + relocate_pure(&(*(pp))); } mask >>= 1; } @@ -2234,33 +2264,29 @@ static void sweep_thread(thread_gc *tgc, ptr p) W(tc) = 0; X(tc) = 0; Y(tc) = 0; - relocate_pure(&(THREADNO(tc)), p, SIZE); - relocate_pure(&(CURRENTINPUT(tc)), p, SIZE); - relocate_pure(&(CURRENTOUTPUT(tc)), p, SIZE); - relocate_pure(&(CURRENTERROR(tc)), p, SIZE); - relocate_pure(&(SFD(tc)), p, SIZE); - relocate_pure(&(CURRENTMSO(tc)), p, SIZE); - relocate_pure(&(TARGETMACHINE(tc)), p, SIZE); - relocate_pure(&(FXLENGTHBV(tc)), p, SIZE); - relocate_pure(&(FXFIRSTBITSETBV(tc)), p, SIZE); - relocate_pure(&(NULLIMMUTABLEVECTOR(tc)), p, SIZE); - relocate_pure(&(NULLIMMUTABLEFXVECTOR(tc)), p, SIZE); - relocate_pure(&(NULLIMMUTABLEBYTEVECTOR(tc)), p, SIZE); - relocate_pure(&(NULLIMMUTABLESTRING(tc)), p, SIZE); - relocate_pure(&(COMPILEPROFILE(tc)), p, SIZE); - relocate_pure(&(SUBSETMODE(tc)), p, SIZE); - relocate_pure(&(DEFAULTRECORDEQUALPROCEDURE(tc)), p, SIZE); - relocate_pure(&(DEFAULTRECORDHASHPROCEDURE(tc)), p, SIZE); - relocate_pure(&(COMPRESSFORMAT(tc)), p, SIZE); - relocate_pure(&(COMPRESSLEVEL(tc)), p, SIZE); - relocate_pure(&(PARAMETERS(tc)), p, SIZE); + relocate_pure(&(THREADNO(tc))); + relocate_pure(&(CURRENTINPUT(tc))); + relocate_pure(&(CURRENTOUTPUT(tc))); + relocate_pure(&(CURRENTERROR(tc))); + relocate_pure(&(SFD(tc))); + relocate_pure(&(CURRENTMSO(tc))); + relocate_pure(&(TARGETMACHINE(tc))); + relocate_pure(&(FXLENGTHBV(tc))); + relocate_pure(&(FXFIRSTBITSETBV(tc))); + relocate_pure(&(COMPILEPROFILE(tc))); + relocate_pure(&(SUBSETMODE(tc))); + relocate_pure(&(DEFAULTRECORDEQUALPROCEDURE(tc))); + relocate_pure(&(DEFAULTRECORDHASHPROCEDURE(tc))); + relocate_pure(&(COMPRESSFORMAT(tc))); + relocate_pure(&(COMPRESSLEVEL(tc))); + relocate_pure(&(PARAMETERS(tc))); DSTBV(tc) = Sfalse; SRCBV(tc) = Sfalse; { INT i = 0; while (i < virtual_register_count) { - relocate_pure(&(VIRTREG(tc, i)), p, SIZE); + relocate_pure(&(VIRTREG(tc, i))); i += 1; } } @@ -2274,57 +2300,63 @@ static void sweep_thread(thread_gc *tgc, ptr p) } } } + FLUSH_REMOTE(tgc, p); } static void sweep_port(thread_gc *tgc, ptr p, IGEN from_g) { + FLUSH_REMOTE_BLOCK { - relocate_impure(&PORTHANDLER(p), from_g, p, SIZE); + relocate_impure(&PORTHANDLER(p), from_g); if (((uptr)TYPEFIELD(p)) & PORT_FLAG_OUTPUT) { iptr n = ((iptr)(PORTOLAST(p))) - ((iptr)(PORTOBUF(p))); - relocate_impure(&PORTOBUF(p), from_g, p, SIZE); + relocate_impure(&PORTOBUF(p), from_g); PORTOLAST(p) = (ptr)(((iptr)(PORTOBUF(p))) + n); } if (((uptr)TYPEFIELD(p)) & PORT_FLAG_INPUT) { iptr n = ((iptr)(PORTILAST(p))) - ((iptr)(PORTIBUF(p))); - relocate_impure(&PORTIBUF(p), from_g, p, SIZE); + relocate_impure(&PORTIBUF(p), from_g); PORTILAST(p) = (ptr)(((iptr)(PORTIBUF(p))) + n); } - relocate_impure(&PORTINFO(p), from_g, p, SIZE); - relocate_impure(&PORTNAME(p), from_g, p, SIZE); + relocate_impure(&PORTINFO(p), from_g); + relocate_impure(&PORTNAME(p), from_g); } + FLUSH_REMOTE(tgc, p); } static IGEN sweep_dirty_port(thread_gc *tgc, ptr p, IGEN youngest) { + FLUSH_REMOTE_BLOCK { - relocate_dirty(&PORTHANDLER(p), youngest, p, SIZE); + relocate_dirty(&PORTHANDLER(p), youngest); if (((uptr)TYPEFIELD(p)) & PORT_FLAG_OUTPUT) { iptr n = ((iptr)(PORTOLAST(p))) - ((iptr)(PORTOBUF(p))); - relocate_dirty(&PORTOBUF(p), youngest, p, SIZE); + relocate_dirty(&PORTOBUF(p), youngest); PORTOLAST(p) = (ptr)(((iptr)(PORTOBUF(p))) + n); } if (((uptr)TYPEFIELD(p)) & PORT_FLAG_INPUT) { iptr n = ((iptr)(PORTILAST(p))) - ((iptr)(PORTIBUF(p))); - relocate_dirty(&PORTIBUF(p), youngest, p, SIZE); + relocate_dirty(&PORTIBUF(p), youngest); PORTILAST(p) = (ptr)(((iptr)(PORTIBUF(p))) + n); } - relocate_dirty(&PORTINFO(p), youngest, p, SIZE); - relocate_dirty(&PORTNAME(p), youngest, p, SIZE); + relocate_dirty(&PORTINFO(p), youngest); + relocate_dirty(&PORTNAME(p), youngest); } + FLUSH_REMOTE(tgc, p); return youngest; } static void sweep_continuation(thread_gc *tgc, ptr p, IGEN from_g) { + FLUSH_REMOTE_BLOCK { { - relocate_pure(&CONTWINDERS(p), p, SIZE); - relocate_impure(&CONTATTACHMENTS(p), from_g, p, SIZE); + relocate_pure(&CONTWINDERS(p)); + relocate_impure(&CONTATTACHMENTS(p), from_g); if ((CONTLENGTH(p)) == scaled_shot_1_shot_flag) { } @@ -2337,14 +2369,14 @@ static void sweep_continuation(thread_gc *tgc, ptr p, IGEN from_g) { if (!(SEGMENT_IS_LOCAL(s_si, stk))) { - RECORD_REMOTE_RANGE(tgc, p, SIZE, s_si); + RECORD_REMOTE(s_si); } else { CONTSTACK(p) = copy_stack(tgc, CONTSTACK(p), &(CONTLENGTH(p)), CONTCLENGTH(p)); } } - relocate_pure(&CONTLINK(p), p, SIZE); + relocate_pure(&CONTLINK(p)); { ptr xcp = CONTRET(p); { @@ -2355,7 +2387,7 @@ static void sweep_continuation(thread_gc *tgc, ptr p, IGEN from_g) seginfo* x_si = SegInfo((ptr_get_segment(c_p))); if (x_si -> old_space) { - relocate_code(c_p, x_si, p, SIZE); + relocate_code(c_p, x_si); CONTRET(p) = (ptr)(((uptr)c_p) + co); } { @@ -2387,7 +2419,7 @@ static void sweep_continuation(thread_gc *tgc, ptr p, IGEN from_g) seginfo* x_si = SegInfo((ptr_get_segment(c_p))); if (x_si -> old_space) { - relocate_code(c_p, x_si, p, SIZE); + relocate_code(c_p, x_si); *(pp) = (ptr)(((uptr)c_p) + co); } { @@ -2401,7 +2433,7 @@ static void sweep_continuation(thread_gc *tgc, ptr p, IGEN from_g) pp += 1; if (mask & 1) { - relocate_pure(&(*(pp)), p, SIZE); + relocate_pure(&(*(pp))); } mask >>= 1; } @@ -2415,12 +2447,12 @@ static void sweep_continuation(thread_gc *tgc, ptr p, IGEN from_g) } else if (SEGMENT_IS_LOCAL(n_si, num)) { - relocate_pure(&(*((ENTRYNONCOMPACTLIVEMASKADDR(oldret)))), p, SIZE); + relocate_pure(&(*((ENTRYNONCOMPACTLIVEMASKADDR(oldret))))); num = ENTRYLIVEMASK(oldret); } else { - RECORD_REMOTE_RANGE(tgc, p, SIZE, n_si); + RECORD_REMOTE(n_si); num = S_G.zero_length_bignum; } { @@ -2437,7 +2469,7 @@ static void sweep_continuation(thread_gc *tgc, ptr p, IGEN from_g) pp += 1; if (mask & 1) { - relocate_pure(&(*(pp)), p, SIZE); + relocate_pure(&(*(pp))); } mask >>= 1; } @@ -2464,15 +2496,17 @@ static void sweep_continuation(thread_gc *tgc, ptr p, IGEN from_g) } } } + FLUSH_REMOTE(tgc, p); } static void sweep_code_object(thread_gc *tgc, ptr p, IGEN from_g) { + FLUSH_REMOTE_BLOCK { - relocate_pure(&CODENAME(p), p, SIZE); - relocate_pure(&CODEARITYMASK(p), p, SIZE); - relocate_pure(&CODEINFO(p), p, SIZE); - relocate_pure(&CODEPINFOS(p), p, SIZE); + relocate_pure(&CODENAME(p)); + relocate_pure(&CODEARITYMASK(p)); + relocate_pure(&CODEINFO(p)); + relocate_pure(&CODEPINFOS(p)); { ptr t = CODERELOC(p); { @@ -2509,7 +2543,7 @@ static void sweep_code_object(thread_gc *tgc, ptr p, IGEN from_g) a = a + code_off; { ptr obj = S_get_code_obj(RELOC_TYPE(entry), oldco, a, item_off); - relocate_pure(&obj, p, SIZE); + relocate_pure(&obj); S_set_code_obj("gc", RELOC_TYPE(entry), p, a, obj, item_off); } } @@ -2545,7 +2579,7 @@ static void sweep_code_object(thread_gc *tgc, ptr p, IGEN from_g) } else { - RECORD_REMOTE_RANGE(tgc, p, SIZE, t_si); + RECORD_REMOTE(t_si); } } } @@ -2559,6 +2593,7 @@ static void sweep_code_object(thread_gc *tgc, ptr p, IGEN from_g) } } } + FLUSH_REMOTE(tgc, p); } static uptr size_object(ptr p) @@ -2612,6 +2647,14 @@ static uptr size_object(ptr p) return p_sz; } } + else if (TYPEP(tf, mask_flvector, type_flvector)) + { + uptr sz = size_flvector((Sflvector_length(p))); + { + uptr p_sz = sz; + return p_sz; + } + } else if (TYPEP(tf, mask_bytevector, type_bytevector)) { uptr sz = size_bytevector((Sbytevector_length(p))); @@ -2921,6 +2964,42 @@ static IGEN mark_object(thread_gc *tgc, ptr p, seginfo *si) } } } + else if (TYPEP(tf, mask_flvector, type_flvector)) + { + uptr sz = size_flvector((Sflvector_length(p))); + { + uptr p_sz = sz; + si->marked_mask[segment_bitmap_byte(p)] |= segment_bitmap_bit(p); + { + uptr addr = (uptr)UNTYPE(p, type_typed_object); + uptr seg = addr_get_segment(addr); + uptr end_seg = addr_get_segment(addr + p_sz - 1); + if (seg == end_seg) { + si->marked_count += p_sz; + } else { + seginfo *mark_si; IGEN g; + si->marked_count += ((uptr)build_ptr(seg+1,0)) - addr; + seg++; + while (seg < end_seg) { + mark_si = SegInfo(seg); + g = mark_si->generation; + if (!fully_marked_mask[g]) init_fully_marked_mask(tgc, g); + mark_si->marked_mask = fully_marked_mask[g]; + mark_si->marked_count = bytes_per_segment; + seg++; + } + mark_si = SegInfo(end_seg); + { + if (!mark_si->marked_mask) { + init_mask(tgc, mark_si->marked_mask, mark_si->generation, 0); + } + /* no need to set a bit: it's enough to have made `marked_mask` non-NULL */ + mark_si->marked_count += addr + p_sz - (uptr)build_ptr(end_seg,0); + } + } + } + } + } else if (TYPEP(tf, mask_bytevector, type_bytevector)) { uptr sz = size_bytevector((Sbytevector_length(p))); @@ -2974,9 +3053,9 @@ static IGEN mark_object(thread_gc *tgc, ptr p, seginfo *si) ptr keyval = INITTLCKEYVAL(p); if ((next != Sfalse) && (OLDSPACE(keyval))) { - GC_TC_MUTEX_ACQUIRE(); + GC_MUTEX_ACQUIRE(); tlcs_to_rehash = S_cons_in(tgc -> tc, space_new, 0, p, tlcs_to_rehash); - GC_TC_MUTEX_RELEASE(); + GC_MUTEX_RELEASE(); } } } @@ -2991,8 +3070,8 @@ static IGEN mark_object(thread_gc *tgc, ptr p, seginfo *si) else if ((iptr)tf == type_ratnum) { uptr p_sz = size_ratnum; - relocate_pure(&RATNUM(p), p, SIZE); - relocate_pure(&RATDEN(p), p, SIZE); + relocate_pure(&RATNUM(p)); + relocate_pure(&RATDEN(p)); si->marked_count += p_sz; { ptr mark_p = p; @@ -3005,8 +3084,8 @@ static IGEN mark_object(thread_gc *tgc, ptr p, seginfo *si) else if ((iptr)tf == type_exactnum) { uptr p_sz = size_exactnum; - relocate_pure(&EXACTNUM_REAL_PART(p), p, SIZE); - relocate_pure(&EXACTNUM_IMAG_PART(p), p, SIZE); + relocate_pure(&EXACTNUM_REAL_PART(p)); + relocate_pure(&EXACTNUM_IMAG_PART(p)); si->marked_count += p_sz; { ptr mark_p = p; @@ -3120,9 +3199,9 @@ static IGEN mark_object(thread_gc *tgc, ptr p, seginfo *si) uptr p_sz = size_phantom; si->marked_mask[segment_bitmap_byte(p)] |= segment_bitmap_bit(p); si->marked_count += p_sz; - GC_TC_MUTEX_ACQUIRE(); + GC_MUTEX_ACQUIRE(); (S_G.bytesof[TARGET_GENERATION(si)])[countof_phantom] += PHANTOMLEN(p); - GC_TC_MUTEX_RELEASE(); + GC_MUTEX_RELEASE(); } else { @@ -3159,16 +3238,16 @@ static IGEN mark_object(thread_gc *tgc, ptr p, seginfo *si) else if (t == type_closure) { ptr code = CLOSCODE(p); - relocate_pure(&code, p, SIZE); + relocate_pure(&code); if ((CODETYPE(code)) & (code_flag_continuation << code_flags_offset)) { uptr p_sz = size_continuation; if ((CONTLENGTH(p)) == opportunistic_1_shot_flag) { CONTLENGTH(p) = CONTCLENGTH(p); - GC_TC_MUTEX_ACQUIRE(); + GC_MUTEX_ACQUIRE(); conts_to_promote = S_cons_in(tgc -> tc, space_new, 0, p, conts_to_promote); - GC_TC_MUTEX_RELEASE(); + GC_MUTEX_RELEASE(); } else { @@ -3387,6 +3466,9 @@ static IBOOL object_directly_refers_to_self(ptr p) else if (TYPEP(tf, mask_fxvector, type_fxvector)) { } + else if (TYPEP(tf, mask_flvector, type_flvector)) + { + } else if (TYPEP(tf, mask_bytevector, type_bytevector)) { } diff --git a/src/ChezScheme/boot/pb/gc-oce.inc b/src/ChezScheme/boot/pb/gc-oce.inc index 77d3fe68f2..651e849b60 100644 --- a/src/ChezScheme/boot/pb/gc-oce.inc +++ b/src/ChezScheme/boot/pb/gc-oce.inc @@ -16,7 +16,7 @@ static IGEN copy(thread_gc *tgc, ptr p, seginfo *si, ptr *dest) on tag-reflexive base descriptor */ if (p != tf) { - relocate_pure(&RECORDINSTTYPE(p), p, SIZE); + relocate_pure(&RECORDINSTTYPE(p)); } { ptr rtd = RECORDINSTTYPE(p); @@ -82,7 +82,7 @@ static IGEN copy(thread_gc *tgc, ptr p, seginfo *si, ptr *dest) } else { - relocate_pure(&counts, p, SIZE); + relocate_pure(&counts); RECORDDESCCOUNTS(c_rtd) = counts; if ((RTDCOUNTSTIMESTAMP(counts)) != (S_G.gctimestamp[0])) { @@ -176,6 +176,20 @@ static IGEN copy(thread_gc *tgc, ptr p, seginfo *si, ptr *dest) } } } + else if (TYPEP(tf, mask_flvector, type_flvector)) + { + ISPC p_spc = space_data; + { + uptr sz = size_flvector((Sflvector_length(p))); + { + uptr p_sz = sz; + find_gc_room(tgc, p_spc, tg, type_typed_object, p_sz, new_p); + memcpy_aligned(&FLVECTOR_TYPE(new_p), &FLVECTOR_TYPE(p), sz); + S_G.countof[tg][countof_flvector] += 1; + S_G.bytesof[tg][countof_flvector] += p_sz; + } + } + } else if (TYPEP(tf, mask_bytevector, type_bytevector)) { ISPC p_spc = space_data; @@ -208,9 +222,9 @@ static IGEN copy(thread_gc *tgc, ptr p, seginfo *si, ptr *dest) INITTLCKEYVAL(new_p) = keyval; if ((next != Sfalse) && (OLDSPACE(keyval))) { - GC_TC_MUTEX_ACQUIRE(); + GC_MUTEX_ACQUIRE(); tlcs_to_rehash = S_cons_in(tgc -> tc, space_new, 0, new_p, tlcs_to_rehash); - GC_TC_MUTEX_RELEASE(); + GC_MUTEX_RELEASE(); } S_G.countof[tg][countof_tlc] += 1; } @@ -243,12 +257,12 @@ static IGEN copy(thread_gc *tgc, ptr p, seginfo *si, ptr *dest) RATTYPE(new_p) = type_ratnum; { ptr tmp_p = RATNUM(p); - relocate_pure(&tmp_p, p, SIZE); + relocate_pure(&tmp_p); RATNUM(new_p) = tmp_p; } { ptr tmp_p = RATDEN(p); - relocate_pure(&tmp_p, p, SIZE); + relocate_pure(&tmp_p); RATDEN(new_p) = tmp_p; } S_G.countof[tg][countof_ratnum] += 1; @@ -263,12 +277,12 @@ static IGEN copy(thread_gc *tgc, ptr p, seginfo *si, ptr *dest) EXACTNUM_TYPE(new_p) = type_exactnum; { ptr tmp_p = EXACTNUM_REAL_PART(p); - relocate_pure(&tmp_p, p, SIZE); + relocate_pure(&tmp_p); EXACTNUM_REAL_PART(new_p) = tmp_p; } { ptr tmp_p = EXACTNUM_IMAG_PART(p); - relocate_pure(&tmp_p, p, SIZE); + relocate_pure(&tmp_p); EXACTNUM_IMAG_PART(new_p) = tmp_p; } S_G.countof[tg][countof_exactnum] += 1; @@ -385,9 +399,9 @@ static IGEN copy(thread_gc *tgc, ptr p, seginfo *si, ptr *dest) PHANTOMTYPE(new_p) = type_phantom; PHANTOMLEN(new_p) = PHANTOMLEN(p); S_G.countof[tg][countof_phantom] += 1; - GC_TC_MUTEX_ACQUIRE(); + GC_MUTEX_ACQUIRE(); (S_G.bytesof[tg])[countof_phantom] += PHANTOMLEN(p); - GC_TC_MUTEX_RELEASE(); + GC_MUTEX_RELEASE(); } } else @@ -479,7 +493,7 @@ static IGEN copy(thread_gc *tgc, ptr p, seginfo *si, ptr *dest) else if (t == type_closure) { ptr code = CLOSCODE(p); - relocate_pure(&code, p, SIZE); + relocate_pure(&code); if ((CODETYPE(code)) & (code_flag_continuation << code_flags_offset)) { ISPC p_spc = ((is_counting_root(si, p)) @@ -492,9 +506,9 @@ static IGEN copy(thread_gc *tgc, ptr p, seginfo *si, ptr *dest) if ((CONTLENGTH(p)) == opportunistic_1_shot_flag) { CONTLENGTH(new_p) = CONTCLENGTH(p); - GC_TC_MUTEX_ACQUIRE(); + GC_MUTEX_ACQUIRE(); conts_to_promote = S_cons_in(tgc -> tc, space_new, 0, new_p, conts_to_promote); - GC_TC_MUTEX_RELEASE(); + GC_MUTEX_RELEASE(); } else { @@ -587,6 +601,7 @@ static IGEN copy(thread_gc *tgc, ptr p, seginfo *si, ptr *dest) static void sweep(thread_gc *tgc, ptr p, IGEN from_g) { + FLUSH_REMOTE_BLOCK PUSH_BACKREFERENCE(p) { ITYPE t = TYPEBITS(p); @@ -595,7 +610,7 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) ptr tf = TYPEFIELD(p); if (TYPEP(tf, mask_record, type_record)) { - relocate_pure(&RECORDINSTTYPE(p), p, size_record_inst((UNFIX((RECORDDESCSIZE(RECORDINSTTYPE(p))))))); + relocate_pure(&RECORDINSTTYPE(p)); { ptr rtd = RECORDINSTTYPE(p); { @@ -613,7 +628,7 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) ptr* ppend = ((ptr*)(TO_VOIDP((((uptr)(TO_PTR(pp))) + len)))) - 1; while (pp < ppend) { - relocate_impure(&(*(pp)), from_g, p, SIZE); + relocate_impure(&(*(pp)), from_g); pp += 1; } } @@ -624,7 +639,7 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) { if (mask & 1) { - relocate_impure(&(*(pp)), from_g, p, SIZE); + relocate_impure(&(*(pp)), from_g); } mask >>= 1; pp += 1; @@ -634,7 +649,7 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) } else { - relocate_pure(&(RECORDDESCPM(rtd)), p, SIZE); + relocate_pure(&(RECORDDESCPM(rtd))); num = RECORDDESCPM(rtd); { iptr index = (BIGLEN(num)) - 1; @@ -646,7 +661,7 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) { if (mask & 1) { - relocate_impure(&(*(pp)), from_g, p, SIZE); + relocate_impure(&(*(pp)), from_g); } mask >>= 1; pp += 1; @@ -675,7 +690,7 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) ptr *p_p = &INITVECTIT(p, 0); for (idx = 0; idx < p_len; idx++) { - relocate_impure(&(p_p[idx]), from_g, p, SIZE); + relocate_impure(&(p_p[idx]), from_g); } } } @@ -687,7 +702,7 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) ptr *p_p = &INITSTENVECTIT(p, 0); for (idx = 0; idx < p_len; idx++) { - relocate_impure(&(p_p[idx]), from_g, p, SIZE); + relocate_impure(&(p_p[idx]), from_g); } } } @@ -697,28 +712,31 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) else if (TYPEP(tf, mask_fxvector, type_fxvector)) { } + else if (TYPEP(tf, mask_flvector, type_flvector)) + { + } else if (TYPEP(tf, mask_bytevector, type_bytevector)) { } else if ((iptr)tf == type_tlc) { - relocate_impure(&INITTLCHT(p), from_g, p, SIZE); - relocate_impure(&INITTLCKEYVAL(p), from_g, p, SIZE); - relocate_impure(&INITTLCNEXT(p), from_g, p, SIZE); + relocate_impure(&INITTLCHT(p), from_g); + relocate_impure(&INITTLCKEYVAL(p), from_g); + relocate_impure(&INITTLCNEXT(p), from_g); } else if (TYPEP(tf, mask_box, type_box)) { - relocate_impure(&INITBOXREF(p), from_g, p, SIZE); + relocate_impure(&INITBOXREF(p), from_g); } else if ((iptr)tf == type_ratnum) { - relocate_pure(&RATNUM(p), p, SIZE); - relocate_pure(&RATDEN(p), p, SIZE); + relocate_pure(&RATNUM(p)); + relocate_pure(&RATDEN(p)); } else if ((iptr)tf == type_exactnum) { - relocate_pure(&EXACTNUM_REAL_PART(p), p, SIZE); - relocate_pure(&EXACTNUM_IMAG_PART(p), p, SIZE); + relocate_pure(&EXACTNUM_REAL_PART(p)); + relocate_pure(&EXACTNUM_IMAG_PART(p)); } else if ((iptr)tf == type_inexactnum) { @@ -728,28 +746,28 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) } else if (TYPEP(tf, mask_port, type_port)) { - relocate_impure(&PORTHANDLER(p), from_g, p, SIZE); + relocate_impure(&PORTHANDLER(p), from_g); if (((uptr)tf) & PORT_FLAG_OUTPUT) { iptr n = ((iptr)(PORTOLAST(p))) - ((iptr)(PORTOBUF(p))); - relocate_impure(&PORTOBUF(p), from_g, p, SIZE); + relocate_impure(&PORTOBUF(p), from_g); PORTOLAST(p) = (ptr)(((iptr)(PORTOBUF(p))) + n); } if (((uptr)tf) & PORT_FLAG_INPUT) { iptr n = ((iptr)(PORTILAST(p))) - ((iptr)(PORTIBUF(p))); - relocate_impure(&PORTIBUF(p), from_g, p, SIZE); + relocate_impure(&PORTIBUF(p), from_g); PORTILAST(p) = (ptr)(((iptr)(PORTIBUF(p))) + n); } - relocate_impure(&PORTINFO(p), from_g, p, SIZE); - relocate_impure(&PORTNAME(p), from_g, p, SIZE); + relocate_impure(&PORTINFO(p), from_g); + relocate_impure(&PORTNAME(p), from_g); } else if (TYPEP(tf, mask_code, type_code)) { - relocate_pure(&CODENAME(p), p, SIZE); - relocate_pure(&CODEARITYMASK(p), p, SIZE); - relocate_pure(&CODEINFO(p), p, SIZE); - relocate_pure(&CODEPINFOS(p), p, SIZE); + relocate_pure(&CODENAME(p)); + relocate_pure(&CODEARITYMASK(p)); + relocate_pure(&CODEINFO(p)); + relocate_pure(&CODEPINFOS(p)); { ptr t = CODERELOC(p); { @@ -786,7 +804,7 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) a = a + code_off; { ptr obj = S_get_code_obj(RELOC_TYPE(entry), oldco, a, item_off); - relocate_pure(&obj, p, SIZE); + relocate_pure(&obj); S_set_code_obj("gc", RELOC_TYPE(entry), p, a, obj, item_off); } } @@ -824,7 +842,7 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) } else { - RECORD_REMOTE_RANGE(tgc, p, SIZE, t_si); + RECORD_REMOTE(t_si); } } } @@ -857,10 +875,10 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) } } STACKCACHE(tc) = Snil; - relocate_pure(&(CCHAIN(tc)), p, SIZE); - relocate_pure(&(STACKLINK(tc)), p, SIZE); - relocate_pure(&(WINDERS(tc)), p, SIZE); - relocate_pure(&(ATTACHMENTS(tc)), p, SIZE); + relocate_pure(&(CCHAIN(tc))); + relocate_pure(&(STACKLINK(tc))); + relocate_pure(&(WINDERS(tc))); + relocate_pure(&(ATTACHMENTS(tc))); CACHEDFRAME(tc) = Sfalse; { ptr xcp = FRAME(tc, 0); @@ -872,7 +890,7 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) seginfo* x_si = SegInfo((ptr_get_segment(c_p))); if (x_si -> old_space) { - relocate_code(c_p, x_si, p, SIZE); + relocate_code(c_p, x_si); FRAME(tc, 0) = (ptr)(((uptr)c_p) + co); } { @@ -902,7 +920,7 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) seginfo* x_si = SegInfo((ptr_get_segment(c_p))); if (x_si -> old_space) { - relocate_code(c_p, x_si, p, SIZE); + relocate_code(c_p, x_si); *(pp) = (ptr)(((uptr)c_p) + co); } { @@ -916,7 +934,7 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) pp += 1; if (mask & 1) { - relocate_pure(&(*(pp)), p, SIZE); + relocate_pure(&(*(pp))); } mask >>= 1; } @@ -930,12 +948,12 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) } else if (SEGMENT_IS_LOCAL(n_si, num)) { - relocate_pure(&(*((ENTRYNONCOMPACTLIVEMASKADDR(oldret)))), p, SIZE); + relocate_pure(&(*((ENTRYNONCOMPACTLIVEMASKADDR(oldret))))); num = ENTRYLIVEMASK(oldret); } else { - RECORD_REMOTE_RANGE(tgc, p, SIZE, n_si); + RECORD_REMOTE(n_si); num = S_G.zero_length_bignum; } { @@ -952,7 +970,7 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) pp += 1; if (mask & 1) { - relocate_pure(&(*(pp)), p, SIZE); + relocate_pure(&(*(pp))); } mask >>= 1; } @@ -972,33 +990,29 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) W(tc) = 0; X(tc) = 0; Y(tc) = 0; - relocate_pure(&(THREADNO(tc)), p, SIZE); - relocate_pure(&(CURRENTINPUT(tc)), p, SIZE); - relocate_pure(&(CURRENTOUTPUT(tc)), p, SIZE); - relocate_pure(&(CURRENTERROR(tc)), p, SIZE); - relocate_pure(&(SFD(tc)), p, SIZE); - relocate_pure(&(CURRENTMSO(tc)), p, SIZE); - relocate_pure(&(TARGETMACHINE(tc)), p, SIZE); - relocate_pure(&(FXLENGTHBV(tc)), p, SIZE); - relocate_pure(&(FXFIRSTBITSETBV(tc)), p, SIZE); - relocate_pure(&(NULLIMMUTABLEVECTOR(tc)), p, SIZE); - relocate_pure(&(NULLIMMUTABLEFXVECTOR(tc)), p, SIZE); - relocate_pure(&(NULLIMMUTABLEBYTEVECTOR(tc)), p, SIZE); - relocate_pure(&(NULLIMMUTABLESTRING(tc)), p, SIZE); - relocate_pure(&(COMPILEPROFILE(tc)), p, SIZE); - relocate_pure(&(SUBSETMODE(tc)), p, SIZE); - relocate_pure(&(DEFAULTRECORDEQUALPROCEDURE(tc)), p, SIZE); - relocate_pure(&(DEFAULTRECORDHASHPROCEDURE(tc)), p, SIZE); - relocate_pure(&(COMPRESSFORMAT(tc)), p, SIZE); - relocate_pure(&(COMPRESSLEVEL(tc)), p, SIZE); - relocate_pure(&(PARAMETERS(tc)), p, SIZE); + relocate_pure(&(THREADNO(tc))); + relocate_pure(&(CURRENTINPUT(tc))); + relocate_pure(&(CURRENTOUTPUT(tc))); + relocate_pure(&(CURRENTERROR(tc))); + relocate_pure(&(SFD(tc))); + relocate_pure(&(CURRENTMSO(tc))); + relocate_pure(&(TARGETMACHINE(tc))); + relocate_pure(&(FXLENGTHBV(tc))); + relocate_pure(&(FXFIRSTBITSETBV(tc))); + relocate_pure(&(COMPILEPROFILE(tc))); + relocate_pure(&(SUBSETMODE(tc))); + relocate_pure(&(DEFAULTRECORDEQUALPROCEDURE(tc))); + relocate_pure(&(DEFAULTRECORDHASHPROCEDURE(tc))); + relocate_pure(&(COMPRESSFORMAT(tc))); + relocate_pure(&(COMPRESSLEVEL(tc))); + relocate_pure(&(PARAMETERS(tc))); DSTBV(tc) = Sfalse; SRCBV(tc) = Sfalse; { INT i = 0; while (i < virtual_register_count) { - relocate_pure(&(VIRTREG(tc, i)), p, SIZE); + relocate_pure(&(VIRTREG(tc, i))); i += 1; } } @@ -1033,24 +1047,24 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) } else if (p_at_spc == space_weakpair) { - relocate_impure(&INITCDR(p), from_g, p, SIZE); + relocate_impure(&INITCDR(p), from_g); } else { - relocate_impure(&INITCAR(p), from_g, p, SIZE); - relocate_impure(&INITCDR(p), from_g, p, SIZE); + relocate_impure(&INITCAR(p), from_g); + relocate_impure(&INITCDR(p), from_g); } } } else if (t == type_closure) { ptr code = CLOSCODE(p); - relocate_pure(&code, p, SIZE); + relocate_pure(&code); if ((CODETYPE(code)) & (code_flag_continuation << code_flags_offset)) { SETCLOSCODE(p, code); - relocate_pure(&CONTWINDERS(p), p, SIZE); - relocate_impure(&CONTATTACHMENTS(p), from_g, p, SIZE); + relocate_pure(&CONTWINDERS(p)); + relocate_impure(&CONTATTACHMENTS(p), from_g); if ((CONTLENGTH(p)) == scaled_shot_1_shot_flag) { } @@ -1063,14 +1077,14 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) { if (!(SEGMENT_IS_LOCAL(s_si, stk))) { - RECORD_REMOTE_RANGE(tgc, p, SIZE, s_si); + RECORD_REMOTE(s_si); } else { CONTSTACK(p) = copy_stack(tgc, CONTSTACK(p), &(CONTLENGTH(p)), CONTCLENGTH(p)); } } - relocate_pure(&CONTLINK(p), p, SIZE); + relocate_pure(&CONTLINK(p)); { ptr xcp = CONTRET(p); { @@ -1081,7 +1095,7 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) seginfo* x_si = SegInfo((ptr_get_segment(c_p))); if (x_si -> old_space) { - relocate_code(c_p, x_si, p, SIZE); + relocate_code(c_p, x_si); CONTRET(p) = (ptr)(((uptr)c_p) + co); } { @@ -1113,7 +1127,7 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) seginfo* x_si = SegInfo((ptr_get_segment(c_p))); if (x_si -> old_space) { - relocate_code(c_p, x_si, p, SIZE); + relocate_code(c_p, x_si); *(pp) = (ptr)(((uptr)c_p) + co); } { @@ -1127,7 +1141,7 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) pp += 1; if (mask & 1) { - relocate_pure(&(*(pp)), p, SIZE); + relocate_pure(&(*(pp))); } mask >>= 1; } @@ -1141,12 +1155,12 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) } else if (SEGMENT_IS_LOCAL(n_si, num)) { - relocate_pure(&(*((ENTRYNONCOMPACTLIVEMASKADDR(oldret)))), p, SIZE); + relocate_pure(&(*((ENTRYNONCOMPACTLIVEMASKADDR(oldret))))); num = ENTRYLIVEMASK(oldret); } else { - RECORD_REMOTE_RANGE(tgc, p, SIZE, n_si); + RECORD_REMOTE(n_si); num = S_G.zero_length_bignum; } { @@ -1163,7 +1177,7 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) pp += 1; if (mask & 1) { - relocate_pure(&(*(pp)), p, SIZE); + relocate_pure(&(*(pp))); } mask >>= 1; } @@ -1200,7 +1214,7 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) ptr *p_p = &CLOSIT(p, 0); for (idx = 0; idx < p_len; idx++) { - relocate_impure(&(p_p[idx]), from_g, p, SIZE); + relocate_impure(&(p_p[idx]), from_g); } } } @@ -1212,7 +1226,7 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) ptr *p_p = &CLOSIT(p, 0); for (idx = 0; idx < p_len; idx++) { - relocate_pure(&(p_p[idx]), p, SIZE); + relocate_pure(&(p_p[idx])); } } } @@ -1220,19 +1234,19 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) } else if (t == type_symbol) { - relocate_impure(&INITSYMVAL(p), from_g, p, SIZE); + relocate_impure(&INITSYMVAL(p), from_g); { ptr val = INITSYMVAL(p); { ptr code = ((Sprocedurep(val)) ? (CLOSCODE(val)) : (SYMCODE(p))); - relocate_pure(&code, p, SIZE); + relocate_pure(&code); INITSYMCODE(p, code); - relocate_impure(&INITSYMPLIST(p), from_g, p, SIZE); - relocate_impure(&INITSYMNAME(p), from_g, p, SIZE); - relocate_impure(&INITSYMSPLIST(p), from_g, p, SIZE); - relocate_impure(&INITSYMHASH(p), from_g, p, SIZE); + relocate_impure(&INITSYMPLIST(p), from_g); + relocate_impure(&INITSYMNAME(p), from_g); + relocate_impure(&INITSYMSPLIST(p), from_g); + relocate_impure(&INITSYMHASH(p), from_g); } } } @@ -1245,204 +1259,211 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) } } POP_BACKREFERENCE() + FLUSH_REMOTE(tgc, p); } static void sweep_object_in_old(thread_gc *tgc, ptr p) { - ITYPE t = TYPEBITS(p); - if (t == type_typed_object) + FLUSH_REMOTE_BLOCK { - ptr tf = TYPEFIELD(p); - if (TYPEP(tf, mask_record, type_record)) + ITYPE t = TYPEBITS(p); + if (t == type_typed_object) { - relocate_pure(&RECORDINSTTYPE(p), p, size_record_inst((UNFIX((RECORDDESCSIZE(RECORDINSTTYPE(p))))))); + ptr tf = TYPEFIELD(p); + if (TYPEP(tf, mask_record, type_record)) { - ptr rtd = RECORDINSTTYPE(p); + relocate_pure(&RECORDINSTTYPE(p)); { - uptr len = UNFIX((RECORDDESCSIZE(rtd))); + ptr rtd = RECORDINSTTYPE(p); { - ptr num = RECORDDESCPM(rtd); - ptr* pp = &(RECORDINSTIT(p, 0)); - if (Sfixnump(num)) + uptr len = UNFIX((RECORDDESCSIZE(rtd))); { + ptr num = RECORDDESCPM(rtd); + ptr* pp = &(RECORDINSTIT(p, 0)); + if (Sfixnump(num)) { - uptr mask = ((uptr)(UNFIX(num))) >> 1; - if (mask == (((uptr)-1) >> 1)) { + uptr mask = ((uptr)(UNFIX(num))) >> 1; + if (mask == (((uptr)-1) >> 1)) { - ptr* ppend = ((ptr*)(TO_VOIDP((((uptr)(TO_PTR(pp))) + len)))) - 1; - while (pp < ppend) { - relocate_indirect((*(pp)), p, SIZE); - pp += 1; + ptr* ppend = ((ptr*)(TO_VOIDP((((uptr)(TO_PTR(pp))) + len)))) - 1; + while (pp < ppend) + { + relocate_indirect((*(pp))); + pp += 1; + } } } - } - else - { - while (mask != 0) + else { - if (mask & 1) + while (mask != 0) { - relocate_indirect((*(pp)), p, SIZE); + if (mask & 1) + { + relocate_indirect((*(pp))); + } + mask >>= 1; + pp += 1; } - mask >>= 1; - pp += 1; } } } - } - else - { - relocate_pure(&(RECORDDESCPM(rtd)), p, SIZE); - num = RECORDDESCPM(rtd); + else { - iptr index = (BIGLEN(num)) - 1; - bigit mask = (BIGIT(num, index)) >> 1; - INT bits = bigit_bits - 1; - while (1) + relocate_pure(&(RECORDDESCPM(rtd))); + num = RECORDDESCPM(rtd); { - do + iptr index = (BIGLEN(num)) - 1; + bigit mask = (BIGIT(num, index)) >> 1; + INT bits = bigit_bits - 1; + while (1) { - if (mask & 1) + do + { + if (mask & 1) + { + relocate_indirect((*(pp))); + } + mask >>= 1; + pp += 1; + bits -= 1; + } + while (bits > 0); + if (index == 0) { - relocate_indirect((*(pp)), p, SIZE); + break; } - mask >>= 1; - pp += 1; - bits -= 1; - } - while (bits > 0); - if (index == 0) - { - break; + index -= 1; + mask = BIGIT(num, index); + bits = bigit_bits; } - index -= 1; - mask = BIGIT(num, index); - bits = bigit_bits; } } } } } } - } - else if (TYPEP(tf, mask_vector, type_vector)) - { - uptr len = Svector_length(p); + else if (TYPEP(tf, mask_vector, type_vector)) { - uptr idx, p_len = len; - ptr *p_p = &INITVECTIT(p, 0); - for (idx = 0; idx < p_len; idx++) + uptr len = Svector_length(p); { - relocate_indirect((p_p[idx]), p, SIZE); + uptr idx, p_len = len; + ptr *p_p = &INITVECTIT(p, 0); + for (idx = 0; idx < p_len; idx++) + { + relocate_indirect((p_p[idx])); + } } } - } - else if (TYPEP(tf, mask_stencil_vector, type_stencil_vector)) - { - uptr len = Sstencil_vector_length(p); + else if (TYPEP(tf, mask_stencil_vector, type_stencil_vector)) { - uptr idx, p_len = len; - ptr *p_p = &INITSTENVECTIT(p, 0); - for (idx = 0; idx < p_len; idx++) + uptr len = Sstencil_vector_length(p); { - relocate_indirect((p_p[idx]), p, SIZE); + uptr idx, p_len = len; + ptr *p_p = &INITSTENVECTIT(p, 0); + for (idx = 0; idx < p_len; idx++) + { + relocate_indirect((p_p[idx])); + } } } - } - else if (TYPEP(tf, mask_string, type_string)) - { - } - else if (TYPEP(tf, mask_fxvector, type_fxvector)) - { - } - else if (TYPEP(tf, mask_bytevector, type_bytevector)) - { - } - else if ((iptr)tf == type_tlc) - { - relocate_indirect(INITTLCHT(p), p, SIZE); - relocate_indirect(INITTLCKEYVAL(p), p, SIZE); - relocate_indirect(INITTLCNEXT(p), p, SIZE); - } - else if (TYPEP(tf, mask_box, type_box)) - { - relocate_indirect(INITBOXREF(p), p, SIZE); - } - else if ((iptr)tf == type_ratnum) - { - relocate_pure(&RATNUM(p), p, SIZE); - relocate_pure(&RATDEN(p), p, SIZE); - } - else if ((iptr)tf == type_exactnum) - { - relocate_pure(&EXACTNUM_REAL_PART(p), p, SIZE); - relocate_pure(&EXACTNUM_IMAG_PART(p), p, SIZE); - } - else if ((iptr)tf == type_inexactnum) - { - } - else if (TYPEP(tf, mask_bignum, type_bignum)) - { - } - else if (TYPEP(tf, mask_port, type_port)) - { - relocate_indirect(PORTHANDLER(p), p, SIZE); - if (((uptr)tf) & PORT_FLAG_OUTPUT) + else if (TYPEP(tf, mask_string, type_string)) { - relocate_indirect(PORTOBUF(p), p, SIZE); } - if (((uptr)tf) & PORT_FLAG_INPUT) + else if (TYPEP(tf, mask_fxvector, type_fxvector)) { - relocate_indirect(PORTIBUF(p), p, SIZE); } - relocate_indirect(PORTINFO(p), p, SIZE); - relocate_indirect(PORTNAME(p), p, SIZE); - } - else if (TYPEP(tf, mask_code, type_code)) - { - relocate_pure(&CODENAME(p), p, SIZE); - relocate_pure(&CODEARITYMASK(p), p, SIZE); - relocate_pure(&CODEINFO(p), p, SIZE); - relocate_pure(&CODEPINFOS(p), p, SIZE); + else if (TYPEP(tf, mask_flvector, type_flvector)) + { + } + else if (TYPEP(tf, mask_bytevector, type_bytevector)) + { + } + else if ((iptr)tf == type_tlc) + { + relocate_indirect(INITTLCHT(p)); + relocate_indirect(INITTLCKEYVAL(p)); + relocate_indirect(INITTLCNEXT(p)); + } + else if (TYPEP(tf, mask_box, type_box)) + { + relocate_indirect(INITBOXREF(p)); + } + else if ((iptr)tf == type_ratnum) + { + relocate_pure(&RATNUM(p)); + relocate_pure(&RATDEN(p)); + } + else if ((iptr)tf == type_exactnum) + { + relocate_pure(&EXACTNUM_REAL_PART(p)); + relocate_pure(&EXACTNUM_IMAG_PART(p)); + } + else if ((iptr)tf == type_inexactnum) + { + } + else if (TYPEP(tf, mask_bignum, type_bignum)) + { + } + else if (TYPEP(tf, mask_port, type_port)) + { + relocate_indirect(PORTHANDLER(p)); + if (((uptr)tf) & PORT_FLAG_OUTPUT) + { + relocate_indirect(PORTOBUF(p)); + } + if (((uptr)tf) & PORT_FLAG_INPUT) + { + relocate_indirect(PORTIBUF(p)); + } + relocate_indirect(PORTINFO(p)); + relocate_indirect(PORTNAME(p)); + } + else if (TYPEP(tf, mask_code, type_code)) { - ptr t = CODERELOC(p); + relocate_pure(&CODENAME(p)); + relocate_pure(&CODEARITYMASK(p)); + relocate_pure(&CODEINFO(p)); + relocate_pure(&CODEPINFOS(p)); { - iptr m = (t - ? (RELOCSIZE(t)) - : 0); + ptr t = CODERELOC(p); { - ptr oldco = (t - ? (RELOCCODE(t)) - : 0); + iptr m = (t + ? (RELOCSIZE(t)) + : 0); { - iptr a = 0; + ptr oldco = (t + ? (RELOCCODE(t)) + : 0); { - iptr n = 0; - while (n < m) + iptr a = 0; { + iptr n = 0; + while (n < m) { - uptr entry = RELOCIT(t, n); - uptr item_off = 0; - uptr code_off = 0; - n = n + 1; - if (RELOC_EXTENDED_FORMAT(entry)) { - item_off = RELOCIT(t, n); - n = n + 1; - code_off = RELOCIT(t, n); + uptr entry = RELOCIT(t, n); + uptr item_off = 0; + uptr code_off = 0; n = n + 1; - } - else - { - item_off = RELOC_ITEM_OFFSET(entry); - code_off = RELOC_CODE_OFFSET(entry); - } - a = a + code_off; - { - ptr obj = S_get_code_obj(RELOC_TYPE(entry), oldco, a, item_off); - relocate_pure(&obj, p, SIZE); + if (RELOC_EXTENDED_FORMAT(entry)) + { + item_off = RELOCIT(t, n); + n = n + 1; + code_off = RELOCIT(t, n); + n = n + 1; + } + else + { + item_off = RELOC_ITEM_OFFSET(entry); + code_off = RELOC_CODE_OFFSET(entry); + } + a = a + code_off; + { + ptr obj = S_get_code_obj(RELOC_TYPE(entry), oldco, a, item_off); + relocate_pure(&obj); + } } } } @@ -1451,109 +1472,109 @@ static void sweep_object_in_old(thread_gc *tgc, ptr p) } } } - } - else if ((iptr)tf == type_thread) - { + else if ((iptr)tf == type_thread) { - ptr tc = (ptr)(THREADTC(p)); - if (tc != ((ptr)0)) { - STACKCACHE(tc) = Snil; - relocate_pure(&(CCHAIN(tc)), p, SIZE); - relocate_pure(&(STACKLINK(tc)), p, SIZE); - relocate_pure(&(WINDERS(tc)), p, SIZE); - relocate_pure(&(ATTACHMENTS(tc)), p, SIZE); + ptr tc = (ptr)(THREADTC(p)); + if (tc != ((ptr)0)) { - ptr xcp = FRAME(tc, 0); + STACKCACHE(tc) = Snil; + relocate_pure(&(CCHAIN(tc))); + relocate_pure(&(STACKLINK(tc))); + relocate_pure(&(WINDERS(tc))); + relocate_pure(&(ATTACHMENTS(tc))); { - iptr co = (ENTRYOFFSET(xcp)) + (((uptr)xcp) - ((uptr)(TO_PTR((ENTRYOFFSETADDR(xcp)))))); + ptr xcp = FRAME(tc, 0); { - ptr c_p = (ptr)(((uptr)xcp) - co); + iptr co = (ENTRYOFFSET(xcp)) + (((uptr)xcp) - ((uptr)(TO_PTR((ENTRYOFFSETADDR(xcp)))))); { - seginfo* x_si = SegInfo((ptr_get_segment(c_p))); - if (x_si -> old_space) - { - relocate_code(c_p, x_si, p, SIZE); - } + ptr c_p = (ptr)(((uptr)xcp) - co); { - uptr base = (uptr)(SCHEMESTACK(tc)); + seginfo* x_si = SegInfo((ptr_get_segment(c_p))); + if (x_si -> old_space) { - uptr fp = (uptr)(SFP(tc)); + relocate_code(c_p, x_si); + } + { + uptr base = (uptr)(SCHEMESTACK(tc)); { - uptr ret = (uptr)(FRAME(tc, 0)); - while (fp != base) + uptr fp = (uptr)(SFP(tc)); { - if (fp < base) - { - S_error_abort("sweep_stack(gc): malformed stack"); - } - fp = fp - (ENTRYFRAMESIZE(ret)); + uptr ret = (uptr)(FRAME(tc, 0)); + while (fp != base) { - ptr* pp = (ptr*)(TO_VOIDP(fp)); - iptr oldret = ret; - ret = (iptr)(*(pp)); + if (fp < base) + { + S_error_abort("sweep_stack(gc): malformed stack"); + } + fp = fp - (ENTRYFRAMESIZE(ret)); { - ptr xcp = *(pp); + ptr* pp = (ptr*)(TO_VOIDP(fp)); + iptr oldret = ret; + ret = (iptr)(*(pp)); { - iptr co = (ENTRYOFFSET(xcp)) + (((uptr)xcp) - ((uptr)(TO_PTR((ENTRYOFFSETADDR(xcp)))))); + ptr xcp = *(pp); { - ptr c_p = (ptr)(((uptr)xcp) - co); + iptr co = (ENTRYOFFSET(xcp)) + (((uptr)xcp) - ((uptr)(TO_PTR((ENTRYOFFSETADDR(xcp)))))); { - seginfo* x_si = SegInfo((ptr_get_segment(c_p))); - if (x_si -> old_space) - { - relocate_code(c_p, x_si, p, SIZE); - } + ptr c_p = (ptr)(((uptr)xcp) - co); { - ptr num = ENTRYLIVEMASK(oldret); - if (Sfixnump(num)) + seginfo* x_si = SegInfo((ptr_get_segment(c_p))); + if (x_si -> old_space) + { + relocate_code(c_p, x_si); + } { + ptr num = ENTRYLIVEMASK(oldret); + if (Sfixnump(num)) { - uptr mask = UNFIX(num); - while (mask != 0) { - pp += 1; - if (mask & 1) + uptr mask = UNFIX(num); + while (mask != 0) { - relocate_pure(&(*(pp)), p, SIZE); + pp += 1; + if (mask & 1) + { + relocate_pure(&(*(pp))); + } + mask >>= 1; } - mask >>= 1; } } - } - else - { - seginfo* n_si = SegInfo((ptr_get_segment(num))); - if (!(n_si -> old_space)) - { - } - else if (SEGMENT_IS_LOCAL(n_si, num)) - { - relocate_pure(&(*((ENTRYNONCOMPACTLIVEMASKADDR(oldret)))), p, SIZE); - num = ENTRYLIVEMASK(oldret); - } else { - RECORD_REMOTE_RANGE(tgc, p, SIZE, n_si); - num = S_G.zero_length_bignum; - } - { - iptr index = BIGLEN(num); - while (index != 0) + seginfo* n_si = SegInfo((ptr_get_segment(num))); + if (!(n_si -> old_space)) { - index -= 1; + } + else if (SEGMENT_IS_LOCAL(n_si, num)) + { + relocate_pure(&(*((ENTRYNONCOMPACTLIVEMASKADDR(oldret))))); + num = ENTRYLIVEMASK(oldret); + } + else + { + RECORD_REMOTE(n_si); + num = S_G.zero_length_bignum; + } + { + iptr index = BIGLEN(num); + while (index != 0) { - INT bits = bigit_bits; - bigit mask = BIGIT(num, index); - while (bits > 0) + index -= 1; { - bits -= 1; - pp += 1; - if (mask & 1) + INT bits = bigit_bits; + bigit mask = BIGIT(num, index); + while (bits > 0) { - relocate_pure(&(*(pp)), p, SIZE); + bits -= 1; + pp += 1; + if (mask & 1) + { + relocate_pure(&(*(pp))); + } + mask >>= 1; } - mask >>= 1; } } } @@ -1565,33 +1586,29 @@ static void sweep_object_in_old(thread_gc *tgc, ptr p) } } } - } - relocate_pure(&(THREADNO(tc)), p, SIZE); - relocate_pure(&(CURRENTINPUT(tc)), p, SIZE); - relocate_pure(&(CURRENTOUTPUT(tc)), p, SIZE); - relocate_pure(&(CURRENTERROR(tc)), p, SIZE); - relocate_pure(&(SFD(tc)), p, SIZE); - relocate_pure(&(CURRENTMSO(tc)), p, SIZE); - relocate_pure(&(TARGETMACHINE(tc)), p, SIZE); - relocate_pure(&(FXLENGTHBV(tc)), p, SIZE); - relocate_pure(&(FXFIRSTBITSETBV(tc)), p, SIZE); - relocate_pure(&(NULLIMMUTABLEVECTOR(tc)), p, SIZE); - relocate_pure(&(NULLIMMUTABLEFXVECTOR(tc)), p, SIZE); - relocate_pure(&(NULLIMMUTABLEBYTEVECTOR(tc)), p, SIZE); - relocate_pure(&(NULLIMMUTABLESTRING(tc)), p, SIZE); - relocate_pure(&(COMPILEPROFILE(tc)), p, SIZE); - relocate_pure(&(SUBSETMODE(tc)), p, SIZE); - relocate_pure(&(DEFAULTRECORDEQUALPROCEDURE(tc)), p, SIZE); - relocate_pure(&(DEFAULTRECORDHASHPROCEDURE(tc)), p, SIZE); - relocate_pure(&(COMPRESSFORMAT(tc)), p, SIZE); - relocate_pure(&(COMPRESSLEVEL(tc)), p, SIZE); - relocate_pure(&(PARAMETERS(tc)), p, SIZE); - { - INT i = 0; - while (i < virtual_register_count) + relocate_pure(&(THREADNO(tc))); + relocate_pure(&(CURRENTINPUT(tc))); + relocate_pure(&(CURRENTOUTPUT(tc))); + relocate_pure(&(CURRENTERROR(tc))); + relocate_pure(&(SFD(tc))); + relocate_pure(&(CURRENTMSO(tc))); + relocate_pure(&(TARGETMACHINE(tc))); + relocate_pure(&(FXLENGTHBV(tc))); + relocate_pure(&(FXFIRSTBITSETBV(tc))); + relocate_pure(&(COMPILEPROFILE(tc))); + relocate_pure(&(SUBSETMODE(tc))); + relocate_pure(&(DEFAULTRECORDEQUALPROCEDURE(tc))); + relocate_pure(&(DEFAULTRECORDHASHPROCEDURE(tc))); + relocate_pure(&(COMPRESSFORMAT(tc))); + relocate_pure(&(COMPRESSLEVEL(tc))); + relocate_pure(&(PARAMETERS(tc))); { - relocate_pure(&(VIRTREG(tc, i)), p, SIZE); - i += 1; + INT i = 0; + while (i < virtual_register_count) + { + relocate_pure(&(VIRTREG(tc, i))); + i += 1; + } } } } @@ -1603,144 +1620,144 @@ static void sweep_object_in_old(thread_gc *tgc, ptr p) } } } - } - else if ((iptr)tf == type_rtd_counts) - { - } - else if ((iptr)tf == type_phantom) - { - } - else - { - S_error_abort("sweep-in-old: illegal typed object type"); - } - } - else if (t == type_pair) - { - { - ISPC p_at_spc = SPACE(p); - if (p_at_spc == space_ephemeron) + else if ((iptr)tf == type_rtd_counts) { } - else if (p_at_spc == space_weakpair) + else if ((iptr)tf == type_phantom) { - relocate_indirect(INITCDR(p), p, SIZE); } else { - relocate_indirect(INITCAR(p), p, SIZE); - relocate_indirect(INITCDR(p), p, SIZE); + S_error_abort("sweep-in-old: illegal typed object type"); } } - } - else if (t == type_closure) - { - ptr code = CLOSCODE(p); - relocate_pure(&code, p, SIZE); - if ((CODETYPE(code)) & (code_flag_continuation << code_flags_offset)) + else if (t == type_pair) { - SETCLOSCODE(p, code); - relocate_pure(&CONTWINDERS(p), p, SIZE); - relocate_indirect(CONTATTACHMENTS(p), p, SIZE); - if ((CONTLENGTH(p)) == scaled_shot_1_shot_flag) { + ISPC p_at_spc = SPACE(p); + if (p_at_spc == space_ephemeron) + { + } + else if (p_at_spc == space_weakpair) + { + relocate_indirect(INITCDR(p)); + } + else + { + relocate_indirect(INITCAR(p)); + relocate_indirect(INITCDR(p)); + } } - else + } + else if (t == type_closure) + { + ptr code = CLOSCODE(p); + relocate_pure(&code); + if ((CODETYPE(code)) & (code_flag_continuation << code_flags_offset)) { - relocate_pure(&CONTLINK(p), p, SIZE); + SETCLOSCODE(p, code); + relocate_pure(&CONTWINDERS(p)); + relocate_indirect(CONTATTACHMENTS(p)); + if ((CONTLENGTH(p)) == scaled_shot_1_shot_flag) { - ptr xcp = CONTRET(p); + } + else + { + relocate_pure(&CONTLINK(p)); { - iptr co = (ENTRYOFFSET(xcp)) + (((uptr)xcp) - ((uptr)(TO_PTR((ENTRYOFFSETADDR(xcp)))))); + ptr xcp = CONTRET(p); { - ptr c_p = (ptr)(((uptr)xcp) - co); + iptr co = (ENTRYOFFSET(xcp)) + (((uptr)xcp) - ((uptr)(TO_PTR((ENTRYOFFSETADDR(xcp)))))); { - seginfo* x_si = SegInfo((ptr_get_segment(c_p))); - if (x_si -> old_space) - { - relocate_code(c_p, x_si, p, SIZE); - } + ptr c_p = (ptr)(((uptr)xcp) - co); { - uptr stack = (uptr)(CONTSTACK(p)); + seginfo* x_si = SegInfo((ptr_get_segment(c_p))); + if (x_si -> old_space) + { + relocate_code(c_p, x_si); + } { - uptr base = stack; + uptr stack = (uptr)(CONTSTACK(p)); { - uptr fp = stack + (CONTCLENGTH(p)); + uptr base = stack; { - uptr ret = (uptr)(CONTRET(p)); - while (fp != base) + uptr fp = stack + (CONTCLENGTH(p)); { - if (fp < base) - { - S_error_abort("sweep_stack(gc): malformed stack"); - } - fp = fp - (ENTRYFRAMESIZE(ret)); + uptr ret = (uptr)(CONTRET(p)); + while (fp != base) { - ptr* pp = (ptr*)(TO_VOIDP(fp)); - iptr oldret = ret; - ret = (iptr)(*(pp)); + if (fp < base) { - ptr xcp = *(pp); + S_error_abort("sweep_stack(gc): malformed stack"); + } + fp = fp - (ENTRYFRAMESIZE(ret)); + { + ptr* pp = (ptr*)(TO_VOIDP(fp)); + iptr oldret = ret; + ret = (iptr)(*(pp)); { - iptr co = (ENTRYOFFSET(xcp)) + (((uptr)xcp) - ((uptr)(TO_PTR((ENTRYOFFSETADDR(xcp)))))); + ptr xcp = *(pp); { - ptr c_p = (ptr)(((uptr)xcp) - co); + iptr co = (ENTRYOFFSET(xcp)) + (((uptr)xcp) - ((uptr)(TO_PTR((ENTRYOFFSETADDR(xcp)))))); { - seginfo* x_si = SegInfo((ptr_get_segment(c_p))); - if (x_si -> old_space) - { - relocate_code(c_p, x_si, p, SIZE); - } + ptr c_p = (ptr)(((uptr)xcp) - co); { - ptr num = ENTRYLIVEMASK(oldret); - if (Sfixnump(num)) + seginfo* x_si = SegInfo((ptr_get_segment(c_p))); + if (x_si -> old_space) + { + relocate_code(c_p, x_si); + } { + ptr num = ENTRYLIVEMASK(oldret); + if (Sfixnump(num)) { - uptr mask = UNFIX(num); - while (mask != 0) { - pp += 1; - if (mask & 1) + uptr mask = UNFIX(num); + while (mask != 0) { - relocate_pure(&(*(pp)), p, SIZE); + pp += 1; + if (mask & 1) + { + relocate_pure(&(*(pp))); + } + mask >>= 1; } - mask >>= 1; } } - } - else - { - seginfo* n_si = SegInfo((ptr_get_segment(num))); - if (!(n_si -> old_space)) - { - } - else if (SEGMENT_IS_LOCAL(n_si, num)) - { - relocate_pure(&(*((ENTRYNONCOMPACTLIVEMASKADDR(oldret)))), p, SIZE); - num = ENTRYLIVEMASK(oldret); - } else { - RECORD_REMOTE_RANGE(tgc, p, SIZE, n_si); - num = S_G.zero_length_bignum; - } - { - iptr index = BIGLEN(num); - while (index != 0) + seginfo* n_si = SegInfo((ptr_get_segment(num))); + if (!(n_si -> old_space)) + { + } + else if (SEGMENT_IS_LOCAL(n_si, num)) { - index -= 1; + relocate_pure(&(*((ENTRYNONCOMPACTLIVEMASKADDR(oldret))))); + num = ENTRYLIVEMASK(oldret); + } + else + { + RECORD_REMOTE(n_si); + num = S_G.zero_length_bignum; + } + { + iptr index = BIGLEN(num); + while (index != 0) { - INT bits = bigit_bits; - bigit mask = BIGIT(num, index); - while (bits > 0) + index -= 1; { - bits -= 1; - pp += 1; - if (mask & 1) + INT bits = bigit_bits; + bigit mask = BIGIT(num, index); + while (bits > 0) { - relocate_pure(&(*(pp)), p, SIZE); + bits -= 1; + pp += 1; + if (mask & 1) + { + relocate_pure(&(*(pp))); + } + mask >>= 1; } - mask >>= 1; } } } @@ -1762,65 +1779,67 @@ static void sweep_object_in_old(thread_gc *tgc, ptr p) } } } - } - else - { - uptr len = CODEFREE(code); - if ((CODETYPE(code)) & (code_flag_mutable_closure << code_flags_offset)) + else { - SETCLOSCODE(p, code); + uptr len = CODEFREE(code); + if ((CODETYPE(code)) & (code_flag_mutable_closure << code_flags_offset)) { - uptr idx, p_len = len; - ptr *p_p = &CLOSIT(p, 0); - for (idx = 0; idx < p_len; idx++) + SETCLOSCODE(p, code); { - relocate_indirect((p_p[idx]), p, SIZE); + uptr idx, p_len = len; + ptr *p_p = &CLOSIT(p, 0); + for (idx = 0; idx < p_len; idx++) + { + relocate_indirect((p_p[idx])); + } } } - } - else - { - SETCLOSCODE(p, code); + else { - uptr idx, p_len = len; - ptr *p_p = &CLOSIT(p, 0); - for (idx = 0; idx < p_len; idx++) + SETCLOSCODE(p, code); { - relocate_pure(&(p_p[idx]), p, SIZE); + uptr idx, p_len = len; + ptr *p_p = &CLOSIT(p, 0); + for (idx = 0; idx < p_len; idx++) + { + relocate_pure(&(p_p[idx])); + } } } } } - } - else if (t == type_symbol) - { - relocate_indirect(INITSYMVAL(p), p, SIZE); + else if (t == type_symbol) { - ptr val = INITSYMVAL(p); - { - ptr code = ((Sprocedurep(val)) - ? (CLOSCODE(val)) - : (SYMCODE(p))); - relocate_pure(&code, p, SIZE); - INITSYMCODE(p, code); - relocate_indirect(INITSYMPLIST(p), p, SIZE); - relocate_indirect(INITSYMNAME(p), p, SIZE); - relocate_indirect(INITSYMSPLIST(p), p, SIZE); - relocate_indirect(INITSYMHASH(p), p, SIZE); + relocate_indirect(INITSYMVAL(p)); + { + ptr val = INITSYMVAL(p); + { + ptr code = ((Sprocedurep(val)) + ? (CLOSCODE(val)) + : (SYMCODE(p))); + relocate_pure(&code); + INITSYMCODE(p, code); + relocate_indirect(INITSYMPLIST(p)); + relocate_indirect(INITSYMNAME(p)); + relocate_indirect(INITSYMSPLIST(p)); + relocate_indirect(INITSYMHASH(p)); + } } } + else if (t == type_flonum) + { + } + else + { + S_error_abort("sweep-in-old: illegal type"); + } } - else if (t == type_flonum) - { - } - else - { - S_error_abort("sweep-in-old: illegal type"); - } + ASSERT_EMPTY_FLUSH_REMOTE(); } static IGEN sweep_dirty_object(thread_gc *tgc, ptr p, IGEN youngest) { + FLUSH_REMOTE_BLOCK PUSH_BACKREFERENCE(p) { ITYPE t = TYPEBITS(p); @@ -1842,7 +1861,7 @@ static IGEN sweep_dirty_object(thread_gc *tgc, ptr p, IGEN youngest) { if (mask & 1) { - relocate_dirty(&(*(pp)), youngest, p, SIZE); + relocate_dirty(&(*(pp)), youngest); } mask >>= 1; pp += 1; @@ -1861,7 +1880,7 @@ static IGEN sweep_dirty_object(thread_gc *tgc, ptr p, IGEN youngest) { if (mask & 1) { - relocate_dirty(&(*(pp)), youngest, p, SIZE); + relocate_dirty(&(*(pp)), youngest); } mask >>= 1; pp += 1; @@ -1889,7 +1908,7 @@ static IGEN sweep_dirty_object(thread_gc *tgc, ptr p, IGEN youngest) ptr *p_p = &INITVECTIT(p, 0); for (idx = 0; idx < p_len; idx++) { - relocate_dirty(&(p_p[idx]), youngest, p, SIZE); + relocate_dirty(&(p_p[idx]), youngest); } } } @@ -1901,7 +1920,7 @@ static IGEN sweep_dirty_object(thread_gc *tgc, ptr p, IGEN youngest) ptr *p_p = &INITSTENVECTIT(p, 0); for (idx = 0; idx < p_len; idx++) { - relocate_dirty(&(p_p[idx]), youngest, p, SIZE); + relocate_dirty(&(p_p[idx]), youngest); } } } @@ -1911,18 +1930,21 @@ static IGEN sweep_dirty_object(thread_gc *tgc, ptr p, IGEN youngest) else if (TYPEP(tf, mask_fxvector, type_fxvector)) { } + else if (TYPEP(tf, mask_flvector, type_flvector)) + { + } else if (TYPEP(tf, mask_bytevector, type_bytevector)) { } else if ((iptr)tf == type_tlc) { - relocate_dirty(&INITTLCHT(p), youngest, p, SIZE); - relocate_dirty(&INITTLCKEYVAL(p), youngest, p, SIZE); - relocate_dirty(&INITTLCNEXT(p), youngest, p, SIZE); + relocate_dirty(&INITTLCHT(p), youngest); + relocate_dirty(&INITTLCKEYVAL(p), youngest); + relocate_dirty(&INITTLCNEXT(p), youngest); } else if (TYPEP(tf, mask_box, type_box)) { - relocate_dirty(&INITBOXREF(p), youngest, p, SIZE); + relocate_dirty(&INITBOXREF(p), youngest); } else if ((iptr)tf == type_ratnum) { @@ -1938,21 +1960,21 @@ static IGEN sweep_dirty_object(thread_gc *tgc, ptr p, IGEN youngest) } else if (TYPEP(tf, mask_port, type_port)) { - relocate_dirty(&PORTHANDLER(p), youngest, p, SIZE); + relocate_dirty(&PORTHANDLER(p), youngest); if (((uptr)tf) & PORT_FLAG_OUTPUT) { iptr n = ((iptr)(PORTOLAST(p))) - ((iptr)(PORTOBUF(p))); - relocate_dirty(&PORTOBUF(p), youngest, p, SIZE); + relocate_dirty(&PORTOBUF(p), youngest); PORTOLAST(p) = (ptr)(((iptr)(PORTOBUF(p))) + n); } if (((uptr)tf) & PORT_FLAG_INPUT) { iptr n = ((iptr)(PORTILAST(p))) - ((iptr)(PORTIBUF(p))); - relocate_dirty(&PORTIBUF(p), youngest, p, SIZE); + relocate_dirty(&PORTIBUF(p), youngest); PORTILAST(p) = (ptr)(((iptr)(PORTIBUF(p))) + n); } - relocate_dirty(&PORTINFO(p), youngest, p, SIZE); - relocate_dirty(&PORTNAME(p), youngest, p, SIZE); + relocate_dirty(&PORTINFO(p), youngest); + relocate_dirty(&PORTNAME(p), youngest); } else if (TYPEP(tf, mask_code, type_code)) { @@ -1981,12 +2003,12 @@ static IGEN sweep_dirty_object(thread_gc *tgc, ptr p, IGEN youngest) } else if (p_at_spc == space_weakpair) { - relocate_dirty(&INITCDR(p), youngest, p, SIZE); + relocate_dirty(&INITCDR(p), youngest); } else { - relocate_dirty(&INITCAR(p), youngest, p, SIZE); - relocate_dirty(&INITCDR(p), youngest, p, SIZE); + relocate_dirty(&INITCAR(p), youngest); + relocate_dirty(&INITCDR(p), youngest); } } } @@ -2002,7 +2024,7 @@ static IGEN sweep_dirty_object(thread_gc *tgc, ptr p, IGEN youngest) ptr *p_p = &CLOSIT(p, 0); for (idx = 0; idx < p_len; idx++) { - relocate_dirty(&(p_p[idx]), youngest, p, SIZE); + relocate_dirty(&(p_p[idx]), youngest); } } } @@ -2010,19 +2032,19 @@ static IGEN sweep_dirty_object(thread_gc *tgc, ptr p, IGEN youngest) } else if (t == type_symbol) { - relocate_dirty(&INITSYMVAL(p), youngest, p, SIZE); + relocate_dirty(&INITSYMVAL(p), youngest); { ptr val = INITSYMVAL(p); { ptr code = ((Sprocedurep(val)) ? (CLOSCODE(val)) : (SYMCODE(p))); - relocate_dirty(&code, youngest, p, SIZE); + relocate_dirty(&code, youngest); INITSYMCODE(p, code); - relocate_dirty(&INITSYMPLIST(p), youngest, p, SIZE); - relocate_dirty(&INITSYMNAME(p), youngest, p, SIZE); - relocate_dirty(&INITSYMSPLIST(p), youngest, p, SIZE); - relocate_dirty(&INITSYMHASH(p), youngest, p, SIZE); + relocate_dirty(&INITSYMPLIST(p), youngest); + relocate_dirty(&INITSYMNAME(p), youngest); + relocate_dirty(&INITSYMSPLIST(p), youngest); + relocate_dirty(&INITSYMHASH(p), youngest); } } } @@ -2035,14 +2057,16 @@ static IGEN sweep_dirty_object(thread_gc *tgc, ptr p, IGEN youngest) } } POP_BACKREFERENCE() + FLUSH_REMOTE(tgc, p); return youngest; } static void sweep_record(thread_gc *tgc, ptr p, IGEN from_g) { + FLUSH_REMOTE_BLOCK PUSH_BACKREFERENCE(p) { - relocate_pure(&RECORDINSTTYPE(p), p, size_record_inst((UNFIX((RECORDDESCSIZE(RECORDINSTTYPE(p))))))); + relocate_pure(&RECORDINSTTYPE(p)); { ptr rtd = RECORDINSTTYPE(p); { @@ -2060,7 +2084,7 @@ static void sweep_record(thread_gc *tgc, ptr p, IGEN from_g) ptr* ppend = ((ptr*)(TO_VOIDP((((uptr)(TO_PTR(pp))) + len)))) - 1; while (pp < ppend) { - relocate_impure(&(*(pp)), from_g, p, SIZE); + relocate_impure(&(*(pp)), from_g); pp += 1; } } @@ -2071,7 +2095,7 @@ static void sweep_record(thread_gc *tgc, ptr p, IGEN from_g) { if (mask & 1) { - relocate_impure(&(*(pp)), from_g, p, SIZE); + relocate_impure(&(*(pp)), from_g); } mask >>= 1; pp += 1; @@ -2081,7 +2105,7 @@ static void sweep_record(thread_gc *tgc, ptr p, IGEN from_g) } else { - relocate_pure(&(RECORDDESCPM(rtd)), p, SIZE); + relocate_pure(&(RECORDDESCPM(rtd))); num = RECORDDESCPM(rtd); { iptr index = (BIGLEN(num)) - 1; @@ -2093,7 +2117,7 @@ static void sweep_record(thread_gc *tgc, ptr p, IGEN from_g) { if (mask & 1) { - relocate_impure(&(*(pp)), from_g, p, SIZE); + relocate_impure(&(*(pp)), from_g); } mask >>= 1; pp += 1; @@ -2115,10 +2139,12 @@ static void sweep_record(thread_gc *tgc, ptr p, IGEN from_g) } } POP_BACKREFERENCE() + FLUSH_REMOTE(tgc, p); } static IGEN sweep_dirty_record(thread_gc *tgc, ptr p, IGEN youngest) { + FLUSH_REMOTE_BLOCK PUSH_BACKREFERENCE(p) { { @@ -2134,7 +2160,7 @@ static IGEN sweep_dirty_record(thread_gc *tgc, ptr p, IGEN youngest) { if (mask & 1) { - relocate_dirty(&(*(pp)), youngest, p, SIZE); + relocate_dirty(&(*(pp)), youngest); } mask >>= 1; pp += 1; @@ -2153,7 +2179,7 @@ static IGEN sweep_dirty_record(thread_gc *tgc, ptr p, IGEN youngest) { if (mask & 1) { - relocate_dirty(&(*(pp)), youngest, p, SIZE); + relocate_dirty(&(*(pp)), youngest); } mask >>= 1; pp += 1; @@ -2174,62 +2200,68 @@ static IGEN sweep_dirty_record(thread_gc *tgc, ptr p, IGEN youngest) } } POP_BACKREFERENCE() + FLUSH_REMOTE(tgc, p); return youngest; } static void sweep_symbol(thread_gc *tgc, ptr p, IGEN from_g) { + FLUSH_REMOTE_BLOCK PUSH_BACKREFERENCE(p) { { - relocate_impure(&INITSYMVAL(p), from_g, p, SIZE); + relocate_impure(&INITSYMVAL(p), from_g); { ptr val = INITSYMVAL(p); { ptr code = ((Sprocedurep(val)) ? (CLOSCODE(val)) : (SYMCODE(p))); - relocate_pure(&code, p, SIZE); + relocate_pure(&code); INITSYMCODE(p, code); - relocate_impure(&INITSYMPLIST(p), from_g, p, SIZE); - relocate_impure(&INITSYMNAME(p), from_g, p, SIZE); - relocate_impure(&INITSYMSPLIST(p), from_g, p, SIZE); - relocate_impure(&INITSYMHASH(p), from_g, p, SIZE); + relocate_impure(&INITSYMPLIST(p), from_g); + relocate_impure(&INITSYMNAME(p), from_g); + relocate_impure(&INITSYMSPLIST(p), from_g); + relocate_impure(&INITSYMHASH(p), from_g); } } } } POP_BACKREFERENCE() + FLUSH_REMOTE(tgc, p); } static IGEN sweep_dirty_symbol(thread_gc *tgc, ptr p, IGEN youngest) { + FLUSH_REMOTE_BLOCK PUSH_BACKREFERENCE(p) { { - relocate_dirty(&INITSYMVAL(p), youngest, p, SIZE); + relocate_dirty(&INITSYMVAL(p), youngest); { ptr val = INITSYMVAL(p); { ptr code = ((Sprocedurep(val)) ? (CLOSCODE(val)) : (SYMCODE(p))); - relocate_dirty(&code, youngest, p, SIZE); + relocate_dirty(&code, youngest); INITSYMCODE(p, code); - relocate_dirty(&INITSYMPLIST(p), youngest, p, SIZE); - relocate_dirty(&INITSYMNAME(p), youngest, p, SIZE); - relocate_dirty(&INITSYMSPLIST(p), youngest, p, SIZE); - relocate_dirty(&INITSYMHASH(p), youngest, p, SIZE); + relocate_dirty(&INITSYMPLIST(p), youngest); + relocate_dirty(&INITSYMNAME(p), youngest); + relocate_dirty(&INITSYMSPLIST(p), youngest); + relocate_dirty(&INITSYMHASH(p), youngest); } } } } POP_BACKREFERENCE() + FLUSH_REMOTE(tgc, p); return youngest; } static void sweep_thread(thread_gc *tgc, ptr p) { + FLUSH_REMOTE_BLOCK PUSH_BACKREFERENCE(p) { { @@ -2249,10 +2281,10 @@ static void sweep_thread(thread_gc *tgc, ptr p) } } STACKCACHE(tc) = Snil; - relocate_pure(&(CCHAIN(tc)), p, SIZE); - relocate_pure(&(STACKLINK(tc)), p, SIZE); - relocate_pure(&(WINDERS(tc)), p, SIZE); - relocate_pure(&(ATTACHMENTS(tc)), p, SIZE); + relocate_pure(&(CCHAIN(tc))); + relocate_pure(&(STACKLINK(tc))); + relocate_pure(&(WINDERS(tc))); + relocate_pure(&(ATTACHMENTS(tc))); CACHEDFRAME(tc) = Sfalse; { ptr xcp = FRAME(tc, 0); @@ -2264,7 +2296,7 @@ static void sweep_thread(thread_gc *tgc, ptr p) seginfo* x_si = SegInfo((ptr_get_segment(c_p))); if (x_si -> old_space) { - relocate_code(c_p, x_si, p, SIZE); + relocate_code(c_p, x_si); FRAME(tc, 0) = (ptr)(((uptr)c_p) + co); } { @@ -2294,7 +2326,7 @@ static void sweep_thread(thread_gc *tgc, ptr p) seginfo* x_si = SegInfo((ptr_get_segment(c_p))); if (x_si -> old_space) { - relocate_code(c_p, x_si, p, SIZE); + relocate_code(c_p, x_si); *(pp) = (ptr)(((uptr)c_p) + co); } { @@ -2308,7 +2340,7 @@ static void sweep_thread(thread_gc *tgc, ptr p) pp += 1; if (mask & 1) { - relocate_pure(&(*(pp)), p, SIZE); + relocate_pure(&(*(pp))); } mask >>= 1; } @@ -2322,12 +2354,12 @@ static void sweep_thread(thread_gc *tgc, ptr p) } else if (SEGMENT_IS_LOCAL(n_si, num)) { - relocate_pure(&(*((ENTRYNONCOMPACTLIVEMASKADDR(oldret)))), p, SIZE); + relocate_pure(&(*((ENTRYNONCOMPACTLIVEMASKADDR(oldret))))); num = ENTRYLIVEMASK(oldret); } else { - RECORD_REMOTE_RANGE(tgc, p, SIZE, n_si); + RECORD_REMOTE(n_si); num = S_G.zero_length_bignum; } { @@ -2344,7 +2376,7 @@ static void sweep_thread(thread_gc *tgc, ptr p) pp += 1; if (mask & 1) { - relocate_pure(&(*(pp)), p, SIZE); + relocate_pure(&(*(pp))); } mask >>= 1; } @@ -2364,33 +2396,29 @@ static void sweep_thread(thread_gc *tgc, ptr p) W(tc) = 0; X(tc) = 0; Y(tc) = 0; - relocate_pure(&(THREADNO(tc)), p, SIZE); - relocate_pure(&(CURRENTINPUT(tc)), p, SIZE); - relocate_pure(&(CURRENTOUTPUT(tc)), p, SIZE); - relocate_pure(&(CURRENTERROR(tc)), p, SIZE); - relocate_pure(&(SFD(tc)), p, SIZE); - relocate_pure(&(CURRENTMSO(tc)), p, SIZE); - relocate_pure(&(TARGETMACHINE(tc)), p, SIZE); - relocate_pure(&(FXLENGTHBV(tc)), p, SIZE); - relocate_pure(&(FXFIRSTBITSETBV(tc)), p, SIZE); - relocate_pure(&(NULLIMMUTABLEVECTOR(tc)), p, SIZE); - relocate_pure(&(NULLIMMUTABLEFXVECTOR(tc)), p, SIZE); - relocate_pure(&(NULLIMMUTABLEBYTEVECTOR(tc)), p, SIZE); - relocate_pure(&(NULLIMMUTABLESTRING(tc)), p, SIZE); - relocate_pure(&(COMPILEPROFILE(tc)), p, SIZE); - relocate_pure(&(SUBSETMODE(tc)), p, SIZE); - relocate_pure(&(DEFAULTRECORDEQUALPROCEDURE(tc)), p, SIZE); - relocate_pure(&(DEFAULTRECORDHASHPROCEDURE(tc)), p, SIZE); - relocate_pure(&(COMPRESSFORMAT(tc)), p, SIZE); - relocate_pure(&(COMPRESSLEVEL(tc)), p, SIZE); - relocate_pure(&(PARAMETERS(tc)), p, SIZE); + relocate_pure(&(THREADNO(tc))); + relocate_pure(&(CURRENTINPUT(tc))); + relocate_pure(&(CURRENTOUTPUT(tc))); + relocate_pure(&(CURRENTERROR(tc))); + relocate_pure(&(SFD(tc))); + relocate_pure(&(CURRENTMSO(tc))); + relocate_pure(&(TARGETMACHINE(tc))); + relocate_pure(&(FXLENGTHBV(tc))); + relocate_pure(&(FXFIRSTBITSETBV(tc))); + relocate_pure(&(COMPILEPROFILE(tc))); + relocate_pure(&(SUBSETMODE(tc))); + relocate_pure(&(DEFAULTRECORDEQUALPROCEDURE(tc))); + relocate_pure(&(DEFAULTRECORDHASHPROCEDURE(tc))); + relocate_pure(&(COMPRESSFORMAT(tc))); + relocate_pure(&(COMPRESSLEVEL(tc))); + relocate_pure(&(PARAMETERS(tc))); DSTBV(tc) = Sfalse; SRCBV(tc) = Sfalse; { INT i = 0; while (i < virtual_register_count) { - relocate_pure(&(VIRTREG(tc, i)), p, SIZE); + relocate_pure(&(VIRTREG(tc, i))); i += 1; } } @@ -2405,62 +2433,68 @@ static void sweep_thread(thread_gc *tgc, ptr p) } } POP_BACKREFERENCE() + FLUSH_REMOTE(tgc, p); } static void sweep_port(thread_gc *tgc, ptr p, IGEN from_g) { + FLUSH_REMOTE_BLOCK PUSH_BACKREFERENCE(p) { - relocate_impure(&PORTHANDLER(p), from_g, p, SIZE); + relocate_impure(&PORTHANDLER(p), from_g); if (((uptr)TYPEFIELD(p)) & PORT_FLAG_OUTPUT) { iptr n = ((iptr)(PORTOLAST(p))) - ((iptr)(PORTOBUF(p))); - relocate_impure(&PORTOBUF(p), from_g, p, SIZE); + relocate_impure(&PORTOBUF(p), from_g); PORTOLAST(p) = (ptr)(((iptr)(PORTOBUF(p))) + n); } if (((uptr)TYPEFIELD(p)) & PORT_FLAG_INPUT) { iptr n = ((iptr)(PORTILAST(p))) - ((iptr)(PORTIBUF(p))); - relocate_impure(&PORTIBUF(p), from_g, p, SIZE); + relocate_impure(&PORTIBUF(p), from_g); PORTILAST(p) = (ptr)(((iptr)(PORTIBUF(p))) + n); } - relocate_impure(&PORTINFO(p), from_g, p, SIZE); - relocate_impure(&PORTNAME(p), from_g, p, SIZE); + relocate_impure(&PORTINFO(p), from_g); + relocate_impure(&PORTNAME(p), from_g); } POP_BACKREFERENCE() + FLUSH_REMOTE(tgc, p); } static IGEN sweep_dirty_port(thread_gc *tgc, ptr p, IGEN youngest) { + FLUSH_REMOTE_BLOCK PUSH_BACKREFERENCE(p) { - relocate_dirty(&PORTHANDLER(p), youngest, p, SIZE); + relocate_dirty(&PORTHANDLER(p), youngest); if (((uptr)TYPEFIELD(p)) & PORT_FLAG_OUTPUT) { iptr n = ((iptr)(PORTOLAST(p))) - ((iptr)(PORTOBUF(p))); - relocate_dirty(&PORTOBUF(p), youngest, p, SIZE); + relocate_dirty(&PORTOBUF(p), youngest); PORTOLAST(p) = (ptr)(((iptr)(PORTOBUF(p))) + n); } if (((uptr)TYPEFIELD(p)) & PORT_FLAG_INPUT) { iptr n = ((iptr)(PORTILAST(p))) - ((iptr)(PORTIBUF(p))); - relocate_dirty(&PORTIBUF(p), youngest, p, SIZE); + relocate_dirty(&PORTIBUF(p), youngest); PORTILAST(p) = (ptr)(((iptr)(PORTIBUF(p))) + n); } - relocate_dirty(&PORTINFO(p), youngest, p, SIZE); - relocate_dirty(&PORTNAME(p), youngest, p, SIZE); + relocate_dirty(&PORTINFO(p), youngest); + relocate_dirty(&PORTNAME(p), youngest); } POP_BACKREFERENCE() + FLUSH_REMOTE(tgc, p); return youngest; } static void sweep_continuation(thread_gc *tgc, ptr p, IGEN from_g) { + FLUSH_REMOTE_BLOCK PUSH_BACKREFERENCE(p) { { - relocate_pure(&CONTWINDERS(p), p, SIZE); - relocate_impure(&CONTATTACHMENTS(p), from_g, p, SIZE); + relocate_pure(&CONTWINDERS(p)); + relocate_impure(&CONTATTACHMENTS(p), from_g); if ((CONTLENGTH(p)) == scaled_shot_1_shot_flag) { } @@ -2473,14 +2507,14 @@ static void sweep_continuation(thread_gc *tgc, ptr p, IGEN from_g) { if (!(SEGMENT_IS_LOCAL(s_si, stk))) { - RECORD_REMOTE_RANGE(tgc, p, SIZE, s_si); + RECORD_REMOTE(s_si); } else { CONTSTACK(p) = copy_stack(tgc, CONTSTACK(p), &(CONTLENGTH(p)), CONTCLENGTH(p)); } } - relocate_pure(&CONTLINK(p), p, SIZE); + relocate_pure(&CONTLINK(p)); { ptr xcp = CONTRET(p); { @@ -2491,7 +2525,7 @@ static void sweep_continuation(thread_gc *tgc, ptr p, IGEN from_g) seginfo* x_si = SegInfo((ptr_get_segment(c_p))); if (x_si -> old_space) { - relocate_code(c_p, x_si, p, SIZE); + relocate_code(c_p, x_si); CONTRET(p) = (ptr)(((uptr)c_p) + co); } { @@ -2523,7 +2557,7 @@ static void sweep_continuation(thread_gc *tgc, ptr p, IGEN from_g) seginfo* x_si = SegInfo((ptr_get_segment(c_p))); if (x_si -> old_space) { - relocate_code(c_p, x_si, p, SIZE); + relocate_code(c_p, x_si); *(pp) = (ptr)(((uptr)c_p) + co); } { @@ -2537,7 +2571,7 @@ static void sweep_continuation(thread_gc *tgc, ptr p, IGEN from_g) pp += 1; if (mask & 1) { - relocate_pure(&(*(pp)), p, SIZE); + relocate_pure(&(*(pp))); } mask >>= 1; } @@ -2551,12 +2585,12 @@ static void sweep_continuation(thread_gc *tgc, ptr p, IGEN from_g) } else if (SEGMENT_IS_LOCAL(n_si, num)) { - relocate_pure(&(*((ENTRYNONCOMPACTLIVEMASKADDR(oldret)))), p, SIZE); + relocate_pure(&(*((ENTRYNONCOMPACTLIVEMASKADDR(oldret))))); num = ENTRYLIVEMASK(oldret); } else { - RECORD_REMOTE_RANGE(tgc, p, SIZE, n_si); + RECORD_REMOTE(n_si); num = S_G.zero_length_bignum; } { @@ -2573,7 +2607,7 @@ static void sweep_continuation(thread_gc *tgc, ptr p, IGEN from_g) pp += 1; if (mask & 1) { - relocate_pure(&(*(pp)), p, SIZE); + relocate_pure(&(*(pp))); } mask >>= 1; } @@ -2601,16 +2635,18 @@ static void sweep_continuation(thread_gc *tgc, ptr p, IGEN from_g) } } POP_BACKREFERENCE() + FLUSH_REMOTE(tgc, p); } static void sweep_code_object(thread_gc *tgc, ptr p, IGEN from_g) { + FLUSH_REMOTE_BLOCK PUSH_BACKREFERENCE(p) { - relocate_pure(&CODENAME(p), p, SIZE); - relocate_pure(&CODEARITYMASK(p), p, SIZE); - relocate_pure(&CODEINFO(p), p, SIZE); - relocate_pure(&CODEPINFOS(p), p, SIZE); + relocate_pure(&CODENAME(p)); + relocate_pure(&CODEARITYMASK(p)); + relocate_pure(&CODEINFO(p)); + relocate_pure(&CODEPINFOS(p)); { ptr t = CODERELOC(p); { @@ -2647,7 +2683,7 @@ static void sweep_code_object(thread_gc *tgc, ptr p, IGEN from_g) a = a + code_off; { ptr obj = S_get_code_obj(RELOC_TYPE(entry), oldco, a, item_off); - relocate_pure(&obj, p, SIZE); + relocate_pure(&obj); S_set_code_obj("gc", RELOC_TYPE(entry), p, a, obj, item_off); } } @@ -2685,7 +2721,7 @@ static void sweep_code_object(thread_gc *tgc, ptr p, IGEN from_g) } else { - RECORD_REMOTE_RANGE(tgc, p, SIZE, t_si); + RECORD_REMOTE(t_si); } } } @@ -2700,6 +2736,7 @@ static void sweep_code_object(thread_gc *tgc, ptr p, IGEN from_g) } } POP_BACKREFERENCE() + FLUSH_REMOTE(tgc, p); } static uptr size_object(ptr p) @@ -2753,6 +2790,14 @@ static uptr size_object(ptr p) return p_sz; } } + else if (TYPEP(tf, mask_flvector, type_flvector)) + { + uptr sz = size_flvector((Sflvector_length(p))); + { + uptr p_sz = sz; + return p_sz; + } + } else if (TYPEP(tf, mask_bytevector, type_bytevector)) { uptr sz = size_bytevector((Sbytevector_length(p))); @@ -2899,7 +2944,7 @@ static IGEN mark_object(thread_gc *tgc, ptr p, seginfo *si) on tag-reflexive base descriptor */ if (p != tf) { - relocate_pure(&RECORDINSTTYPE(p), p, SIZE); + relocate_pure(&RECORDINSTTYPE(p)); } { ptr rtd = RECORDINSTTYPE(p); @@ -2970,7 +3015,7 @@ static IGEN mark_object(thread_gc *tgc, ptr p, seginfo *si) } else { - relocate_pure(&counts, p, SIZE); + relocate_pure(&counts); RECORDDESCCOUNTS(c_rtd) = counts; if ((RTDCOUNTSTIMESTAMP(counts)) != (S_G.gctimestamp[0])) { @@ -3120,6 +3165,44 @@ static IGEN mark_object(thread_gc *tgc, ptr p, seginfo *si) S_G.bytesof[TARGET_GENERATION(si)][countof_fxvector] += p_sz; } } + else if (TYPEP(tf, mask_flvector, type_flvector)) + { + uptr sz = size_flvector((Sflvector_length(p))); + { + uptr p_sz = sz; + si->marked_mask[segment_bitmap_byte(p)] |= segment_bitmap_bit(p); + { + uptr addr = (uptr)UNTYPE(p, type_typed_object); + uptr seg = addr_get_segment(addr); + uptr end_seg = addr_get_segment(addr + p_sz - 1); + if (seg == end_seg) { + si->marked_count += p_sz; + } else { + seginfo *mark_si; IGEN g; + si->marked_count += ((uptr)build_ptr(seg+1,0)) - addr; + seg++; + while (seg < end_seg) { + mark_si = SegInfo(seg); + g = mark_si->generation; + if (!fully_marked_mask[g]) init_fully_marked_mask(tgc, g); + mark_si->marked_mask = fully_marked_mask[g]; + mark_si->marked_count = bytes_per_segment; + seg++; + } + mark_si = SegInfo(end_seg); + { + if (!mark_si->marked_mask) { + init_mask(tgc, mark_si->marked_mask, mark_si->generation, 0); + } + /* no need to set a bit: it's enough to have made `marked_mask` non-NULL */ + mark_si->marked_count += addr + p_sz - (uptr)build_ptr(end_seg,0); + } + } + } + S_G.countof[TARGET_GENERATION(si)][countof_flvector] += 1; + S_G.bytesof[TARGET_GENERATION(si)][countof_flvector] += p_sz; + } + } else if (TYPEP(tf, mask_bytevector, type_bytevector)) { uptr sz = size_bytevector((Sbytevector_length(p))); @@ -3175,9 +3258,9 @@ static IGEN mark_object(thread_gc *tgc, ptr p, seginfo *si) ptr keyval = INITTLCKEYVAL(p); if ((next != Sfalse) && (OLDSPACE(keyval))) { - GC_TC_MUTEX_ACQUIRE(); + GC_MUTEX_ACQUIRE(); tlcs_to_rehash = S_cons_in(tgc -> tc, space_new, 0, p, tlcs_to_rehash); - GC_TC_MUTEX_RELEASE(); + GC_MUTEX_RELEASE(); } S_G.countof[TARGET_GENERATION(si)][countof_tlc] += 1; } @@ -3194,8 +3277,8 @@ static IGEN mark_object(thread_gc *tgc, ptr p, seginfo *si) else if ((iptr)tf == type_ratnum) { uptr p_sz = size_ratnum; - relocate_pure(&RATNUM(p), p, SIZE); - relocate_pure(&RATDEN(p), p, SIZE); + relocate_pure(&RATNUM(p)); + relocate_pure(&RATDEN(p)); si->marked_count += p_sz; { ptr mark_p = p; @@ -3209,8 +3292,8 @@ static IGEN mark_object(thread_gc *tgc, ptr p, seginfo *si) else if ((iptr)tf == type_exactnum) { uptr p_sz = size_exactnum; - relocate_pure(&EXACTNUM_REAL_PART(p), p, SIZE); - relocate_pure(&EXACTNUM_IMAG_PART(p), p, SIZE); + relocate_pure(&EXACTNUM_REAL_PART(p)); + relocate_pure(&EXACTNUM_IMAG_PART(p)); si->marked_count += p_sz; { ptr mark_p = p; @@ -3334,9 +3417,9 @@ static IGEN mark_object(thread_gc *tgc, ptr p, seginfo *si) si->marked_mask[segment_bitmap_byte(p)] |= segment_bitmap_bit(p); si->marked_count += p_sz; S_G.countof[TARGET_GENERATION(si)][countof_phantom] += 1; - GC_TC_MUTEX_ACQUIRE(); + GC_MUTEX_ACQUIRE(); (S_G.bytesof[TARGET_GENERATION(si)])[countof_phantom] += PHANTOMLEN(p); - GC_TC_MUTEX_RELEASE(); + GC_MUTEX_RELEASE(); } else { @@ -3376,16 +3459,16 @@ static IGEN mark_object(thread_gc *tgc, ptr p, seginfo *si) else if (t == type_closure) { ptr code = CLOSCODE(p); - relocate_pure(&code, p, SIZE); + relocate_pure(&code); if ((CODETYPE(code)) & (code_flag_continuation << code_flags_offset)) { uptr p_sz = size_continuation; if ((CONTLENGTH(p)) == opportunistic_1_shot_flag) { CONTLENGTH(p) = CONTCLENGTH(p); - GC_TC_MUTEX_ACQUIRE(); + GC_MUTEX_ACQUIRE(); conts_to_promote = S_cons_in(tgc -> tc, space_new, 0, p, conts_to_promote); - GC_TC_MUTEX_RELEASE(); + GC_MUTEX_RELEASE(); } else { @@ -3622,6 +3705,9 @@ static IBOOL object_directly_refers_to_self(ptr p) else if (TYPEP(tf, mask_fxvector, type_fxvector)) { } + else if (TYPEP(tf, mask_flvector, type_flvector)) + { + } else if (TYPEP(tf, mask_bytevector, type_bytevector)) { } @@ -3952,6 +4038,14 @@ static void measure(thread_gc *tgc, ptr p) measure_total += p_sz; } } + else if (TYPEP(tf, mask_flvector, type_flvector)) + { + uptr sz = size_flvector((Sflvector_length(p))); + { + uptr p_sz = sz; + measure_total += p_sz; + } + } else if (TYPEP(tf, mask_bytevector, type_bytevector)) { uptr sz = size_bytevector((Sbytevector_length(p))); @@ -4237,7 +4331,6 @@ static void measure(thread_gc *tgc, ptr p) } else { - RECORD_REMOTE_RANGE(tgc, p, SIZE, n_si); num = S_G.zero_length_bignum; } { @@ -4318,26 +4411,6 @@ static void measure(thread_gc *tgc, ptr p) push_measure(tgc, r_p); } { /* measure */ - ptr r_p = NULLIMMUTABLEVECTOR(tc); - if (!IMMEDIATE(r_p)) - push_measure(tgc, r_p); - } - { /* measure */ - ptr r_p = NULLIMMUTABLEFXVECTOR(tc); - if (!IMMEDIATE(r_p)) - push_measure(tgc, r_p); - } - { /* measure */ - ptr r_p = NULLIMMUTABLEBYTEVECTOR(tc); - if (!IMMEDIATE(r_p)) - push_measure(tgc, r_p); - } - { /* measure */ - ptr r_p = NULLIMMUTABLESTRING(tc); - if (!IMMEDIATE(r_p)) - push_measure(tgc, r_p); - } - { /* measure */ ptr r_p = COMPILEPROFILE(tc); if (!IMMEDIATE(r_p)) push_measure(tgc, r_p); @@ -4557,7 +4630,6 @@ static void measure(thread_gc *tgc, ptr p) } else { - RECORD_REMOTE_RANGE(tgc, p, SIZE, n_si); num = S_G.zero_length_bignum; } { diff --git a/src/ChezScheme/boot/pb/gc-par.inc b/src/ChezScheme/boot/pb/gc-par.inc index cc4a504cea..9d60ec3741 100644 --- a/src/ChezScheme/boot/pb/gc-par.inc +++ b/src/ChezScheme/boot/pb/gc-par.inc @@ -103,6 +103,18 @@ static IGEN copy(thread_gc *tgc, ptr p, seginfo *si, ptr *dest) } } } + else if (TYPEP(tf, mask_flvector, type_flvector)) + { + ISPC p_spc = space_data; + { + uptr sz = size_flvector((Sflvector_length(p))); + { + uptr p_sz = sz; + find_gc_room(tgc, p_spc, tg, type_typed_object, p_sz, new_p); + memcpy_aligned(&FLVECTOR_TYPE(new_p), &FLVECTOR_TYPE(p), sz); + } + } + } else if (TYPEP(tf, mask_bytevector, type_bytevector)) { ISPC p_spc = space_data; @@ -131,9 +143,9 @@ static IGEN copy(thread_gc *tgc, ptr p, seginfo *si, ptr *dest) INITTLCKEYVAL(new_p) = keyval; if ((next != Sfalse) && (OLDSPACE(keyval))) { - GC_TC_MUTEX_ACQUIRE(); + GC_MUTEX_ACQUIRE(); tlcs_to_rehash = S_cons_in(tgc -> tc, space_new, 0, new_p, tlcs_to_rehash); - GC_TC_MUTEX_RELEASE(); + GC_MUTEX_RELEASE(); } } } @@ -275,9 +287,9 @@ static IGEN copy(thread_gc *tgc, ptr p, seginfo *si, ptr *dest) find_gc_room(tgc, p_spc, tg, type_typed_object, p_sz, new_p); PHANTOMTYPE(new_p) = type_phantom; PHANTOMLEN(new_p) = PHANTOMLEN(p); - GC_TC_MUTEX_ACQUIRE(); + GC_MUTEX_ACQUIRE(); (S_G.bytesof[tg])[countof_phantom] += PHANTOMLEN(p); - GC_TC_MUTEX_RELEASE(); + GC_MUTEX_RELEASE(); } } else @@ -372,9 +384,9 @@ static IGEN copy(thread_gc *tgc, ptr p, seginfo *si, ptr *dest) if ((CONTLENGTH(p)) == opportunistic_1_shot_flag) { CONTLENGTH(new_p) = CONTCLENGTH(p); - GC_TC_MUTEX_ACQUIRE(); + GC_MUTEX_ACQUIRE(); conts_to_promote = S_cons_in(tgc -> tc, space_new, 0, new_p, conts_to_promote); - GC_TC_MUTEX_RELEASE(); + GC_MUTEX_RELEASE(); } else { @@ -457,6 +469,7 @@ static IGEN copy(thread_gc *tgc, ptr p, seginfo *si, ptr *dest) static void sweep(thread_gc *tgc, ptr p, IGEN from_g) { + FLUSH_REMOTE_BLOCK { ITYPE t = TYPEBITS(p); if (t == type_typed_object) @@ -464,83 +477,80 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) ptr tf = TYPEFIELD(p); if (TYPEP(tf, mask_record, type_record)) { - relocate_pure(&RECORDINSTTYPE(p), p, size_record_inst((UNFIX((RECORDDESCSIZE(RECORDINSTTYPE(p))))))); + relocate_pure(&RECORDINSTTYPE(p)); { ptr rtd = RECORDINSTTYPE(p); { uptr len = UNFIX((RECORDDESCSIZE(rtd))); { - uptr p_sz = size_record_inst(len); + ptr num = RECORDDESCPM(rtd); + ptr* pp = &(RECORDINSTIT(p, 0)); + if (Sfixnump(num)) { - ptr num = RECORDDESCPM(rtd); - ptr* pp = &(RECORDINSTIT(p, 0)); - if (Sfixnump(num)) { + uptr mask = ((uptr)(UNFIX(num))) >> 1; + if (mask == (((uptr)-1) >> 1)) { - uptr mask = ((uptr)(UNFIX(num))) >> 1; - if (mask == (((uptr)-1) >> 1)) { + ptr* ppend = ((ptr*)(TO_VOIDP((((uptr)(TO_PTR(pp))) + len)))) - 1; + while (pp < ppend) { - ptr* ppend = ((ptr*)(TO_VOIDP((((uptr)(TO_PTR(pp))) + len)))) - 1; - while (pp < ppend) - { - relocate_impure(&(*(pp)), from_g, p, p_sz); - pp += 1; - } + relocate_impure(&(*(pp)), from_g); + pp += 1; } } - else + } + else + { + while (mask != 0) { - while (mask != 0) + if (mask & 1) { - if (mask & 1) - { - relocate_impure(&(*(pp)), from_g, p, p_sz); - } - mask >>= 1; - pp += 1; + relocate_impure(&(*(pp)), from_g); } + mask >>= 1; + pp += 1; } } } + } + else + { + seginfo* pm_si = SegInfo((ptr_get_segment(num))); + if ((!(pm_si -> old_space)) || (SEGMENT_IS_LOCAL(pm_si, num))) + { + relocate_pure(&(RECORDDESCPM(rtd))); + num = RECORDDESCPM(rtd); + } else { - seginfo* pm_si = SegInfo((ptr_get_segment(num))); - if ((!(pm_si -> old_space)) || (SEGMENT_IS_LOCAL(pm_si, num))) - { - relocate_pure(&(RECORDDESCPM(rtd)), p, p_sz); - num = RECORDDESCPM(rtd); - } - else - { - RECORD_REMOTE_RANGE(tgc, p, p_sz, pm_si); - num = S_G.zero_length_bignum; - } + RECORD_REMOTE(pm_si); + num = S_G.zero_length_bignum; + } + { + iptr index = (BIGLEN(num)) - 1; + bigit mask = (BIGIT(num, index)) >> 1; + INT bits = bigit_bits - 1; + while (1) { - iptr index = (BIGLEN(num)) - 1; - bigit mask = (BIGIT(num, index)) >> 1; - INT bits = bigit_bits - 1; - while (1) + do { - do - { - if (mask & 1) - { - relocate_impure(&(*(pp)), from_g, p, p_sz); - } - mask >>= 1; - pp += 1; - bits -= 1; - } - while (bits > 0); - if (index == 0) + if (mask & 1) { - break; + relocate_impure(&(*(pp)), from_g); } - index -= 1; - mask = BIGIT(num, index); - bits = bigit_bits; + mask >>= 1; + pp += 1; + bits -= 1; } + while (bits > 0); + if (index == 0) + { + break; + } + index -= 1; + mask = BIGIT(num, index); + bits = bigit_bits; } } } @@ -552,14 +562,11 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) { uptr len = Svector_length(p); { - uptr p_sz = size_vector(len); + uptr idx, p_len = len; + ptr *p_p = &INITVECTIT(p, 0); + for (idx = 0; idx < p_len; idx++) { - uptr idx, p_len = len; - ptr *p_p = &INITVECTIT(p, 0); - for (idx = 0; idx < p_len; idx++) - { - relocate_impure(&(p_p[idx]), from_g, p, p_sz); - } + relocate_impure(&(p_p[idx]), from_g); } } } @@ -567,14 +574,11 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) { uptr len = Sstencil_vector_length(p); { - uptr p_sz = size_stencil_vector(len); + uptr idx, p_len = len; + ptr *p_p = &INITSTENVECTIT(p, 0); + for (idx = 0; idx < p_len; idx++) { - uptr idx, p_len = len; - ptr *p_p = &INITSTENVECTIT(p, 0); - for (idx = 0; idx < p_len; idx++) - { - relocate_impure(&(p_p[idx]), from_g, p, p_sz); - } + relocate_impure(&(p_p[idx]), from_g); } } } @@ -584,32 +588,31 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) else if (TYPEP(tf, mask_fxvector, type_fxvector)) { } + else if (TYPEP(tf, mask_flvector, type_flvector)) + { + } else if (TYPEP(tf, mask_bytevector, type_bytevector)) { } else if ((iptr)tf == type_tlc) { - uptr p_sz = size_tlc; - relocate_impure(&INITTLCHT(p), from_g, p, p_sz); - relocate_impure(&INITTLCKEYVAL(p), from_g, p, p_sz); - relocate_impure(&INITTLCNEXT(p), from_g, p, p_sz); + relocate_impure(&INITTLCHT(p), from_g); + relocate_impure(&INITTLCKEYVAL(p), from_g); + relocate_impure(&INITTLCNEXT(p), from_g); } else if (TYPEP(tf, mask_box, type_box)) { - uptr p_sz = size_box; - relocate_impure(&INITBOXREF(p), from_g, p, p_sz); + relocate_impure(&INITBOXREF(p), from_g); } else if ((iptr)tf == type_ratnum) { - uptr p_sz = size_ratnum; - relocate_pure(&RATNUM(p), p, p_sz); - relocate_pure(&RATDEN(p), p, p_sz); + relocate_pure(&RATNUM(p)); + relocate_pure(&RATDEN(p)); } else if ((iptr)tf == type_exactnum) { - uptr p_sz = size_exactnum; - relocate_pure(&EXACTNUM_REAL_PART(p), p, p_sz); - relocate_pure(&EXACTNUM_IMAG_PART(p), p, p_sz); + relocate_pure(&EXACTNUM_REAL_PART(p)); + relocate_pure(&EXACTNUM_IMAG_PART(p)); } else if ((iptr)tf == type_inexactnum) { @@ -619,113 +622,108 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) } else if (TYPEP(tf, mask_port, type_port)) { - uptr p_sz = size_port; - relocate_impure(&PORTHANDLER(p), from_g, p, p_sz); + relocate_impure(&PORTHANDLER(p), from_g); if (((uptr)tf) & PORT_FLAG_OUTPUT) { iptr n = ((iptr)(PORTOLAST(p))) - ((iptr)(PORTOBUF(p))); - relocate_impure(&PORTOBUF(p), from_g, p, p_sz); + relocate_impure(&PORTOBUF(p), from_g); PORTOLAST(p) = (ptr)(((iptr)(PORTOBUF(p))) + n); } if (((uptr)tf) & PORT_FLAG_INPUT) { iptr n = ((iptr)(PORTILAST(p))) - ((iptr)(PORTIBUF(p))); - relocate_impure(&PORTIBUF(p), from_g, p, p_sz); + relocate_impure(&PORTIBUF(p), from_g); PORTILAST(p) = (ptr)(((iptr)(PORTIBUF(p))) + n); } - relocate_impure(&PORTINFO(p), from_g, p, p_sz); - relocate_impure(&PORTNAME(p), from_g, p, p_sz); + relocate_impure(&PORTINFO(p), from_g); + relocate_impure(&PORTNAME(p), from_g); } else if (TYPEP(tf, mask_code, type_code)) { - uptr len = CODELEN(p); + relocate_pure(&CODENAME(p)); + relocate_pure(&CODEARITYMASK(p)); + relocate_pure(&CODEINFO(p)); + relocate_pure(&CODEPINFOS(p)); { - uptr p_sz = size_code(len); - relocate_pure(&CODENAME(p), p, p_sz); - relocate_pure(&CODEARITYMASK(p), p, p_sz); - relocate_pure(&CODEINFO(p), p, p_sz); - relocate_pure(&CODEPINFOS(p), p, p_sz); + ptr t = CODERELOC(p); { - ptr t = CODERELOC(p); + iptr m = (t + ? (RELOCSIZE(t)) + : 0); { - iptr m = (t - ? (RELOCSIZE(t)) - : 0); + ptr oldco = (t + ? (RELOCCODE(t)) + : 0); { - ptr oldco = (t - ? (RELOCCODE(t)) - : 0); + iptr a = 0; { - iptr a = 0; + iptr n = 0; + while (n < m) { - iptr n = 0; - while (n < m) { + uptr entry = RELOCIT(t, n); + uptr item_off = 0; + uptr code_off = 0; + n = n + 1; + if (RELOC_EXTENDED_FORMAT(entry)) { - uptr entry = RELOCIT(t, n); - uptr item_off = 0; - uptr code_off = 0; + item_off = RELOCIT(t, n); + n = n + 1; + code_off = RELOCIT(t, n); n = n + 1; - if (RELOC_EXTENDED_FORMAT(entry)) - { - item_off = RELOCIT(t, n); - n = n + 1; - code_off = RELOCIT(t, n); - n = n + 1; - } - else - { - item_off = RELOC_ITEM_OFFSET(entry); - code_off = RELOC_CODE_OFFSET(entry); - } - a = a + code_off; - { - ptr obj = S_get_code_obj(RELOC_TYPE(entry), oldco, a, item_off); - relocate_pure(&obj, p, p_sz); - S_set_code_obj("gc", RELOC_TYPE(entry), p, a, obj, item_off); - } + } + else + { + item_off = RELOC_ITEM_OFFSET(entry); + code_off = RELOC_CODE_OFFSET(entry); + } + a = a + code_off; + { + ptr obj = S_get_code_obj(RELOC_TYPE(entry), oldco, a, item_off); + relocate_pure(&obj); + S_set_code_obj("gc", RELOC_TYPE(entry), p, a, obj, item_off); } } - if ((from_g == static_generation) && ((!S_G.retain_static_relocation) && (0 == ((CODETYPE(p)) & (code_flag_template << code_flags_offset))))) - { - CODERELOC(p) = (ptr)0; - } - else + } + if ((from_g == static_generation) && ((!S_G.retain_static_relocation) && (0 == ((CODETYPE(p)) & (code_flag_template << code_flags_offset))))) + { + CODERELOC(p) = (ptr)0; + } + else + { { + seginfo* t_si = SegInfo((ptr_get_segment(t))); + if (t_si -> old_space) { - seginfo* t_si = SegInfo((ptr_get_segment(t))); - if (t_si -> old_space) + if (SEGMENT_IS_LOCAL(t_si, t)) { - if (SEGMENT_IS_LOCAL(t_si, t)) + n = size_reloc_table((RELOCSIZE(t))); + if (t_si -> use_marks) { - n = size_reloc_table((RELOCSIZE(t))); - if (t_si -> use_marks) + if (!(marked(t_si, t))) { - if (!(marked(t_si, t))) - { - mark_typemod_data_object(tgc, t, n, t_si); - } - } - else - { - { - ptr oldt = t; - find_gc_room(tgc, space_data, from_g, typemod, n, t); - memcpy_aligned(TO_VOIDP(t), TO_VOIDP(oldt), n); - } + mark_typemod_data_object(tgc, t, n, t_si); } } else { - RECORD_REMOTE_RANGE(tgc, p, p_sz, t_si); + { + ptr oldt = t; + find_gc_room(tgc, space_data, from_g, typemod, n, t); + memcpy_aligned(TO_VOIDP(t), TO_VOIDP(oldt), n); + } } } + else + { + RECORD_REMOTE(t_si); + } } - RELOCCODE(t) = p; - CODERELOC(p) = t; } - S_record_code_mod(tgc -> tc, (uptr)(TO_PTR((&(CODEIT(p, 0))))), (uptr)(CODELEN(p))); + RELOCCODE(t) = p; + CODERELOC(p) = t; } + S_record_code_mod(tgc -> tc, (uptr)(TO_PTR((&(CODEIT(p, 0))))), (uptr)(CODELEN(p))); } } } @@ -734,7 +732,6 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) } else if ((iptr)tf == type_thread) { - uptr p_sz = size_thread; { ptr tc = (ptr)(THREADTC(p)); if (tc != ((ptr)0)) @@ -752,10 +749,10 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) } } STACKCACHE(tc) = Snil; - relocate_pure(&(CCHAIN(tc)), p, p_sz); - relocate_pure(&(STACKLINK(tc)), p, p_sz); - relocate_pure(&(WINDERS(tc)), p, p_sz); - relocate_pure(&(ATTACHMENTS(tc)), p, p_sz); + relocate_pure(&(CCHAIN(tc))); + relocate_pure(&(STACKLINK(tc))); + relocate_pure(&(WINDERS(tc))); + relocate_pure(&(ATTACHMENTS(tc))); CACHEDFRAME(tc) = Sfalse; { ptr xcp = FRAME(tc, 0); @@ -767,7 +764,7 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) seginfo* x_si = SegInfo((ptr_get_segment(c_p))); if (x_si -> old_space) { - relocate_code(c_p, x_si, p, p_sz); + relocate_code(c_p, x_si); FRAME(tc, 0) = (ptr)(((uptr)c_p) + co); } { @@ -797,7 +794,7 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) seginfo* x_si = SegInfo((ptr_get_segment(c_p))); if (x_si -> old_space) { - relocate_code(c_p, x_si, p, p_sz); + relocate_code(c_p, x_si); *(pp) = (ptr)(((uptr)c_p) + co); } { @@ -811,7 +808,7 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) pp += 1; if (mask & 1) { - relocate_pure(&(*(pp)), p, p_sz); + relocate_pure(&(*(pp))); } mask >>= 1; } @@ -825,12 +822,12 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) } else if (SEGMENT_IS_LOCAL(n_si, num)) { - relocate_pure(&(*((ENTRYNONCOMPACTLIVEMASKADDR(oldret)))), p, p_sz); + relocate_pure(&(*((ENTRYNONCOMPACTLIVEMASKADDR(oldret))))); num = ENTRYLIVEMASK(oldret); } else { - RECORD_REMOTE_RANGE(tgc, p, p_sz, n_si); + RECORD_REMOTE(n_si); num = S_G.zero_length_bignum; } { @@ -847,7 +844,7 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) pp += 1; if (mask & 1) { - relocate_pure(&(*(pp)), p, p_sz); + relocate_pure(&(*(pp))); } mask >>= 1; } @@ -867,33 +864,29 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) W(tc) = 0; X(tc) = 0; Y(tc) = 0; - relocate_pure(&(THREADNO(tc)), p, p_sz); - relocate_pure(&(CURRENTINPUT(tc)), p, p_sz); - relocate_pure(&(CURRENTOUTPUT(tc)), p, p_sz); - relocate_pure(&(CURRENTERROR(tc)), p, p_sz); - relocate_pure(&(SFD(tc)), p, p_sz); - relocate_pure(&(CURRENTMSO(tc)), p, p_sz); - relocate_pure(&(TARGETMACHINE(tc)), p, p_sz); - relocate_pure(&(FXLENGTHBV(tc)), p, p_sz); - relocate_pure(&(FXFIRSTBITSETBV(tc)), p, p_sz); - relocate_pure(&(NULLIMMUTABLEVECTOR(tc)), p, p_sz); - relocate_pure(&(NULLIMMUTABLEFXVECTOR(tc)), p, p_sz); - relocate_pure(&(NULLIMMUTABLEBYTEVECTOR(tc)), p, p_sz); - relocate_pure(&(NULLIMMUTABLESTRING(tc)), p, p_sz); - relocate_pure(&(COMPILEPROFILE(tc)), p, p_sz); - relocate_pure(&(SUBSETMODE(tc)), p, p_sz); - relocate_pure(&(DEFAULTRECORDEQUALPROCEDURE(tc)), p, p_sz); - relocate_pure(&(DEFAULTRECORDHASHPROCEDURE(tc)), p, p_sz); - relocate_pure(&(COMPRESSFORMAT(tc)), p, p_sz); - relocate_pure(&(COMPRESSLEVEL(tc)), p, p_sz); - relocate_pure(&(PARAMETERS(tc)), p, p_sz); + relocate_pure(&(THREADNO(tc))); + relocate_pure(&(CURRENTINPUT(tc))); + relocate_pure(&(CURRENTOUTPUT(tc))); + relocate_pure(&(CURRENTERROR(tc))); + relocate_pure(&(SFD(tc))); + relocate_pure(&(CURRENTMSO(tc))); + relocate_pure(&(TARGETMACHINE(tc))); + relocate_pure(&(FXLENGTHBV(tc))); + relocate_pure(&(FXFIRSTBITSETBV(tc))); + relocate_pure(&(COMPILEPROFILE(tc))); + relocate_pure(&(SUBSETMODE(tc))); + relocate_pure(&(DEFAULTRECORDEQUALPROCEDURE(tc))); + relocate_pure(&(DEFAULTRECORDHASHPROCEDURE(tc))); + relocate_pure(&(COMPRESSFORMAT(tc))); + relocate_pure(&(COMPRESSLEVEL(tc))); + relocate_pure(&(PARAMETERS(tc))); DSTBV(tc) = Sfalse; SRCBV(tc) = Sfalse; { INT i = 0; while (i < virtual_register_count) { - relocate_pure(&(VIRTREG(tc, i)), p, p_sz); + relocate_pure(&(VIRTREG(tc, i))); i += 1; } } @@ -928,27 +921,24 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) } else if (p_at_spc == space_weakpair) { - uptr p_sz = size_pair; - relocate_impure(&INITCDR(p), from_g, p, p_sz); + relocate_impure(&INITCDR(p), from_g); } else { - uptr p_sz = size_pair; - relocate_impure(&INITCAR(p), from_g, p, p_sz); - relocate_impure(&INITCDR(p), from_g, p, p_sz); + relocate_impure(&INITCAR(p), from_g); + relocate_impure(&INITCDR(p), from_g); } } } else if (t == type_closure) { ptr code = CLOSCODE(p); - relocate_pure(&code, p, size_closure((CODEFREE((CLOSCODE(p)))))); + relocate_pure(&code); if ((CODETYPE(code)) & (code_flag_continuation << code_flags_offset)) { - uptr p_sz = size_continuation; SETCLOSCODE(p, code); - relocate_pure(&CONTWINDERS(p), p, p_sz); - relocate_impure(&CONTATTACHMENTS(p), from_g, p, p_sz); + relocate_pure(&CONTWINDERS(p)); + relocate_impure(&CONTATTACHMENTS(p), from_g); if ((CONTLENGTH(p)) == scaled_shot_1_shot_flag) { } @@ -961,14 +951,14 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) { if (!(SEGMENT_IS_LOCAL(s_si, stk))) { - RECORD_REMOTE_RANGE(tgc, p, p_sz, s_si); + RECORD_REMOTE(s_si); } else { CONTSTACK(p) = copy_stack(tgc, CONTSTACK(p), &(CONTLENGTH(p)), CONTCLENGTH(p)); } } - relocate_pure(&CONTLINK(p), p, p_sz); + relocate_pure(&CONTLINK(p)); { ptr xcp = CONTRET(p); { @@ -979,7 +969,7 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) seginfo* x_si = SegInfo((ptr_get_segment(c_p))); if (x_si -> old_space) { - relocate_code(c_p, x_si, p, p_sz); + relocate_code(c_p, x_si); CONTRET(p) = (ptr)(((uptr)c_p) + co); } { @@ -1011,7 +1001,7 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) seginfo* x_si = SegInfo((ptr_get_segment(c_p))); if (x_si -> old_space) { - relocate_code(c_p, x_si, p, p_sz); + relocate_code(c_p, x_si); *(pp) = (ptr)(((uptr)c_p) + co); } { @@ -1025,7 +1015,7 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) pp += 1; if (mask & 1) { - relocate_pure(&(*(pp)), p, p_sz); + relocate_pure(&(*(pp))); } mask >>= 1; } @@ -1039,12 +1029,12 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) } else if (SEGMENT_IS_LOCAL(n_si, num)) { - relocate_pure(&(*((ENTRYNONCOMPACTLIVEMASKADDR(oldret)))), p, p_sz); + relocate_pure(&(*((ENTRYNONCOMPACTLIVEMASKADDR(oldret))))); num = ENTRYLIVEMASK(oldret); } else { - RECORD_REMOTE_RANGE(tgc, p, p_sz, n_si); + RECORD_REMOTE(n_si); num = S_G.zero_length_bignum; } { @@ -1061,7 +1051,7 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) pp += 1; if (mask & 1) { - relocate_pure(&(*(pp)), p, p_sz); + relocate_pure(&(*(pp))); } mask >>= 1; } @@ -1090,30 +1080,27 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) else { uptr len = CODEFREE(code); + if ((CODETYPE(code)) & (code_flag_mutable_closure << code_flags_offset)) { - uptr p_sz = size_closure(len); - if ((CODETYPE(code)) & (code_flag_mutable_closure << code_flags_offset)) + SETCLOSCODE(p, code); { - SETCLOSCODE(p, code); + uptr idx, p_len = len; + ptr *p_p = &CLOSIT(p, 0); + for (idx = 0; idx < p_len; idx++) { - uptr idx, p_len = len; - ptr *p_p = &CLOSIT(p, 0); - for (idx = 0; idx < p_len; idx++) - { - relocate_impure(&(p_p[idx]), from_g, p, p_sz); - } + relocate_impure(&(p_p[idx]), from_g); } } - else + } + else + { + SETCLOSCODE(p, code); { - SETCLOSCODE(p, code); + uptr idx, p_len = len; + ptr *p_p = &CLOSIT(p, 0); + for (idx = 0; idx < p_len; idx++) { - uptr idx, p_len = len; - ptr *p_p = &CLOSIT(p, 0); - for (idx = 0; idx < p_len; idx++) - { - relocate_pure(&(p_p[idx]), p, p_sz); - } + relocate_pure(&(p_p[idx])); } } } @@ -1121,8 +1108,7 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) } else if (t == type_symbol) { - uptr p_sz = size_symbol; - relocate_impure(&INITSYMVAL(p), from_g, p, p_sz); + relocate_impure(&INITSYMVAL(p), from_g); { ptr val = INITSYMVAL(p); { @@ -1134,17 +1120,17 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) ptr code = ((Sprocedurep(val)) ? (CLOSCODE(val)) : (SYMCODE(p))); - relocate_pure(&code, p, p_sz); + relocate_pure(&code); INITSYMCODE(p, code); } else { - RECORD_REMOTE_RANGE(tgc, p, p_sz, v_si); + RECORD_REMOTE(v_si); } - relocate_impure(&INITSYMPLIST(p), from_g, p, p_sz); - relocate_impure(&INITSYMNAME(p), from_g, p, p_sz); - relocate_impure(&INITSYMSPLIST(p), from_g, p, p_sz); - relocate_impure(&INITSYMHASH(p), from_g, p, p_sz); + relocate_impure(&INITSYMPLIST(p), from_g); + relocate_impure(&INITSYMNAME(p), from_g); + relocate_impure(&INITSYMSPLIST(p), from_g); + relocate_impure(&INITSYMHASH(p), from_g); } } } @@ -1156,23 +1142,24 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) S_error_abort("sweep: illegal type"); } } + FLUSH_REMOTE(tgc, p); } static void sweep_object_in_old(thread_gc *tgc, ptr p) { - ITYPE t = TYPEBITS(p); - if (t == type_typed_object) + FLUSH_REMOTE_BLOCK { - ptr tf = TYPEFIELD(p); - if (TYPEP(tf, mask_record, type_record)) + ITYPE t = TYPEBITS(p); + if (t == type_typed_object) { - relocate_pure(&RECORDINSTTYPE(p), p, size_record_inst((UNFIX((RECORDDESCSIZE(RECORDINSTTYPE(p))))))); + ptr tf = TYPEFIELD(p); + if (TYPEP(tf, mask_record, type_record)) { - ptr rtd = RECORDINSTTYPE(p); + relocate_pure(&RECORDINSTTYPE(p)); { - uptr len = UNFIX((RECORDDESCSIZE(rtd))); + ptr rtd = RECORDINSTTYPE(p); { - uptr p_sz = size_record_inst(len); + uptr len = UNFIX((RECORDDESCSIZE(rtd))); { ptr num = RECORDDESCPM(rtd); ptr* pp = &(RECORDINSTIT(p, 0)); @@ -1186,7 +1173,7 @@ static void sweep_object_in_old(thread_gc *tgc, ptr p) ptr* ppend = ((ptr*)(TO_VOIDP((((uptr)(TO_PTR(pp))) + len)))) - 1; while (pp < ppend) { - relocate_indirect((*(pp)), p, p_sz); + relocate_indirect((*(pp))); pp += 1; } } @@ -1197,7 +1184,7 @@ static void sweep_object_in_old(thread_gc *tgc, ptr p) { if (mask & 1) { - relocate_indirect((*(pp)), p, p_sz); + relocate_indirect((*(pp))); } mask >>= 1; pp += 1; @@ -1207,7 +1194,7 @@ static void sweep_object_in_old(thread_gc *tgc, ptr p) } else { - relocate_pure(&(RECORDDESCPM(rtd)), p, p_sz); + relocate_pure(&(RECORDDESCPM(rtd))); num = RECORDDESCPM(rtd); { iptr index = (BIGLEN(num)) - 1; @@ -1219,7 +1206,7 @@ static void sweep_object_in_old(thread_gc *tgc, ptr p) { if (mask & 1) { - relocate_indirect((*(pp)), p, p_sz); + relocate_indirect((*(pp))); } mask >>= 1; pp += 1; @@ -1240,100 +1227,88 @@ static void sweep_object_in_old(thread_gc *tgc, ptr p) } } } - } - else if (TYPEP(tf, mask_vector, type_vector)) - { - uptr len = Svector_length(p); + else if (TYPEP(tf, mask_vector, type_vector)) { - uptr p_sz = size_vector(len); + uptr len = Svector_length(p); { uptr idx, p_len = len; ptr *p_p = &INITVECTIT(p, 0); for (idx = 0; idx < p_len; idx++) { - relocate_indirect((p_p[idx]), p, p_sz); + relocate_indirect((p_p[idx])); } } } - } - else if (TYPEP(tf, mask_stencil_vector, type_stencil_vector)) - { - uptr len = Sstencil_vector_length(p); + else if (TYPEP(tf, mask_stencil_vector, type_stencil_vector)) { - uptr p_sz = size_stencil_vector(len); + uptr len = Sstencil_vector_length(p); { uptr idx, p_len = len; ptr *p_p = &INITSTENVECTIT(p, 0); for (idx = 0; idx < p_len; idx++) { - relocate_indirect((p_p[idx]), p, p_sz); + relocate_indirect((p_p[idx])); } } } - } - else if (TYPEP(tf, mask_string, type_string)) - { - } - else if (TYPEP(tf, mask_fxvector, type_fxvector)) - { - } - else if (TYPEP(tf, mask_bytevector, type_bytevector)) - { - } - else if ((iptr)tf == type_tlc) - { - uptr p_sz = size_tlc; - relocate_indirect(INITTLCHT(p), p, p_sz); - relocate_indirect(INITTLCKEYVAL(p), p, p_sz); - relocate_indirect(INITTLCNEXT(p), p, p_sz); - } - else if (TYPEP(tf, mask_box, type_box)) - { - uptr p_sz = size_box; - relocate_indirect(INITBOXREF(p), p, p_sz); - } - else if ((iptr)tf == type_ratnum) - { - uptr p_sz = size_ratnum; - relocate_pure(&RATNUM(p), p, p_sz); - relocate_pure(&RATDEN(p), p, p_sz); - } - else if ((iptr)tf == type_exactnum) - { - uptr p_sz = size_exactnum; - relocate_pure(&EXACTNUM_REAL_PART(p), p, p_sz); - relocate_pure(&EXACTNUM_IMAG_PART(p), p, p_sz); - } - else if ((iptr)tf == type_inexactnum) - { - } - else if (TYPEP(tf, mask_bignum, type_bignum)) - { - } - else if (TYPEP(tf, mask_port, type_port)) - { - uptr p_sz = size_port; - relocate_indirect(PORTHANDLER(p), p, p_sz); - if (((uptr)tf) & PORT_FLAG_OUTPUT) + else if (TYPEP(tf, mask_string, type_string)) { - relocate_indirect(PORTOBUF(p), p, p_sz); } - if (((uptr)tf) & PORT_FLAG_INPUT) + else if (TYPEP(tf, mask_fxvector, type_fxvector)) { - relocate_indirect(PORTIBUF(p), p, p_sz); } - relocate_indirect(PORTINFO(p), p, p_sz); - relocate_indirect(PORTNAME(p), p, p_sz); - } - else if (TYPEP(tf, mask_code, type_code)) - { - uptr len = CODELEN(p); + else if (TYPEP(tf, mask_flvector, type_flvector)) { - uptr p_sz = size_code(len); - relocate_pure(&CODENAME(p), p, p_sz); - relocate_pure(&CODEARITYMASK(p), p, p_sz); - relocate_pure(&CODEINFO(p), p, p_sz); - relocate_pure(&CODEPINFOS(p), p, p_sz); + } + else if (TYPEP(tf, mask_bytevector, type_bytevector)) + { + } + else if ((iptr)tf == type_tlc) + { + relocate_indirect(INITTLCHT(p)); + relocate_indirect(INITTLCKEYVAL(p)); + relocate_indirect(INITTLCNEXT(p)); + } + else if (TYPEP(tf, mask_box, type_box)) + { + relocate_indirect(INITBOXREF(p)); + } + else if ((iptr)tf == type_ratnum) + { + relocate_pure(&RATNUM(p)); + relocate_pure(&RATDEN(p)); + } + else if ((iptr)tf == type_exactnum) + { + relocate_pure(&EXACTNUM_REAL_PART(p)); + relocate_pure(&EXACTNUM_IMAG_PART(p)); + } + else if ((iptr)tf == type_inexactnum) + { + } + else if (TYPEP(tf, mask_bignum, type_bignum)) + { + } + else if (TYPEP(tf, mask_port, type_port)) + { + relocate_indirect(PORTHANDLER(p)); + if (((uptr)tf) & PORT_FLAG_OUTPUT) + { + relocate_indirect(PORTOBUF(p)); + } + if (((uptr)tf) & PORT_FLAG_INPUT) + { + relocate_indirect(PORTIBUF(p)); + } + relocate_indirect(PORTINFO(p)); + relocate_indirect(PORTNAME(p)); + } + else if (TYPEP(tf, mask_code, type_code)) + { + relocate_pure(&CODENAME(p)); + relocate_pure(&CODEARITYMASK(p)); + relocate_pure(&CODEINFO(p)); + relocate_pure(&CODEPINFOS(p)); { ptr t = CODERELOC(p); { @@ -1370,7 +1345,7 @@ static void sweep_object_in_old(thread_gc *tgc, ptr p) a = a + code_off; { ptr obj = S_get_code_obj(RELOC_TYPE(entry), oldco, a, item_off); - relocate_pure(&obj, p, p_sz); + relocate_pure(&obj); } } } @@ -1380,110 +1355,109 @@ static void sweep_object_in_old(thread_gc *tgc, ptr p) } } } - } - else if ((iptr)tf == type_thread) - { - uptr p_sz = size_thread; + else if ((iptr)tf == type_thread) { - ptr tc = (ptr)(THREADTC(p)); - if (tc != ((ptr)0)) { - STACKCACHE(tc) = Snil; - relocate_pure(&(CCHAIN(tc)), p, p_sz); - relocate_pure(&(STACKLINK(tc)), p, p_sz); - relocate_pure(&(WINDERS(tc)), p, p_sz); - relocate_pure(&(ATTACHMENTS(tc)), p, p_sz); + ptr tc = (ptr)(THREADTC(p)); + if (tc != ((ptr)0)) { - ptr xcp = FRAME(tc, 0); + STACKCACHE(tc) = Snil; + relocate_pure(&(CCHAIN(tc))); + relocate_pure(&(STACKLINK(tc))); + relocate_pure(&(WINDERS(tc))); + relocate_pure(&(ATTACHMENTS(tc))); { - iptr co = (ENTRYOFFSET(xcp)) + (((uptr)xcp) - ((uptr)(TO_PTR((ENTRYOFFSETADDR(xcp)))))); + ptr xcp = FRAME(tc, 0); { - ptr c_p = (ptr)(((uptr)xcp) - co); + iptr co = (ENTRYOFFSET(xcp)) + (((uptr)xcp) - ((uptr)(TO_PTR((ENTRYOFFSETADDR(xcp)))))); { - seginfo* x_si = SegInfo((ptr_get_segment(c_p))); - if (x_si -> old_space) - { - relocate_code(c_p, x_si, p, p_sz); - } + ptr c_p = (ptr)(((uptr)xcp) - co); { - uptr base = (uptr)(SCHEMESTACK(tc)); + seginfo* x_si = SegInfo((ptr_get_segment(c_p))); + if (x_si -> old_space) { - uptr fp = (uptr)(SFP(tc)); + relocate_code(c_p, x_si); + } + { + uptr base = (uptr)(SCHEMESTACK(tc)); { - uptr ret = (uptr)(FRAME(tc, 0)); - while (fp != base) + uptr fp = (uptr)(SFP(tc)); { - if (fp < base) - { - S_error_abort("sweep_stack(gc): malformed stack"); - } - fp = fp - (ENTRYFRAMESIZE(ret)); + uptr ret = (uptr)(FRAME(tc, 0)); + while (fp != base) { - ptr* pp = (ptr*)(TO_VOIDP(fp)); - iptr oldret = ret; - ret = (iptr)(*(pp)); + if (fp < base) { - ptr xcp = *(pp); + S_error_abort("sweep_stack(gc): malformed stack"); + } + fp = fp - (ENTRYFRAMESIZE(ret)); + { + ptr* pp = (ptr*)(TO_VOIDP(fp)); + iptr oldret = ret; + ret = (iptr)(*(pp)); { - iptr co = (ENTRYOFFSET(xcp)) + (((uptr)xcp) - ((uptr)(TO_PTR((ENTRYOFFSETADDR(xcp)))))); + ptr xcp = *(pp); { - ptr c_p = (ptr)(((uptr)xcp) - co); + iptr co = (ENTRYOFFSET(xcp)) + (((uptr)xcp) - ((uptr)(TO_PTR((ENTRYOFFSETADDR(xcp)))))); { - seginfo* x_si = SegInfo((ptr_get_segment(c_p))); - if (x_si -> old_space) - { - relocate_code(c_p, x_si, p, p_sz); - } + ptr c_p = (ptr)(((uptr)xcp) - co); { - ptr num = ENTRYLIVEMASK(oldret); - if (Sfixnump(num)) + seginfo* x_si = SegInfo((ptr_get_segment(c_p))); + if (x_si -> old_space) { + relocate_code(c_p, x_si); + } + { + ptr num = ENTRYLIVEMASK(oldret); + if (Sfixnump(num)) { - uptr mask = UNFIX(num); - while (mask != 0) { - pp += 1; - if (mask & 1) + uptr mask = UNFIX(num); + while (mask != 0) { - relocate_pure(&(*(pp)), p, p_sz); + pp += 1; + if (mask & 1) + { + relocate_pure(&(*(pp))); + } + mask >>= 1; } - mask >>= 1; } } - } - else - { - seginfo* n_si = SegInfo((ptr_get_segment(num))); - if (!(n_si -> old_space)) - { - } - else if (SEGMENT_IS_LOCAL(n_si, num)) - { - relocate_pure(&(*((ENTRYNONCOMPACTLIVEMASKADDR(oldret)))), p, p_sz); - num = ENTRYLIVEMASK(oldret); - } else { - RECORD_REMOTE_RANGE(tgc, p, p_sz, n_si); - num = S_G.zero_length_bignum; - } - { - iptr index = BIGLEN(num); - while (index != 0) + seginfo* n_si = SegInfo((ptr_get_segment(num))); + if (!(n_si -> old_space)) + { + } + else if (SEGMENT_IS_LOCAL(n_si, num)) + { + relocate_pure(&(*((ENTRYNONCOMPACTLIVEMASKADDR(oldret))))); + num = ENTRYLIVEMASK(oldret); + } + else + { + RECORD_REMOTE(n_si); + num = S_G.zero_length_bignum; + } { - index -= 1; + iptr index = BIGLEN(num); + while (index != 0) { - INT bits = bigit_bits; - bigit mask = BIGIT(num, index); - while (bits > 0) + index -= 1; { - bits -= 1; - pp += 1; - if (mask & 1) + INT bits = bigit_bits; + bigit mask = BIGIT(num, index); + while (bits > 0) { - relocate_pure(&(*(pp)), p, p_sz); + bits -= 1; + pp += 1; + if (mask & 1) + { + relocate_pure(&(*(pp))); + } + mask >>= 1; } - mask >>= 1; } } } @@ -1495,33 +1469,29 @@ static void sweep_object_in_old(thread_gc *tgc, ptr p) } } } - } - relocate_pure(&(THREADNO(tc)), p, p_sz); - relocate_pure(&(CURRENTINPUT(tc)), p, p_sz); - relocate_pure(&(CURRENTOUTPUT(tc)), p, p_sz); - relocate_pure(&(CURRENTERROR(tc)), p, p_sz); - relocate_pure(&(SFD(tc)), p, p_sz); - relocate_pure(&(CURRENTMSO(tc)), p, p_sz); - relocate_pure(&(TARGETMACHINE(tc)), p, p_sz); - relocate_pure(&(FXLENGTHBV(tc)), p, p_sz); - relocate_pure(&(FXFIRSTBITSETBV(tc)), p, p_sz); - relocate_pure(&(NULLIMMUTABLEVECTOR(tc)), p, p_sz); - relocate_pure(&(NULLIMMUTABLEFXVECTOR(tc)), p, p_sz); - relocate_pure(&(NULLIMMUTABLEBYTEVECTOR(tc)), p, p_sz); - relocate_pure(&(NULLIMMUTABLESTRING(tc)), p, p_sz); - relocate_pure(&(COMPILEPROFILE(tc)), p, p_sz); - relocate_pure(&(SUBSETMODE(tc)), p, p_sz); - relocate_pure(&(DEFAULTRECORDEQUALPROCEDURE(tc)), p, p_sz); - relocate_pure(&(DEFAULTRECORDHASHPROCEDURE(tc)), p, p_sz); - relocate_pure(&(COMPRESSFORMAT(tc)), p, p_sz); - relocate_pure(&(COMPRESSLEVEL(tc)), p, p_sz); - relocate_pure(&(PARAMETERS(tc)), p, p_sz); - { - INT i = 0; - while (i < virtual_register_count) + relocate_pure(&(THREADNO(tc))); + relocate_pure(&(CURRENTINPUT(tc))); + relocate_pure(&(CURRENTOUTPUT(tc))); + relocate_pure(&(CURRENTERROR(tc))); + relocate_pure(&(SFD(tc))); + relocate_pure(&(CURRENTMSO(tc))); + relocate_pure(&(TARGETMACHINE(tc))); + relocate_pure(&(FXLENGTHBV(tc))); + relocate_pure(&(FXFIRSTBITSETBV(tc))); + relocate_pure(&(COMPILEPROFILE(tc))); + relocate_pure(&(SUBSETMODE(tc))); + relocate_pure(&(DEFAULTRECORDEQUALPROCEDURE(tc))); + relocate_pure(&(DEFAULTRECORDHASHPROCEDURE(tc))); + relocate_pure(&(COMPRESSFORMAT(tc))); + relocate_pure(&(COMPRESSLEVEL(tc))); + relocate_pure(&(PARAMETERS(tc))); { - relocate_pure(&(VIRTREG(tc, i)), p, p_sz); - i += 1; + INT i = 0; + while (i < virtual_register_count) + { + relocate_pure(&(VIRTREG(tc, i))); + i += 1; + } } } } @@ -1533,147 +1503,144 @@ static void sweep_object_in_old(thread_gc *tgc, ptr p) } } } - } - else if ((iptr)tf == type_rtd_counts) - { - } - else if ((iptr)tf == type_phantom) - { - } - else - { - S_error_abort("sweep-in-old: illegal typed object type"); - } - } - else if (t == type_pair) - { - { - ISPC p_at_spc = SPACE(p); - if (p_at_spc == space_ephemeron) + else if ((iptr)tf == type_rtd_counts) { } - else if (p_at_spc == space_weakpair) + else if ((iptr)tf == type_phantom) { - uptr p_sz = size_pair; - relocate_indirect(INITCDR(p), p, p_sz); } else { - uptr p_sz = size_pair; - relocate_indirect(INITCAR(p), p, p_sz); - relocate_indirect(INITCDR(p), p, p_sz); + S_error_abort("sweep-in-old: illegal typed object type"); } } - } - else if (t == type_closure) - { - ptr code = CLOSCODE(p); - relocate_pure(&code, p, size_closure((CODEFREE((CLOSCODE(p)))))); - if ((CODETYPE(code)) & (code_flag_continuation << code_flags_offset)) + else if (t == type_pair) { - uptr p_sz = size_continuation; - SETCLOSCODE(p, code); - relocate_pure(&CONTWINDERS(p), p, p_sz); - relocate_indirect(CONTATTACHMENTS(p), p, p_sz); - if ((CONTLENGTH(p)) == scaled_shot_1_shot_flag) { + ISPC p_at_spc = SPACE(p); + if (p_at_spc == space_ephemeron) + { + } + else if (p_at_spc == space_weakpair) + { + relocate_indirect(INITCDR(p)); + } + else + { + relocate_indirect(INITCAR(p)); + relocate_indirect(INITCDR(p)); + } } - else + } + else if (t == type_closure) + { + ptr code = CLOSCODE(p); + relocate_pure(&code); + if ((CODETYPE(code)) & (code_flag_continuation << code_flags_offset)) { - relocate_pure(&CONTLINK(p), p, p_sz); + SETCLOSCODE(p, code); + relocate_pure(&CONTWINDERS(p)); + relocate_indirect(CONTATTACHMENTS(p)); + if ((CONTLENGTH(p)) == scaled_shot_1_shot_flag) { - ptr xcp = CONTRET(p); + } + else + { + relocate_pure(&CONTLINK(p)); { - iptr co = (ENTRYOFFSET(xcp)) + (((uptr)xcp) - ((uptr)(TO_PTR((ENTRYOFFSETADDR(xcp)))))); + ptr xcp = CONTRET(p); { - ptr c_p = (ptr)(((uptr)xcp) - co); + iptr co = (ENTRYOFFSET(xcp)) + (((uptr)xcp) - ((uptr)(TO_PTR((ENTRYOFFSETADDR(xcp)))))); { - seginfo* x_si = SegInfo((ptr_get_segment(c_p))); - if (x_si -> old_space) - { - relocate_code(c_p, x_si, p, p_sz); - } + ptr c_p = (ptr)(((uptr)xcp) - co); { - uptr stack = (uptr)(CONTSTACK(p)); + seginfo* x_si = SegInfo((ptr_get_segment(c_p))); + if (x_si -> old_space) + { + relocate_code(c_p, x_si); + } { - uptr base = stack; + uptr stack = (uptr)(CONTSTACK(p)); { - uptr fp = stack + (CONTCLENGTH(p)); + uptr base = stack; { - uptr ret = (uptr)(CONTRET(p)); - while (fp != base) + uptr fp = stack + (CONTCLENGTH(p)); { - if (fp < base) - { - S_error_abort("sweep_stack(gc): malformed stack"); - } - fp = fp - (ENTRYFRAMESIZE(ret)); + uptr ret = (uptr)(CONTRET(p)); + while (fp != base) { - ptr* pp = (ptr*)(TO_VOIDP(fp)); - iptr oldret = ret; - ret = (iptr)(*(pp)); + if (fp < base) { - ptr xcp = *(pp); + S_error_abort("sweep_stack(gc): malformed stack"); + } + fp = fp - (ENTRYFRAMESIZE(ret)); + { + ptr* pp = (ptr*)(TO_VOIDP(fp)); + iptr oldret = ret; + ret = (iptr)(*(pp)); { - iptr co = (ENTRYOFFSET(xcp)) + (((uptr)xcp) - ((uptr)(TO_PTR((ENTRYOFFSETADDR(xcp)))))); + ptr xcp = *(pp); { - ptr c_p = (ptr)(((uptr)xcp) - co); + iptr co = (ENTRYOFFSET(xcp)) + (((uptr)xcp) - ((uptr)(TO_PTR((ENTRYOFFSETADDR(xcp)))))); { - seginfo* x_si = SegInfo((ptr_get_segment(c_p))); - if (x_si -> old_space) - { - relocate_code(c_p, x_si, p, p_sz); - } + ptr c_p = (ptr)(((uptr)xcp) - co); { - ptr num = ENTRYLIVEMASK(oldret); - if (Sfixnump(num)) + seginfo* x_si = SegInfo((ptr_get_segment(c_p))); + if (x_si -> old_space) { + relocate_code(c_p, x_si); + } + { + ptr num = ENTRYLIVEMASK(oldret); + if (Sfixnump(num)) { - uptr mask = UNFIX(num); - while (mask != 0) { - pp += 1; - if (mask & 1) + uptr mask = UNFIX(num); + while (mask != 0) { - relocate_pure(&(*(pp)), p, p_sz); + pp += 1; + if (mask & 1) + { + relocate_pure(&(*(pp))); + } + mask >>= 1; } - mask >>= 1; } } - } - else - { - seginfo* n_si = SegInfo((ptr_get_segment(num))); - if (!(n_si -> old_space)) - { - } - else if (SEGMENT_IS_LOCAL(n_si, num)) - { - relocate_pure(&(*((ENTRYNONCOMPACTLIVEMASKADDR(oldret)))), p, p_sz); - num = ENTRYLIVEMASK(oldret); - } else { - RECORD_REMOTE_RANGE(tgc, p, p_sz, n_si); - num = S_G.zero_length_bignum; - } - { - iptr index = BIGLEN(num); - while (index != 0) + seginfo* n_si = SegInfo((ptr_get_segment(num))); + if (!(n_si -> old_space)) + { + } + else if (SEGMENT_IS_LOCAL(n_si, num)) + { + relocate_pure(&(*((ENTRYNONCOMPACTLIVEMASKADDR(oldret))))); + num = ENTRYLIVEMASK(oldret); + } + else { - index -= 1; + RECORD_REMOTE(n_si); + num = S_G.zero_length_bignum; + } + { + iptr index = BIGLEN(num); + while (index != 0) { - INT bits = bigit_bits; - bigit mask = BIGIT(num, index); - while (bits > 0) + index -= 1; { - bits -= 1; - pp += 1; - if (mask & 1) + INT bits = bigit_bits; + bigit mask = BIGIT(num, index); + while (bits > 0) { - relocate_pure(&(*(pp)), p, p_sz); + bits -= 1; + pp += 1; + if (mask & 1) + { + relocate_pure(&(*(pp))); + } + mask >>= 1; } - mask >>= 1; } } } @@ -1695,12 +1662,9 @@ static void sweep_object_in_old(thread_gc *tgc, ptr p) } } } - } - else - { - uptr len = CODEFREE(code); + else { - uptr p_sz = size_closure(len); + uptr len = CODEFREE(code); if ((CODETYPE(code)) & (code_flag_mutable_closure << code_flags_offset)) { SETCLOSCODE(p, code); @@ -1709,7 +1673,7 @@ static void sweep_object_in_old(thread_gc *tgc, ptr p) ptr *p_p = &CLOSIT(p, 0); for (idx = 0; idx < p_len; idx++) { - relocate_indirect((p_p[idx]), p, p_sz); + relocate_indirect((p_p[idx])); } } } @@ -1721,43 +1685,44 @@ static void sweep_object_in_old(thread_gc *tgc, ptr p) ptr *p_p = &CLOSIT(p, 0); for (idx = 0; idx < p_len; idx++) { - relocate_pure(&(p_p[idx]), p, p_sz); + relocate_pure(&(p_p[idx])); } } } } } - } - else if (t == type_symbol) - { - uptr p_sz = size_symbol; - relocate_indirect(INITSYMVAL(p), p, p_sz); + else if (t == type_symbol) { - ptr val = INITSYMVAL(p); + relocate_indirect(INITSYMVAL(p)); { - ptr code = ((Sprocedurep(val)) - ? (CLOSCODE(val)) - : (SYMCODE(p))); - relocate_pure(&code, p, p_sz); - INITSYMCODE(p, code); - relocate_indirect(INITSYMPLIST(p), p, p_sz); - relocate_indirect(INITSYMNAME(p), p, p_sz); - relocate_indirect(INITSYMSPLIST(p), p, p_sz); - relocate_indirect(INITSYMHASH(p), p, p_sz); + ptr val = INITSYMVAL(p); + { + ptr code = ((Sprocedurep(val)) + ? (CLOSCODE(val)) + : (SYMCODE(p))); + relocate_pure(&code); + INITSYMCODE(p, code); + relocate_indirect(INITSYMPLIST(p)); + relocate_indirect(INITSYMNAME(p)); + relocate_indirect(INITSYMSPLIST(p)); + relocate_indirect(INITSYMHASH(p)); + } } } + else if (t == type_flonum) + { + } + else + { + S_error_abort("sweep-in-old: illegal type"); + } } - else if (t == type_flonum) - { - } - else - { - S_error_abort("sweep-in-old: illegal type"); - } + ASSERT_EMPTY_FLUSH_REMOTE(); } static IGEN sweep_dirty_object(thread_gc *tgc, ptr p, IGEN youngest) { + FLUSH_REMOTE_BLOCK { ITYPE t = TYPEBITS(p); if (t == type_typed_object) @@ -1768,55 +1733,49 @@ static IGEN sweep_dirty_object(thread_gc *tgc, ptr p, IGEN youngest) { ptr rtd = RECORDINSTTYPE(p); { - uptr len = UNFIX((RECORDDESCSIZE(rtd))); + ptr num = RECORDDESCMPM(rtd); + ptr* pp = &(RECORDINSTIT(p, 0)); + if (Sfixnump(num)) { - uptr p_sz = size_record_inst(len); { - ptr num = RECORDDESCMPM(rtd); - ptr* pp = &(RECORDINSTIT(p, 0)); - if (Sfixnump(num)) + uptr mask = ((uptr)(UNFIX(num))) >> 1; + while (mask != 0) { + if (mask & 1) { - uptr mask = ((uptr)(UNFIX(num))) >> 1; - while (mask != 0) - { - if (mask & 1) - { - relocate_dirty(&(*(pp)), youngest, p, p_sz); - } - mask >>= 1; - pp += 1; - } + relocate_dirty(&(*(pp)), youngest); } + mask >>= 1; + pp += 1; } - else + } + } + else + { + { + iptr index = (BIGLEN(num)) - 1; + bigit mask = (BIGIT(num, index)) >> 1; + INT bits = bigit_bits - 1; + while (1) { + do { - iptr index = (BIGLEN(num)) - 1; - bigit mask = (BIGIT(num, index)) >> 1; - INT bits = bigit_bits - 1; - while (1) + if (mask & 1) { - do - { - if (mask & 1) - { - relocate_dirty(&(*(pp)), youngest, p, p_sz); - } - mask >>= 1; - pp += 1; - bits -= 1; - } - while (bits > 0); - if (index == 0) - { - break; - } - index -= 1; - mask = BIGIT(num, index); - bits = bigit_bits; + relocate_dirty(&(*(pp)), youngest); } + mask >>= 1; + pp += 1; + bits -= 1; + } + while (bits > 0); + if (index == 0) + { + break; } + index -= 1; + mask = BIGIT(num, index); + bits = bigit_bits; } } } @@ -1827,14 +1786,11 @@ static IGEN sweep_dirty_object(thread_gc *tgc, ptr p, IGEN youngest) { uptr len = Svector_length(p); { - uptr p_sz = size_vector(len); + uptr idx, p_len = len; + ptr *p_p = &INITVECTIT(p, 0); + for (idx = 0; idx < p_len; idx++) { - uptr idx, p_len = len; - ptr *p_p = &INITVECTIT(p, 0); - for (idx = 0; idx < p_len; idx++) - { - relocate_dirty(&(p_p[idx]), youngest, p, p_sz); - } + relocate_dirty(&(p_p[idx]), youngest); } } } @@ -1842,14 +1798,11 @@ static IGEN sweep_dirty_object(thread_gc *tgc, ptr p, IGEN youngest) { uptr len = Sstencil_vector_length(p); { - uptr p_sz = size_stencil_vector(len); + uptr idx, p_len = len; + ptr *p_p = &INITSTENVECTIT(p, 0); + for (idx = 0; idx < p_len; idx++) { - uptr idx, p_len = len; - ptr *p_p = &INITSTENVECTIT(p, 0); - for (idx = 0; idx < p_len; idx++) - { - relocate_dirty(&(p_p[idx]), youngest, p, p_sz); - } + relocate_dirty(&(p_p[idx]), youngest); } } } @@ -1859,20 +1812,21 @@ static IGEN sweep_dirty_object(thread_gc *tgc, ptr p, IGEN youngest) else if (TYPEP(tf, mask_fxvector, type_fxvector)) { } + else if (TYPEP(tf, mask_flvector, type_flvector)) + { + } else if (TYPEP(tf, mask_bytevector, type_bytevector)) { } else if ((iptr)tf == type_tlc) { - uptr p_sz = size_tlc; - relocate_dirty(&INITTLCHT(p), youngest, p, p_sz); - relocate_dirty(&INITTLCKEYVAL(p), youngest, p, p_sz); - relocate_dirty(&INITTLCNEXT(p), youngest, p, p_sz); + relocate_dirty(&INITTLCHT(p), youngest); + relocate_dirty(&INITTLCKEYVAL(p), youngest); + relocate_dirty(&INITTLCNEXT(p), youngest); } else if (TYPEP(tf, mask_box, type_box)) { - uptr p_sz = size_box; - relocate_dirty(&INITBOXREF(p), youngest, p, p_sz); + relocate_dirty(&INITBOXREF(p), youngest); } else if ((iptr)tf == type_ratnum) { @@ -1888,22 +1842,21 @@ static IGEN sweep_dirty_object(thread_gc *tgc, ptr p, IGEN youngest) } else if (TYPEP(tf, mask_port, type_port)) { - uptr p_sz = size_port; - relocate_dirty(&PORTHANDLER(p), youngest, p, p_sz); + relocate_dirty(&PORTHANDLER(p), youngest); if (((uptr)tf) & PORT_FLAG_OUTPUT) { iptr n = ((iptr)(PORTOLAST(p))) - ((iptr)(PORTOBUF(p))); - relocate_dirty(&PORTOBUF(p), youngest, p, p_sz); + relocate_dirty(&PORTOBUF(p), youngest); PORTOLAST(p) = (ptr)(((iptr)(PORTOBUF(p))) + n); } if (((uptr)tf) & PORT_FLAG_INPUT) { iptr n = ((iptr)(PORTILAST(p))) - ((iptr)(PORTIBUF(p))); - relocate_dirty(&PORTIBUF(p), youngest, p, p_sz); + relocate_dirty(&PORTIBUF(p), youngest); PORTILAST(p) = (ptr)(((iptr)(PORTIBUF(p))) + n); } - relocate_dirty(&PORTINFO(p), youngest, p, p_sz); - relocate_dirty(&PORTNAME(p), youngest, p, p_sz); + relocate_dirty(&PORTINFO(p), youngest); + relocate_dirty(&PORTNAME(p), youngest); } else if (TYPEP(tf, mask_code, type_code)) { @@ -1932,14 +1885,12 @@ static IGEN sweep_dirty_object(thread_gc *tgc, ptr p, IGEN youngest) } else if (p_at_spc == space_weakpair) { - uptr p_sz = size_pair; - relocate_dirty(&INITCDR(p), youngest, p, p_sz); + relocate_dirty(&INITCDR(p), youngest); } else { - uptr p_sz = size_pair; - relocate_dirty(&INITCAR(p), youngest, p, p_sz); - relocate_dirty(&INITCDR(p), youngest, p, p_sz); + relocate_dirty(&INITCAR(p), youngest); + relocate_dirty(&INITCDR(p), youngest); } } } @@ -1948,17 +1899,14 @@ static IGEN sweep_dirty_object(thread_gc *tgc, ptr p, IGEN youngest) ptr code = CLOSCODE(p); { uptr len = CODEFREE(code); + if ((CODETYPE(code)) & (code_flag_mutable_closure << code_flags_offset)) { - uptr p_sz = size_closure(len); - if ((CODETYPE(code)) & (code_flag_mutable_closure << code_flags_offset)) { + uptr idx, p_len = len; + ptr *p_p = &CLOSIT(p, 0); + for (idx = 0; idx < p_len; idx++) { - uptr idx, p_len = len; - ptr *p_p = &CLOSIT(p, 0); - for (idx = 0; idx < p_len; idx++) - { - relocate_dirty(&(p_p[idx]), youngest, p, p_sz); - } + relocate_dirty(&(p_p[idx]), youngest); } } } @@ -1966,8 +1914,7 @@ static IGEN sweep_dirty_object(thread_gc *tgc, ptr p, IGEN youngest) } else if (t == type_symbol) { - uptr p_sz = size_symbol; - relocate_dirty(&INITSYMVAL(p), youngest, p, p_sz); + relocate_dirty(&INITSYMVAL(p), youngest); { ptr val = INITSYMVAL(p); { @@ -1979,17 +1926,17 @@ static IGEN sweep_dirty_object(thread_gc *tgc, ptr p, IGEN youngest) ptr code = ((Sprocedurep(val)) ? (CLOSCODE(val)) : (SYMCODE(p))); - relocate_dirty(&code, youngest, p, p_sz); + relocate_dirty(&code, youngest); INITSYMCODE(p, code); } else { - RECORD_REMOTE_RANGE(tgc, p, p_sz, v_si); + RECORD_REMOTE(v_si); } - relocate_dirty(&INITSYMPLIST(p), youngest, p, p_sz); - relocate_dirty(&INITSYMNAME(p), youngest, p, p_sz); - relocate_dirty(&INITSYMSPLIST(p), youngest, p, p_sz); - relocate_dirty(&INITSYMHASH(p), youngest, p, p_sz); + relocate_dirty(&INITSYMPLIST(p), youngest); + relocate_dirty(&INITSYMNAME(p), youngest); + relocate_dirty(&INITSYMSPLIST(p), youngest); + relocate_dirty(&INITSYMHASH(p), youngest); } } } @@ -2001,89 +1948,88 @@ static IGEN sweep_dirty_object(thread_gc *tgc, ptr p, IGEN youngest) S_error_abort("sweep: illegal type"); } } + FLUSH_REMOTE(tgc, p); return youngest; } static void sweep_record(thread_gc *tgc, ptr p, IGEN from_g) { + FLUSH_REMOTE_BLOCK { - relocate_pure(&RECORDINSTTYPE(p), p, size_record_inst((UNFIX((RECORDDESCSIZE(RECORDINSTTYPE(p))))))); + relocate_pure(&RECORDINSTTYPE(p)); { ptr rtd = RECORDINSTTYPE(p); { uptr len = UNFIX((RECORDDESCSIZE(rtd))); { - uptr p_sz = size_record_inst(len); + ptr num = RECORDDESCPM(rtd); + ptr* pp = &(RECORDINSTIT(p, 0)); + if (Sfixnump(num)) { - ptr num = RECORDDESCPM(rtd); - ptr* pp = &(RECORDINSTIT(p, 0)); - if (Sfixnump(num)) { + uptr mask = ((uptr)(UNFIX(num))) >> 1; + if (mask == (((uptr)-1) >> 1)) { - uptr mask = ((uptr)(UNFIX(num))) >> 1; - if (mask == (((uptr)-1) >> 1)) { + ptr* ppend = ((ptr*)(TO_VOIDP((((uptr)(TO_PTR(pp))) + len)))) - 1; + while (pp < ppend) { - ptr* ppend = ((ptr*)(TO_VOIDP((((uptr)(TO_PTR(pp))) + len)))) - 1; - while (pp < ppend) - { - relocate_impure(&(*(pp)), from_g, p, p_sz); - pp += 1; - } + relocate_impure(&(*(pp)), from_g); + pp += 1; } } - else + } + else + { + while (mask != 0) { - while (mask != 0) + if (mask & 1) { - if (mask & 1) - { - relocate_impure(&(*(pp)), from_g, p, p_sz); - } - mask >>= 1; - pp += 1; + relocate_impure(&(*(pp)), from_g); } + mask >>= 1; + pp += 1; } } } + } + else + { + seginfo* pm_si = SegInfo((ptr_get_segment(num))); + if ((!(pm_si -> old_space)) || (SEGMENT_IS_LOCAL(pm_si, num))) + { + relocate_pure(&(RECORDDESCPM(rtd))); + num = RECORDDESCPM(rtd); + } else { - seginfo* pm_si = SegInfo((ptr_get_segment(num))); - if ((!(pm_si -> old_space)) || (SEGMENT_IS_LOCAL(pm_si, num))) - { - relocate_pure(&(RECORDDESCPM(rtd)), p, p_sz); - num = RECORDDESCPM(rtd); - } - else - { - RECORD_REMOTE_RANGE(tgc, p, p_sz, pm_si); - num = S_G.zero_length_bignum; - } + RECORD_REMOTE(pm_si); + num = S_G.zero_length_bignum; + } + { + iptr index = (BIGLEN(num)) - 1; + bigit mask = (BIGIT(num, index)) >> 1; + INT bits = bigit_bits - 1; + while (1) { - iptr index = (BIGLEN(num)) - 1; - bigit mask = (BIGIT(num, index)) >> 1; - INT bits = bigit_bits - 1; - while (1) + do { - do + if (mask & 1) { - if (mask & 1) - { - relocate_impure(&(*(pp)), from_g, p, p_sz); - } - mask >>= 1; - pp += 1; - bits -= 1; + relocate_impure(&(*(pp)), from_g); } - while (bits > 0); - if (index == 0) - { - break; - } - index -= 1; - mask = BIGIT(num, index); - bits = bigit_bits; + mask >>= 1; + pp += 1; + bits -= 1; + } + while (bits > 0); + if (index == 0) + { + break; } + index -= 1; + mask = BIGIT(num, index); + bits = bigit_bits; } } } @@ -2091,78 +2037,75 @@ static void sweep_record(thread_gc *tgc, ptr p, IGEN from_g) } } } + FLUSH_REMOTE(tgc, p); } static IGEN sweep_dirty_record(thread_gc *tgc, ptr p, IGEN youngest) { + FLUSH_REMOTE_BLOCK { { ptr rtd = RECORDINSTTYPE(p); { - uptr len = UNFIX((RECORDDESCSIZE(rtd))); + ptr num = RECORDDESCMPM(rtd); + ptr* pp = &(RECORDINSTIT(p, 0)); + if (Sfixnump(num)) { - uptr p_sz = size_record_inst(len); { - ptr num = RECORDDESCMPM(rtd); - ptr* pp = &(RECORDINSTIT(p, 0)); - if (Sfixnump(num)) + uptr mask = ((uptr)(UNFIX(num))) >> 1; + while (mask != 0) { + if (mask & 1) { - uptr mask = ((uptr)(UNFIX(num))) >> 1; - while (mask != 0) - { - if (mask & 1) - { - relocate_dirty(&(*(pp)), youngest, p, p_sz); - } - mask >>= 1; - pp += 1; - } + relocate_dirty(&(*(pp)), youngest); } + mask >>= 1; + pp += 1; } - else + } + } + else + { + { + iptr index = (BIGLEN(num)) - 1; + bigit mask = (BIGIT(num, index)) >> 1; + INT bits = bigit_bits - 1; + while (1) { + do { - iptr index = (BIGLEN(num)) - 1; - bigit mask = (BIGIT(num, index)) >> 1; - INT bits = bigit_bits - 1; - while (1) + if (mask & 1) { - do - { - if (mask & 1) - { - relocate_dirty(&(*(pp)), youngest, p, p_sz); - } - mask >>= 1; - pp += 1; - bits -= 1; - } - while (bits > 0); - if (index == 0) - { - break; - } - index -= 1; - mask = BIGIT(num, index); - bits = bigit_bits; + relocate_dirty(&(*(pp)), youngest); } + mask >>= 1; + pp += 1; + bits -= 1; + } + while (bits > 0); + if (index == 0) + { + break; } + index -= 1; + mask = BIGIT(num, index); + bits = bigit_bits; } } } } } } + FLUSH_REMOTE(tgc, p); return youngest; } static void sweep_symbol(thread_gc *tgc, ptr p, IGEN from_g) { + FLUSH_REMOTE_BLOCK { { - uptr p_sz = size_symbol; - relocate_impure(&INITSYMVAL(p), from_g, p, p_sz); + relocate_impure(&INITSYMVAL(p), from_g); { ptr val = INITSYMVAL(p); { @@ -2174,29 +2117,30 @@ static void sweep_symbol(thread_gc *tgc, ptr p, IGEN from_g) ptr code = ((Sprocedurep(val)) ? (CLOSCODE(val)) : (SYMCODE(p))); - relocate_pure(&code, p, p_sz); + relocate_pure(&code); INITSYMCODE(p, code); } else { - RECORD_REMOTE_RANGE(tgc, p, p_sz, v_si); + RECORD_REMOTE(v_si); } - relocate_impure(&INITSYMPLIST(p), from_g, p, p_sz); - relocate_impure(&INITSYMNAME(p), from_g, p, p_sz); - relocate_impure(&INITSYMSPLIST(p), from_g, p, p_sz); - relocate_impure(&INITSYMHASH(p), from_g, p, p_sz); + relocate_impure(&INITSYMPLIST(p), from_g); + relocate_impure(&INITSYMNAME(p), from_g); + relocate_impure(&INITSYMSPLIST(p), from_g); + relocate_impure(&INITSYMHASH(p), from_g); } } } } + FLUSH_REMOTE(tgc, p); } static IGEN sweep_dirty_symbol(thread_gc *tgc, ptr p, IGEN youngest) { + FLUSH_REMOTE_BLOCK { { - uptr p_sz = size_symbol; - relocate_dirty(&INITSYMVAL(p), youngest, p, p_sz); + relocate_dirty(&INITSYMVAL(p), youngest); { ptr val = INITSYMVAL(p); { @@ -2208,28 +2152,29 @@ static IGEN sweep_dirty_symbol(thread_gc *tgc, ptr p, IGEN youngest) ptr code = ((Sprocedurep(val)) ? (CLOSCODE(val)) : (SYMCODE(p))); - relocate_dirty(&code, youngest, p, p_sz); + relocate_dirty(&code, youngest); INITSYMCODE(p, code); } else { - RECORD_REMOTE_RANGE(tgc, p, p_sz, v_si); + RECORD_REMOTE(v_si); } - relocate_dirty(&INITSYMPLIST(p), youngest, p, p_sz); - relocate_dirty(&INITSYMNAME(p), youngest, p, p_sz); - relocate_dirty(&INITSYMSPLIST(p), youngest, p, p_sz); - relocate_dirty(&INITSYMHASH(p), youngest, p, p_sz); + relocate_dirty(&INITSYMPLIST(p), youngest); + relocate_dirty(&INITSYMNAME(p), youngest); + relocate_dirty(&INITSYMSPLIST(p), youngest); + relocate_dirty(&INITSYMHASH(p), youngest); } } } } + FLUSH_REMOTE(tgc, p); return youngest; } static void sweep_thread(thread_gc *tgc, ptr p) { + FLUSH_REMOTE_BLOCK { - uptr p_sz = size_thread; { ptr tc = (ptr)(THREADTC(p)); if (tc != ((ptr)0)) @@ -2247,10 +2192,10 @@ static void sweep_thread(thread_gc *tgc, ptr p) } } STACKCACHE(tc) = Snil; - relocate_pure(&(CCHAIN(tc)), p, p_sz); - relocate_pure(&(STACKLINK(tc)), p, p_sz); - relocate_pure(&(WINDERS(tc)), p, p_sz); - relocate_pure(&(ATTACHMENTS(tc)), p, p_sz); + relocate_pure(&(CCHAIN(tc))); + relocate_pure(&(STACKLINK(tc))); + relocate_pure(&(WINDERS(tc))); + relocate_pure(&(ATTACHMENTS(tc))); CACHEDFRAME(tc) = Sfalse; { ptr xcp = FRAME(tc, 0); @@ -2262,7 +2207,7 @@ static void sweep_thread(thread_gc *tgc, ptr p) seginfo* x_si = SegInfo((ptr_get_segment(c_p))); if (x_si -> old_space) { - relocate_code(c_p, x_si, p, p_sz); + relocate_code(c_p, x_si); FRAME(tc, 0) = (ptr)(((uptr)c_p) + co); } { @@ -2292,7 +2237,7 @@ static void sweep_thread(thread_gc *tgc, ptr p) seginfo* x_si = SegInfo((ptr_get_segment(c_p))); if (x_si -> old_space) { - relocate_code(c_p, x_si, p, p_sz); + relocate_code(c_p, x_si); *(pp) = (ptr)(((uptr)c_p) + co); } { @@ -2306,7 +2251,7 @@ static void sweep_thread(thread_gc *tgc, ptr p) pp += 1; if (mask & 1) { - relocate_pure(&(*(pp)), p, p_sz); + relocate_pure(&(*(pp))); } mask >>= 1; } @@ -2320,12 +2265,12 @@ static void sweep_thread(thread_gc *tgc, ptr p) } else if (SEGMENT_IS_LOCAL(n_si, num)) { - relocate_pure(&(*((ENTRYNONCOMPACTLIVEMASKADDR(oldret)))), p, p_sz); + relocate_pure(&(*((ENTRYNONCOMPACTLIVEMASKADDR(oldret))))); num = ENTRYLIVEMASK(oldret); } else { - RECORD_REMOTE_RANGE(tgc, p, p_sz, n_si); + RECORD_REMOTE(n_si); num = S_G.zero_length_bignum; } { @@ -2342,7 +2287,7 @@ static void sweep_thread(thread_gc *tgc, ptr p) pp += 1; if (mask & 1) { - relocate_pure(&(*(pp)), p, p_sz); + relocate_pure(&(*(pp))); } mask >>= 1; } @@ -2362,33 +2307,29 @@ static void sweep_thread(thread_gc *tgc, ptr p) W(tc) = 0; X(tc) = 0; Y(tc) = 0; - relocate_pure(&(THREADNO(tc)), p, p_sz); - relocate_pure(&(CURRENTINPUT(tc)), p, p_sz); - relocate_pure(&(CURRENTOUTPUT(tc)), p, p_sz); - relocate_pure(&(CURRENTERROR(tc)), p, p_sz); - relocate_pure(&(SFD(tc)), p, p_sz); - relocate_pure(&(CURRENTMSO(tc)), p, p_sz); - relocate_pure(&(TARGETMACHINE(tc)), p, p_sz); - relocate_pure(&(FXLENGTHBV(tc)), p, p_sz); - relocate_pure(&(FXFIRSTBITSETBV(tc)), p, p_sz); - relocate_pure(&(NULLIMMUTABLEVECTOR(tc)), p, p_sz); - relocate_pure(&(NULLIMMUTABLEFXVECTOR(tc)), p, p_sz); - relocate_pure(&(NULLIMMUTABLEBYTEVECTOR(tc)), p, p_sz); - relocate_pure(&(NULLIMMUTABLESTRING(tc)), p, p_sz); - relocate_pure(&(COMPILEPROFILE(tc)), p, p_sz); - relocate_pure(&(SUBSETMODE(tc)), p, p_sz); - relocate_pure(&(DEFAULTRECORDEQUALPROCEDURE(tc)), p, p_sz); - relocate_pure(&(DEFAULTRECORDHASHPROCEDURE(tc)), p, p_sz); - relocate_pure(&(COMPRESSFORMAT(tc)), p, p_sz); - relocate_pure(&(COMPRESSLEVEL(tc)), p, p_sz); - relocate_pure(&(PARAMETERS(tc)), p, p_sz); + relocate_pure(&(THREADNO(tc))); + relocate_pure(&(CURRENTINPUT(tc))); + relocate_pure(&(CURRENTOUTPUT(tc))); + relocate_pure(&(CURRENTERROR(tc))); + relocate_pure(&(SFD(tc))); + relocate_pure(&(CURRENTMSO(tc))); + relocate_pure(&(TARGETMACHINE(tc))); + relocate_pure(&(FXLENGTHBV(tc))); + relocate_pure(&(FXFIRSTBITSETBV(tc))); + relocate_pure(&(COMPILEPROFILE(tc))); + relocate_pure(&(SUBSETMODE(tc))); + relocate_pure(&(DEFAULTRECORDEQUALPROCEDURE(tc))); + relocate_pure(&(DEFAULTRECORDHASHPROCEDURE(tc))); + relocate_pure(&(COMPRESSFORMAT(tc))); + relocate_pure(&(COMPRESSLEVEL(tc))); + relocate_pure(&(PARAMETERS(tc))); DSTBV(tc) = Sfalse; SRCBV(tc) = Sfalse; { INT i = 0; while (i < virtual_register_count) { - relocate_pure(&(VIRTREG(tc, i)), p, p_sz); + relocate_pure(&(VIRTREG(tc, i))); i += 1; } } @@ -2402,177 +2343,181 @@ static void sweep_thread(thread_gc *tgc, ptr p) } } } + FLUSH_REMOTE(tgc, p); } static void sweep_port(thread_gc *tgc, ptr p, IGEN from_g) { + FLUSH_REMOTE_BLOCK { - uptr p_sz = size_port; - relocate_impure(&PORTHANDLER(p), from_g, p, p_sz); + relocate_impure(&PORTHANDLER(p), from_g); if (((uptr)TYPEFIELD(p)) & PORT_FLAG_OUTPUT) { iptr n = ((iptr)(PORTOLAST(p))) - ((iptr)(PORTOBUF(p))); - relocate_impure(&PORTOBUF(p), from_g, p, p_sz); + relocate_impure(&PORTOBUF(p), from_g); PORTOLAST(p) = (ptr)(((iptr)(PORTOBUF(p))) + n); } if (((uptr)TYPEFIELD(p)) & PORT_FLAG_INPUT) { iptr n = ((iptr)(PORTILAST(p))) - ((iptr)(PORTIBUF(p))); - relocate_impure(&PORTIBUF(p), from_g, p, p_sz); + relocate_impure(&PORTIBUF(p), from_g); PORTILAST(p) = (ptr)(((iptr)(PORTIBUF(p))) + n); } - relocate_impure(&PORTINFO(p), from_g, p, p_sz); - relocate_impure(&PORTNAME(p), from_g, p, p_sz); + relocate_impure(&PORTINFO(p), from_g); + relocate_impure(&PORTNAME(p), from_g); } + FLUSH_REMOTE(tgc, p); } static IGEN sweep_dirty_port(thread_gc *tgc, ptr p, IGEN youngest) { + FLUSH_REMOTE_BLOCK { - uptr p_sz = size_port; - relocate_dirty(&PORTHANDLER(p), youngest, p, p_sz); + relocate_dirty(&PORTHANDLER(p), youngest); if (((uptr)TYPEFIELD(p)) & PORT_FLAG_OUTPUT) { iptr n = ((iptr)(PORTOLAST(p))) - ((iptr)(PORTOBUF(p))); - relocate_dirty(&PORTOBUF(p), youngest, p, p_sz); + relocate_dirty(&PORTOBUF(p), youngest); PORTOLAST(p) = (ptr)(((iptr)(PORTOBUF(p))) + n); } if (((uptr)TYPEFIELD(p)) & PORT_FLAG_INPUT) { iptr n = ((iptr)(PORTILAST(p))) - ((iptr)(PORTIBUF(p))); - relocate_dirty(&PORTIBUF(p), youngest, p, p_sz); + relocate_dirty(&PORTIBUF(p), youngest); PORTILAST(p) = (ptr)(((iptr)(PORTIBUF(p))) + n); } - relocate_dirty(&PORTINFO(p), youngest, p, p_sz); - relocate_dirty(&PORTNAME(p), youngest, p, p_sz); + relocate_dirty(&PORTINFO(p), youngest); + relocate_dirty(&PORTNAME(p), youngest); } + FLUSH_REMOTE(tgc, p); return youngest; } static void sweep_continuation(thread_gc *tgc, ptr p, IGEN from_g) { + FLUSH_REMOTE_BLOCK { { + ptr code = CLOSCODE(p); + relocate_pure(&code); + SETCLOSCODE(p, code); + relocate_pure(&CONTWINDERS(p)); + relocate_impure(&CONTATTACHMENTS(p), from_g); + if ((CONTLENGTH(p)) == scaled_shot_1_shot_flag) { - uptr p_sz = size_continuation; - relocate_pure(&CONTWINDERS(p), p, p_sz); - relocate_impure(&CONTATTACHMENTS(p), from_g, p, p_sz); - if ((CONTLENGTH(p)) == scaled_shot_1_shot_flag) - { - } - else + } + else + { + ptr stk = CONTSTACK(p); { - ptr stk = CONTSTACK(p); + seginfo* s_si = NULL; + if ((stk != ((ptr)0)) && ((s_si = (SegInfo((ptr_get_segment(stk))))), (s_si -> old_space))) { - seginfo* s_si = NULL; - if ((stk != ((ptr)0)) && ((s_si = (SegInfo((ptr_get_segment(stk))))), (s_si -> old_space))) + if (!(SEGMENT_IS_LOCAL(s_si, stk))) { - if (!(SEGMENT_IS_LOCAL(s_si, stk))) - { - RECORD_REMOTE_RANGE(tgc, p, p_sz, s_si); - } - else - { - CONTSTACK(p) = copy_stack(tgc, CONTSTACK(p), &(CONTLENGTH(p)), CONTCLENGTH(p)); - } + RECORD_REMOTE(s_si); } - relocate_pure(&CONTLINK(p), p, p_sz); + else { - ptr xcp = CONTRET(p); + CONTSTACK(p) = copy_stack(tgc, CONTSTACK(p), &(CONTLENGTH(p)), CONTCLENGTH(p)); + } + } + relocate_pure(&CONTLINK(p)); + { + ptr xcp = CONTRET(p); + { + iptr co = (ENTRYOFFSET(xcp)) + (((uptr)xcp) - ((uptr)(TO_PTR((ENTRYOFFSETADDR(xcp)))))); { - iptr co = (ENTRYOFFSET(xcp)) + (((uptr)xcp) - ((uptr)(TO_PTR((ENTRYOFFSETADDR(xcp)))))); + ptr c_p = (ptr)(((uptr)xcp) - co); { - ptr c_p = (ptr)(((uptr)xcp) - co); + seginfo* x_si = SegInfo((ptr_get_segment(c_p))); + if (x_si -> old_space) { - seginfo* x_si = SegInfo((ptr_get_segment(c_p))); - if (x_si -> old_space) - { - relocate_code(c_p, x_si, p, p_sz); - CONTRET(p) = (ptr)(((uptr)c_p) + co); - } + relocate_code(c_p, x_si); + CONTRET(p) = (ptr)(((uptr)c_p) + co); + } + { + uptr stack = (uptr)(CONTSTACK(p)); { - uptr stack = (uptr)(CONTSTACK(p)); + uptr base = stack; { - uptr base = stack; + uptr fp = stack + (CONTCLENGTH(p)); { - uptr fp = stack + (CONTCLENGTH(p)); + uptr ret = (uptr)(CONTRET(p)); + while (fp != base) { - uptr ret = (uptr)(CONTRET(p)); - while (fp != base) + if (fp < base) { - if (fp < base) - { - S_error_abort("sweep_stack(gc): malformed stack"); - } - fp = fp - (ENTRYFRAMESIZE(ret)); + S_error_abort("sweep_stack(gc): malformed stack"); + } + fp = fp - (ENTRYFRAMESIZE(ret)); + { + ptr* pp = (ptr*)(TO_VOIDP(fp)); + iptr oldret = ret; + ret = (iptr)(*(pp)); { - ptr* pp = (ptr*)(TO_VOIDP(fp)); - iptr oldret = ret; - ret = (iptr)(*(pp)); + ptr xcp = *(pp); { - ptr xcp = *(pp); + iptr co = (ENTRYOFFSET(xcp)) + (((uptr)xcp) - ((uptr)(TO_PTR((ENTRYOFFSETADDR(xcp)))))); { - iptr co = (ENTRYOFFSET(xcp)) + (((uptr)xcp) - ((uptr)(TO_PTR((ENTRYOFFSETADDR(xcp)))))); + ptr c_p = (ptr)(((uptr)xcp) - co); { - ptr c_p = (ptr)(((uptr)xcp) - co); + seginfo* x_si = SegInfo((ptr_get_segment(c_p))); + if (x_si -> old_space) { - seginfo* x_si = SegInfo((ptr_get_segment(c_p))); - if (x_si -> old_space) - { - relocate_code(c_p, x_si, p, p_sz); - *(pp) = (ptr)(((uptr)c_p) + co); - } + relocate_code(c_p, x_si); + *(pp) = (ptr)(((uptr)c_p) + co); + } + { + ptr num = ENTRYLIVEMASK(oldret); + if (Sfixnump(num)) { - ptr num = ENTRYLIVEMASK(oldret); - if (Sfixnump(num)) { + uptr mask = UNFIX(num); + while (mask != 0) { - uptr mask = UNFIX(num); - while (mask != 0) + pp += 1; + if (mask & 1) { - pp += 1; - if (mask & 1) - { - relocate_pure(&(*(pp)), p, p_sz); - } - mask >>= 1; + relocate_pure(&(*(pp))); } + mask >>= 1; } } + } + else + { + seginfo* n_si = SegInfo((ptr_get_segment(num))); + if (!(n_si -> old_space)) + { + } + else if (SEGMENT_IS_LOCAL(n_si, num)) + { + relocate_pure(&(*((ENTRYNONCOMPACTLIVEMASKADDR(oldret))))); + num = ENTRYLIVEMASK(oldret); + } else { - seginfo* n_si = SegInfo((ptr_get_segment(num))); - if (!(n_si -> old_space)) - { - } - else if (SEGMENT_IS_LOCAL(n_si, num)) - { - relocate_pure(&(*((ENTRYNONCOMPACTLIVEMASKADDR(oldret)))), p, p_sz); - num = ENTRYLIVEMASK(oldret); - } - else - { - RECORD_REMOTE_RANGE(tgc, p, p_sz, n_si); - num = S_G.zero_length_bignum; - } + RECORD_REMOTE(n_si); + num = S_G.zero_length_bignum; + } + { + iptr index = BIGLEN(num); + while (index != 0) { - iptr index = BIGLEN(num); - while (index != 0) + index -= 1; { - index -= 1; + INT bits = bigit_bits; + bigit mask = BIGIT(num, index); + while (bits > 0) { - INT bits = bigit_bits; - bigit mask = BIGIT(num, index); - while (bits > 0) + bits -= 1; + pp += 1; + if (mask & 1) { - bits -= 1; - pp += 1; - if (mask & 1) - { - relocate_pure(&(*(pp)), p, p_sz); - } - mask >>= 1; + relocate_pure(&(*(pp))); } + mask >>= 1; } } } @@ -2597,105 +2542,104 @@ static void sweep_continuation(thread_gc *tgc, ptr p, IGEN from_g) } } } + FLUSH_REMOTE(tgc, p); } static void sweep_code_object(thread_gc *tgc, ptr p, IGEN from_g) { + FLUSH_REMOTE_BLOCK { - uptr len = CODELEN(p); + relocate_pure(&CODENAME(p)); + relocate_pure(&CODEARITYMASK(p)); + relocate_pure(&CODEINFO(p)); + relocate_pure(&CODEPINFOS(p)); { - uptr p_sz = size_code(len); - relocate_pure(&CODENAME(p), p, p_sz); - relocate_pure(&CODEARITYMASK(p), p, p_sz); - relocate_pure(&CODEINFO(p), p, p_sz); - relocate_pure(&CODEPINFOS(p), p, p_sz); + ptr t = CODERELOC(p); { - ptr t = CODERELOC(p); + iptr m = (t + ? (RELOCSIZE(t)) + : 0); { - iptr m = (t - ? (RELOCSIZE(t)) - : 0); + ptr oldco = (t + ? (RELOCCODE(t)) + : 0); { - ptr oldco = (t - ? (RELOCCODE(t)) - : 0); + iptr a = 0; { - iptr a = 0; + iptr n = 0; + while (n < m) { - iptr n = 0; - while (n < m) { + uptr entry = RELOCIT(t, n); + uptr item_off = 0; + uptr code_off = 0; + n = n + 1; + if (RELOC_EXTENDED_FORMAT(entry)) { - uptr entry = RELOCIT(t, n); - uptr item_off = 0; - uptr code_off = 0; + item_off = RELOCIT(t, n); + n = n + 1; + code_off = RELOCIT(t, n); n = n + 1; - if (RELOC_EXTENDED_FORMAT(entry)) - { - item_off = RELOCIT(t, n); - n = n + 1; - code_off = RELOCIT(t, n); - n = n + 1; - } - else - { - item_off = RELOC_ITEM_OFFSET(entry); - code_off = RELOC_CODE_OFFSET(entry); - } - a = a + code_off; - { - ptr obj = S_get_code_obj(RELOC_TYPE(entry), oldco, a, item_off); - relocate_pure(&obj, p, p_sz); - S_set_code_obj("gc", RELOC_TYPE(entry), p, a, obj, item_off); - } + } + else + { + item_off = RELOC_ITEM_OFFSET(entry); + code_off = RELOC_CODE_OFFSET(entry); + } + a = a + code_off; + { + ptr obj = S_get_code_obj(RELOC_TYPE(entry), oldco, a, item_off); + relocate_pure(&obj); + S_set_code_obj("gc", RELOC_TYPE(entry), p, a, obj, item_off); } } - if ((from_g == static_generation) && ((!S_G.retain_static_relocation) && (0 == ((CODETYPE(p)) & (code_flag_template << code_flags_offset))))) - { - CODERELOC(p) = (ptr)0; - } - else + } + if ((from_g == static_generation) && ((!S_G.retain_static_relocation) && (0 == ((CODETYPE(p)) & (code_flag_template << code_flags_offset))))) + { + CODERELOC(p) = (ptr)0; + } + else + { { + seginfo* t_si = SegInfo((ptr_get_segment(t))); + if (t_si -> old_space) { - seginfo* t_si = SegInfo((ptr_get_segment(t))); - if (t_si -> old_space) + if (SEGMENT_IS_LOCAL(t_si, t)) { - if (SEGMENT_IS_LOCAL(t_si, t)) + n = size_reloc_table((RELOCSIZE(t))); + if (t_si -> use_marks) { - n = size_reloc_table((RELOCSIZE(t))); - if (t_si -> use_marks) + if (!(marked(t_si, t))) { - if (!(marked(t_si, t))) - { - mark_typemod_data_object(tgc, t, n, t_si); - } - } - else - { - { - ptr oldt = t; - find_gc_room(tgc, space_data, from_g, typemod, n, t); - memcpy_aligned(TO_VOIDP(t), TO_VOIDP(oldt), n); - } + mark_typemod_data_object(tgc, t, n, t_si); } } else { - RECORD_REMOTE_RANGE(tgc, p, p_sz, t_si); + { + ptr oldt = t; + find_gc_room(tgc, space_data, from_g, typemod, n, t); + memcpy_aligned(TO_VOIDP(t), TO_VOIDP(oldt), n); + } } } + else + { + RECORD_REMOTE(t_si); + } } - RELOCCODE(t) = p; - CODERELOC(p) = t; } - S_record_code_mod(tgc -> tc, (uptr)(TO_PTR((&(CODEIT(p, 0))))), (uptr)(CODELEN(p))); + RELOCCODE(t) = p; + CODERELOC(p) = t; } + S_record_code_mod(tgc -> tc, (uptr)(TO_PTR((&(CODEIT(p, 0))))), (uptr)(CODELEN(p))); } } } } } } + FLUSH_REMOTE(tgc, p); } static uptr size_object(ptr p) @@ -2749,6 +2693,14 @@ static uptr size_object(ptr p) return p_sz; } } + else if (TYPEP(tf, mask_flvector, type_flvector)) + { + uptr sz = size_flvector((Sflvector_length(p))); + { + uptr p_sz = sz; + return p_sz; + } + } else if (TYPEP(tf, mask_bytevector, type_bytevector)) { uptr sz = size_bytevector((Sbytevector_length(p))); @@ -3058,6 +3010,42 @@ static IGEN mark_object(thread_gc *tgc, ptr p, seginfo *si) } } } + else if (TYPEP(tf, mask_flvector, type_flvector)) + { + uptr sz = size_flvector((Sflvector_length(p))); + { + uptr p_sz = sz; + si->marked_mask[segment_bitmap_byte(p)] |= segment_bitmap_bit(p); + { + uptr addr = (uptr)UNTYPE(p, type_typed_object); + uptr seg = addr_get_segment(addr); + uptr end_seg = addr_get_segment(addr + p_sz - 1); + if (seg == end_seg) { + si->marked_count += p_sz; + } else { + seginfo *mark_si; IGEN g; + si->marked_count += ((uptr)build_ptr(seg+1,0)) - addr; + seg++; + while (seg < end_seg) { + mark_si = SegInfo(seg); + g = mark_si->generation; + if (!fully_marked_mask[g]) init_fully_marked_mask(tgc, g); + mark_si->marked_mask = fully_marked_mask[g]; + mark_si->marked_count = bytes_per_segment; + seg++; + } + mark_si = SegInfo(end_seg); + { + if (!mark_si->marked_mask) { + init_mask(tgc, mark_si->marked_mask, mark_si->generation, 0); + } + /* no need to set a bit: it's enough to have made `marked_mask` non-NULL */ + mark_si->marked_count += addr + p_sz - (uptr)build_ptr(end_seg,0); + } + } + } + } + } else if (TYPEP(tf, mask_bytevector, type_bytevector)) { uptr sz = size_bytevector((Sbytevector_length(p))); @@ -3111,9 +3099,9 @@ static IGEN mark_object(thread_gc *tgc, ptr p, seginfo *si) ptr keyval = INITTLCKEYVAL(p); if ((next != Sfalse) && (OLDSPACE(keyval))) { - GC_TC_MUTEX_ACQUIRE(); + GC_MUTEX_ACQUIRE(); tlcs_to_rehash = S_cons_in(tgc -> tc, space_new, 0, p, tlcs_to_rehash); - GC_TC_MUTEX_RELEASE(); + GC_MUTEX_RELEASE(); } } } @@ -3253,9 +3241,9 @@ static IGEN mark_object(thread_gc *tgc, ptr p, seginfo *si) uptr p_sz = size_phantom; si->marked_mask[segment_bitmap_byte(p)] |= segment_bitmap_bit(p); si->marked_count += p_sz; - GC_TC_MUTEX_ACQUIRE(); + GC_MUTEX_ACQUIRE(); (S_G.bytesof[TARGET_GENERATION(si)])[countof_phantom] += PHANTOMLEN(p); - GC_TC_MUTEX_RELEASE(); + GC_MUTEX_RELEASE(); } else { @@ -3298,9 +3286,9 @@ static IGEN mark_object(thread_gc *tgc, ptr p, seginfo *si) if ((CONTLENGTH(p)) == opportunistic_1_shot_flag) { CONTLENGTH(p) = CONTCLENGTH(p); - GC_TC_MUTEX_ACQUIRE(); + GC_MUTEX_ACQUIRE(); conts_to_promote = S_cons_in(tgc -> tc, space_new, 0, p, conts_to_promote); - GC_TC_MUTEX_RELEASE(); + GC_MUTEX_RELEASE(); } else { @@ -3519,6 +3507,9 @@ static IBOOL object_directly_refers_to_self(ptr p) else if (TYPEP(tf, mask_fxvector, type_fxvector)) { } + else if (TYPEP(tf, mask_flvector, type_flvector)) + { + } else if (TYPEP(tf, mask_bytevector, type_bytevector)) { } diff --git a/src/ChezScheme/boot/pb/heapcheck.inc b/src/ChezScheme/boot/pb/heapcheck.inc index d9aa48bf9e..c0f08825c6 100644 --- a/src/ChezScheme/boot/pb/heapcheck.inc +++ b/src/ChezScheme/boot/pb/heapcheck.inc @@ -108,6 +108,9 @@ static void check_object(ptr p, uptr seg, ISPC s_in, IBOOL aftergc) else if (TYPEP(tf, mask_fxvector, type_fxvector)) { } + else if (TYPEP(tf, mask_flvector, type_flvector)) + { + } else if (TYPEP(tf, mask_bytevector, type_bytevector)) { } @@ -303,10 +306,6 @@ static void check_object(ptr p, uptr seg, ISPC s_in, IBOOL aftergc) check_pointer(&(TARGETMACHINE(tc)), 1, p, seg, s_in, aftergc); check_pointer(&(FXLENGTHBV(tc)), 1, p, seg, s_in, aftergc); check_pointer(&(FXFIRSTBITSETBV(tc)), 1, p, seg, s_in, aftergc); - check_pointer(&(NULLIMMUTABLEVECTOR(tc)), 1, p, seg, s_in, aftergc); - check_pointer(&(NULLIMMUTABLEFXVECTOR(tc)), 1, p, seg, s_in, aftergc); - check_pointer(&(NULLIMMUTABLEBYTEVECTOR(tc)), 1, p, seg, s_in, aftergc); - check_pointer(&(NULLIMMUTABLESTRING(tc)), 1, p, seg, s_in, aftergc); check_pointer(&(COMPILEPROFILE(tc)), 1, p, seg, s_in, aftergc); check_pointer(&(SUBSETMODE(tc)), 1, p, seg, s_in, aftergc); check_pointer(&(DEFAULTRECORDEQUALPROCEDURE(tc)), 1, p, seg, s_in, aftergc); @@ -548,6 +547,14 @@ static uptr size_object(ptr p) return p_sz; } } + else if (TYPEP(tf, mask_flvector, type_flvector)) + { + uptr sz = size_flvector((Sflvector_length(p))); + { + uptr p_sz = sz; + return p_sz; + } + } else if (TYPEP(tf, mask_bytevector, type_bytevector)) { uptr sz = size_bytevector((Sbytevector_length(p))); diff --git a/src/ChezScheme/boot/pb/petite.boot b/src/ChezScheme/boot/pb/petite.boot Binary files differindex 5e5952acaa..b8918b27c5 100644 --- a/src/ChezScheme/boot/pb/petite.boot +++ b/src/ChezScheme/boot/pb/petite.boot diff --git a/src/ChezScheme/boot/pb/scheme.boot b/src/ChezScheme/boot/pb/scheme.boot Binary files differindex 36be365a13..1ef3a157aa 100644 --- a/src/ChezScheme/boot/pb/scheme.boot +++ b/src/ChezScheme/boot/pb/scheme.boot diff --git a/src/ChezScheme/boot/pb/scheme.h b/src/ChezScheme/boot/pb/scheme.h index 32ab406cad..50107505ce 100644 --- a/src/ChezScheme/boot/pb/scheme.h +++ b/src/ChezScheme/boot/pb/scheme.h @@ -1,4 +1,4 @@ -/* scheme.h for Chez Scheme Version 9.5.3.39 (pb) */ +/* scheme.h for Chez Scheme Version 9.5.3.58 (pb) */ /* Do not edit this file. It is automatically generated and */ /* specifically tailored to the version of Chez Scheme named */ @@ -7,7 +7,9 @@ /* Warning: Some macros may evaluate arguments more than once. */ -#define _LARGEFILE64_SOURCE +#ifndef _LARGEFILE64_SOURCE +# define _LARGEFILE64_SOURCE +#endif #include <stdint.h> /* Enable function prototypes by default. */ @@ -43,7 +45,7 @@ #endif /* Chez Scheme Version and machine type */ -#define VERSION "9.5.3.39" +#define VERSION "9.5.3.58" #define MACHINE_TYPE "pb" /* All Scheme objects are of type ptr. Type iptr and */ @@ -87,7 +89,9 @@ typedef unsigned char octet; #define Svectorp(x) ((((uptr)(x)&0x7)==0x7) &&\ (((uptr)((*((ptr *)TO_VOIDP((uptr)(x)+1))))&0x7)==0x0)) #define Sfxvectorp(x) ((((uptr)(x)&0x7)==0x7) &&\ - (((uptr)((*((ptr *)TO_VOIDP((uptr)(x)+1))))&0x7)==0x3)) + (((uptr)((*((ptr *)TO_VOIDP((uptr)(x)+1))))&0xF)==0x3)) +#define Sflvectorp(x) ((((uptr)(x)&0x7)==0x7) &&\ + (((uptr)((*((ptr *)TO_VOIDP((uptr)(x)+1))))&0xF)==0xB)) #define Sbytevectorp(x) ((((uptr)(x)&0x7)==0x7) &&\ (((uptr)((*((ptr *)TO_VOIDP((uptr)(x)+1))))&0x3)==0x1)) #define Sstringp(x) ((((uptr)(x)&0x7)==0x7) &&\ @@ -122,6 +126,8 @@ typedef unsigned char octet; #define Svector_ref(x,i) (((ptr *)TO_VOIDP((uptr)(x)+9))[i]) #define Sfxvector_length(x) ((iptr)((uptr)(*((iptr *)TO_VOIDP((uptr)(x)+1)))>>4)) #define Sfxvector_ref(x,i) (((ptr *)TO_VOIDP((uptr)(x)+9))[i]) +#define Sflvector_length(x) ((iptr)((uptr)(*((iptr *)TO_VOIDP((uptr)(x)+1)))>>4)) +#define Sflvector_ref(x,i) (((double *)TO_VOIDP((uptr)(x)+9))[i]) #define Sbytevector_length(x) ((iptr)((uptr)(*((iptr *)TO_VOIDP((uptr)(x)+1)))>>3)) #define Sbytevector_u8_ref(x,i) (((octet *)TO_VOIDP((uptr)(x)+9))[i]) /* Warning: Sbytevector_data(x) returns a pointer into x. */ @@ -144,6 +150,7 @@ EXPORT void Sset_car PROTO((ptr, ptr)); EXPORT void Sset_cdr PROTO((ptr, ptr)); #define Sstring_set(x,i,c) ((void)((((string_char *)TO_VOIDP((uptr)(x)+9))[i]) = (string_char)(uptr)Schar(c))) #define Sfxvector_set(x,i,n) ((void)(Sfxvector_ref(x,i) = (n))) +#define Sflvector_set(x,i,n) ((void)(Sflvector_ref(x,i) = (n))) #define Sbytevector_u8_set(x,i,n) ((void)(Sbytevector_u8_ref(x,i) = (n))) EXPORT void Svector_set PROTO((ptr, iptr, ptr)); @@ -163,6 +170,7 @@ EXPORT ptr Ssymbol_to_string PROTO((ptr)); EXPORT ptr Sflonum PROTO((double)); EXPORT ptr Smake_vector PROTO((iptr, ptr)); EXPORT ptr Smake_fxvector PROTO((iptr, ptr)); +EXPORT ptr Smake_flvector PROTO((iptr, ptr)); EXPORT ptr Smake_bytevector PROTO((iptr, int)); EXPORT ptr Smake_string PROTO((iptr, int)); EXPORT ptr Smake_uninitialized_string PROTO((iptr)); @@ -213,6 +221,7 @@ EXPORT void Sscheme_init PROTO((void (*)(void))); EXPORT void Sregister_boot_file PROTO((const char *)); EXPORT void Sregister_boot_direct_file PROTO((const char *)); EXPORT void Sregister_boot_file_fd PROTO((const char *, int fd)); +EXPORT void Sregister_boot_file_fd_region PROTO((const char *, int fd, iptr offset, iptr len, int close_after)); EXPORT void Sregister_heap_file PROTO((const char *)); EXPORT void Scompact_heap PROTO((void)); EXPORT void Ssave_heap PROTO((const char *, int)); @@ -257,8 +266,6 @@ typedef uint32_t (*pb_uint32_t)(); typedef double (*pb_double_double_t)(double); typedef double (*pb_double_uptr_t)(uptr); typedef double (*pb_double_double_double_t)(double, double); -typedef int32_t (*pb_int32_int32_t)(int32_t); -typedef int32_t (*pb_int32_int32_uptr_t)(int32_t, uptr); typedef int32_t (*pb_int32_uptr_uptr_uptr_uptr_uptr_t)(uptr, uptr, uptr, uptr, uptr); typedef uptr (*pb_uptr_t)(); typedef uptr (*pb_uptr_uptr_t)(uptr); diff --git a/src/ChezScheme/boot/pb/vfasl.inc b/src/ChezScheme/boot/pb/vfasl.inc deleted file mode 100644 index bca91580a8..0000000000 --- a/src/ChezScheme/boot/pb/vfasl.inc +++ /dev/null @@ -1,676 +0,0 @@ -static ptr copy(vfasl_info *vfi, ptr p, seginfo *si) -{ - ptr new_p; - { - ITYPE t = TYPEBITS(p); - if (t == type_typed_object) - { - ptr tf = TYPEFIELD(p); - if (TYPEP(tf, mask_record, type_record)) - { - { - ptr rtd = RECORDINSTTYPE(p); - int p_vspc = ((is_rtd(rtd, vfi)) - ? vspace_rtd - : (((RECORDDESCMPM(rtd)) == (FIX(0))) - ? vspace_pure_typed - : vspace_impure_record)); - if (is_rtd(rtd, vfi)) - { - if (p != S_G.base_rtd) - { - (void)(vfasl_relocate_help(vfi, rtd)); - } - vfasl_relocate_parents(vfi, RECORDDESCPARENT(p)); - } - { - uptr len = UNFIX((RECORDDESCSIZE(rtd))); - { - uptr p_sz = size_record_inst(len); - FIND_ROOM(vfi, p_vspc, type_typed_object, p_sz, new_p); - RECORDINSTTYPE(new_p) = rtd; - memcpy_aligned(&RECORDINSTIT(new_p, 0), &RECORDINSTIT(p, 0), len - ptr_bytes); - if (p == S_G.base_rtd) - { - vfi -> base_rtd = new_p; - } - { - uptr ua_size = unaligned_size_record_inst(len); - if (p_sz != ua_size) - { - *(((ptr*)(TO_VOIDP((((uptr)(UNTYPE(new_p, type_typed_object))) + ua_size))))) = FIX(0); - } - } - } - } - } - } - else if (TYPEP(tf, mask_vector, type_vector)) - { - int p_vspc = vspace_impure; - { - uptr len = Svector_length(p); - { - uptr p_sz = size_vector(len); - FIND_ROOM(vfi, p_vspc, type_typed_object, p_sz, new_p); - VECTTYPE(new_p) = (uptr)tf; - memcpy_aligned(&INITVECTIT(new_p, 0), &INITVECTIT(p, 0), ptr_bytes * len); - if ((len & 1) == 0) - { - INITVECTIT(new_p, len) = FIX(0); - } - } - } - } - else if (TYPEP(tf, mask_stencil_vector, type_stencil_vector)) - { - int p_vspc = vspace_impure; - { - uptr len = Sstencil_vector_length(p); - { - uptr p_sz = size_stencil_vector(len); - FIND_ROOM(vfi, p_vspc, type_typed_object, p_sz, new_p); - STENVECTTYPE(new_p) = (uptr)tf; - memcpy_aligned(&INITSTENVECTIT(new_p, 0), &INITSTENVECTIT(p, 0), ptr_bytes * len); - if ((len & 1) == 0) - { - INITSTENVECTIT(new_p, len) = FIX(0); - } - } - } - } - else if (TYPEP(tf, mask_string, type_string)) - { - int p_vspc = vspace_data; - { - uptr sz = size_string((Sstring_length(p))); - { - uptr p_sz = sz; - FIND_ROOM(vfi, p_vspc, type_typed_object, p_sz, new_p); - memcpy_aligned(&STRTYPE(new_p), &STRTYPE(p), sz); - } - } - } - else if (TYPEP(tf, mask_fxvector, type_fxvector)) - { - int p_vspc = vspace_data; - { - uptr sz = size_fxvector((Sfxvector_length(p))); - { - uptr p_sz = sz; - FIND_ROOM(vfi, p_vspc, type_typed_object, p_sz, new_p); - memcpy_aligned(&FXVECTOR_TYPE(new_p), &FXVECTOR_TYPE(p), sz); - } - } - } - else if (TYPEP(tf, mask_bytevector, type_bytevector)) - { - int p_vspc = vspace_data; - { - uptr sz = size_bytevector((Sbytevector_length(p))); - { - uptr p_sz = sz; - FIND_ROOM(vfi, p_vspc, type_typed_object, p_sz, new_p); - memcpy_aligned(&BYTEVECTOR_TYPE(new_p), &BYTEVECTOR_TYPE(p), sz); - } - } - } - else if ((iptr)tf == type_tlc) - { - vfasl_fail(vfi, "tlc"); - return(((ptr)0)); - } - else if (TYPEP(tf, mask_box, type_box)) - { - int p_vspc = vspace_impure; - { - uptr p_sz = size_box; - FIND_ROOM(vfi, p_vspc, type_typed_object, p_sz, new_p); - BOXTYPE(new_p) = (uptr)tf; - INITBOXREF(new_p) = INITBOXREF(p); - } - } - else if ((iptr)tf == type_ratnum) - { - int p_vspc = vspace_impure; - { - uptr p_sz = size_ratnum; - FIND_ROOM(vfi, p_vspc, type_typed_object, p_sz, new_p); - RATTYPE(new_p) = type_ratnum; - RATNUM(new_p) = RATNUM(p); - RATDEN(new_p) = RATDEN(p); - ((ptr*)(TO_VOIDP((UNTYPE(new_p, type_typed_object)))))[3] = 0; - } - } - else if ((iptr)tf == type_exactnum) - { - int p_vspc = vspace_impure; - { - uptr p_sz = size_exactnum; - FIND_ROOM(vfi, p_vspc, type_typed_object, p_sz, new_p); - EXACTNUM_TYPE(new_p) = type_exactnum; - EXACTNUM_REAL_PART(new_p) = EXACTNUM_REAL_PART(p); - EXACTNUM_IMAG_PART(new_p) = EXACTNUM_IMAG_PART(p); - ((ptr*)(TO_VOIDP((UNTYPE(new_p, type_typed_object)))))[3] = 0; - } - } - else if ((iptr)tf == type_inexactnum) - { - int p_vspc = vspace_data; - { - uptr p_sz = size_inexactnum; - FIND_ROOM(vfi, p_vspc, type_typed_object, p_sz, new_p); - INEXACTNUM_TYPE(new_p) = type_inexactnum; - INEXACTNUM_REAL_PART(new_p) = INEXACTNUM_REAL_PART(p); - INEXACTNUM_IMAG_PART(new_p) = INEXACTNUM_IMAG_PART(p); - } - } - else if (TYPEP(tf, mask_bignum, type_bignum)) - { - int p_vspc = vspace_data; - { - uptr sz = size_bignum((BIGLEN(p))); - { - uptr p_sz = sz; - FIND_ROOM(vfi, p_vspc, type_typed_object, p_sz, new_p); - memcpy_aligned(&BIGTYPE(new_p), &BIGTYPE(p), sz); - } - } - } - else if (TYPEP(tf, mask_port, type_port)) - { - vfasl_fail(vfi, "port"); - return(((ptr)0)); - } - else if (TYPEP(tf, mask_code, type_code)) - { - int p_vspc = vspace_code; - { - uptr len = CODELEN(p); - { - uptr p_sz = size_code(len); - FIND_ROOM(vfi, p_vspc, type_typed_object, p_sz, new_p); - CODETYPE(new_p) = (uptr)tf; - CODELEN(new_p) = CODELEN(p); - CODERELOC(new_p) = CODERELOC(p); - CODENAME(new_p) = CODENAME(p); - CODEARITYMASK(new_p) = CODEARITYMASK(p); - CODEFREE(new_p) = CODEFREE(p); - CODEINFO(new_p) = CODEINFO(p); - CODEPINFOS(new_p) = CODEPINFOS(p); - memcpy_aligned(&CODEIT(new_p, 0), &CODEIT(p, 0), len); - } - } - } - else if ((iptr)tf == type_thread) - { - vfasl_fail(vfi, "thread"); - return(((ptr)0)); - } - else if ((iptr)tf == type_rtd_counts) - { - return(Sfalse); - } - else if ((iptr)tf == type_phantom) - { - vfasl_fail(vfi, "phantom"); - return(((ptr)0)); - } - else - { - S_error_abort("vfasl-copy: illegal typed object type"); - } - } - else if (t == type_pair) - { - { - ISPC p_at_spc = si->space; - if (p_at_spc == space_ephemeron) - { - vfasl_fail(vfi, "ephemeron"); - return(((ptr)0)); - } - else if (p_at_spc == space_weakpair) - { - vfasl_fail(vfi, "weakpair"); - return(((ptr)0)); - } - else - { - int p_vspc = vspace_impure; - { - uptr p_sz = size_pair; - FIND_ROOM(vfi, p_vspc, type_pair, p_sz, new_p); - INITCAR(new_p) = INITCAR(p); - INITCDR(new_p) = INITCDR(p); - } - } - } - } - else if (t == type_closure) - { - ptr code = CLOSCODE(p); - if ((CODETYPE(code)) & (code_flag_continuation << code_flags_offset)) - { - vfasl_fail(vfi, "closure"); - return(((ptr)0)); - } - else - { - int p_vspc = vspace_closure; - if ((CODETYPE(code)) & (code_flag_mutable_closure << code_flags_offset)) - { - vfasl_fail(vfi, "mutable closure"); - return(((ptr)0)); - } - { - uptr len = CODEFREE(code); - { - uptr p_sz = size_closure(len); - FIND_ROOM(vfi, p_vspc, type_closure, p_sz, new_p); - SETCLOSCODE(new_p, code); - memcpy_aligned(&CLOSIT(new_p, 0), &CLOSIT(p, 0), ptr_bytes * len); - if ((len & 1) == 0) - { - CLOSIT(new_p, len) = FIX(0); - } - } - } - } - } - else if (t == type_symbol) - { - int p_vspc = vspace_symbol; - { - uptr p_sz = size_symbol; - FIND_ROOM(vfi, p_vspc, type_symbol, p_sz, new_p); - INITSYMVAL(new_p) = FIX((vfasl_symbol_to_index(vfi, p))); - INITSYMPVAL(new_p) = Snil; - INITSYMPLIST(new_p) = Snil; - INITSYMNAME(new_p) = INITSYMNAME(p); - INITSYMSPLIST(new_p) = Snil; - INITSYMHASH(new_p) = INITSYMHASH(p); - } - } - else if (t == type_flonum) - { - int p_vspc = vspace_data; - { - uptr p_sz = size_flonum; - FIND_ROOM(vfi, p_vspc, type_flonum, p_sz, new_p); - FLODAT(new_p) = FLODAT(p); - } - } - else - { - S_error_abort("vfasl-copy: illegal type"); - } - } - vfasl_register_forward(vfi, p, new_p); - return new_p; -} - -static uptr sweep(vfasl_info *vfi, ptr p) -{ - uptr result_sz; - { - ITYPE t = TYPEBITS(p); - if (t == type_typed_object) - { - ptr tf = TYPEFIELD(p); - if (TYPEP(tf, mask_record, type_record)) - { - { - ptr rtd = RECORDINSTTYPE(p); - if (p == (vfi -> base_rtd)) - { - { - ptr* pp = &(RECORDINSTIT(p, 0)); - ptr* ppend = ((ptr*)(TO_VOIDP((((uptr)(TO_PTR(pp))) + (UNFIX((RECORDDESCSIZE(rtd)))))))) - 1; - while (pp < ppend) - { - *(pp) = Snil; - pp += 1; - } - return((size_record_inst((UNFIX((RECORDDESCSIZE(rtd))))))); - } - } - vfasl_relocate(vfi, &(RECORDINSTTYPE(p))); - { - uptr len = UNFIX((RECORDDESCSIZE(rtd))); - { - uptr p_sz = size_record_inst(len); - result_sz = p_sz; - { - ptr num = RECORDDESCPM(rtd); - ptr* pp = &(RECORDINSTIT(p, 0)); - if (Sfixnump(num)) - { - { - uptr mask = ((uptr)(UNFIX(num))) >> 1; - if (mask == (((uptr)-1) >> 1)) - { - { - ptr* ppend = ((ptr*)(TO_VOIDP((((uptr)(TO_PTR(pp))) + len)))) - 1; - while (pp < ppend) - { - vfasl_relocate(vfi, &(*(pp))); - pp += 1; - } - } - } - else - { - while (mask != 0) - { - if (mask & 1) - { - vfasl_relocate(vfi, &(*(pp))); - } - mask >>= 1; - pp += 1; - } - } - } - } - else - { - { - iptr index = (BIGLEN(num)) - 1; - bigit mask = (BIGIT(num, index)) >> 1; - INT bits = bigit_bits - 1; - while (1) - { - do - { - if (mask & 1) - { - vfasl_relocate(vfi, &(*(pp))); - } - mask >>= 1; - pp += 1; - bits -= 1; - } - while (bits > 0); - if (index == 0) - { - break; - } - index -= 1; - mask = BIGIT(num, index); - bits = bigit_bits; - } - } - } - } - } - } - } - } - else if (TYPEP(tf, mask_vector, type_vector)) - { - uptr len = Svector_length(p); - { - uptr p_sz = size_vector(len); - result_sz = p_sz; - { - uptr idx, p_len = len; - ptr *p_p = &INITVECTIT(p, 0); - for (idx = 0; idx < p_len; idx++) - { - vfasl_relocate(vfi, &(p_p[idx])); - } - } - } - } - else if (TYPEP(tf, mask_stencil_vector, type_stencil_vector)) - { - uptr len = Sstencil_vector_length(p); - { - uptr p_sz = size_stencil_vector(len); - result_sz = p_sz; - { - uptr idx, p_len = len; - ptr *p_p = &INITSTENVECTIT(p, 0); - for (idx = 0; idx < p_len; idx++) - { - vfasl_relocate(vfi, &(p_p[idx])); - } - } - } - } - else if (TYPEP(tf, mask_string, type_string)) - { - uptr sz = size_string((Sstring_length(p))); - { - uptr p_sz = sz; - result_sz = p_sz; - } - } - else if (TYPEP(tf, mask_fxvector, type_fxvector)) - { - uptr sz = size_fxvector((Sfxvector_length(p))); - { - uptr p_sz = sz; - result_sz = p_sz; - } - } - else if (TYPEP(tf, mask_bytevector, type_bytevector)) - { - uptr sz = size_bytevector((Sbytevector_length(p))); - { - uptr p_sz = sz; - result_sz = p_sz; - } - } - else if ((iptr)tf == type_tlc) - { - vfasl_fail(vfi, "tlc"); - return(0); - } - else if (TYPEP(tf, mask_box, type_box)) - { - uptr p_sz = size_box; - result_sz = p_sz; - vfasl_relocate(vfi, &INITBOXREF(p)); - } - else if ((iptr)tf == type_ratnum) - { - uptr p_sz = size_ratnum; - result_sz = p_sz; - vfasl_relocate(vfi, &RATNUM(p)); - vfasl_relocate(vfi, &RATDEN(p)); - } - else if ((iptr)tf == type_exactnum) - { - uptr p_sz = size_exactnum; - result_sz = p_sz; - vfasl_relocate(vfi, &EXACTNUM_REAL_PART(p)); - vfasl_relocate(vfi, &EXACTNUM_IMAG_PART(p)); - } - else if ((iptr)tf == type_inexactnum) - { - uptr p_sz = size_inexactnum; - result_sz = p_sz; - } - else if (TYPEP(tf, mask_bignum, type_bignum)) - { - uptr sz = size_bignum((BIGLEN(p))); - { - uptr p_sz = sz; - result_sz = p_sz; - } - } - else if (TYPEP(tf, mask_port, type_port)) - { - vfasl_fail(vfi, "port"); - return(0); - } - else if (TYPEP(tf, mask_code, type_code)) - { - uptr len = CODELEN(p); - { - uptr p_sz = size_code(len); - result_sz = p_sz; - vfasl_relocate(vfi, &CODENAME(p)); - vfasl_relocate(vfi, &CODEARITYMASK(p)); - vfasl_relocate(vfi, &CODEINFO(p)); - vfasl_relocate(vfi, &CODEPINFOS(p)); - { - ptr t = CODERELOC(p); - { - iptr m = (t - ? (RELOCSIZE(t)) - : 0); - { - ptr oldco = (t - ? (RELOCCODE(t)) - : 0); - { - uptr r_sz = size_reloc_table(m); - ptr new_t = vfasl_find_room(vfi, vspace_reloc, typemod, r_sz); - memcpy_aligned(TO_VOIDP(new_t), TO_VOIDP(t), r_sz); - t = new_t; - } - { - iptr a = 0; - { - iptr n = 0; - while (n < m) - { - { - uptr entry = RELOCIT(t, n); - uptr item_off = 0; - uptr code_off = 0; - n = n + 1; - if (RELOC_EXTENDED_FORMAT(entry)) - { - item_off = RELOCIT(t, n); - n = n + 1; - code_off = RELOCIT(t, n); - n = n + 1; - } - else - { - item_off = RELOC_ITEM_OFFSET(entry); - code_off = RELOC_CODE_OFFSET(entry); - } - a = a + code_off; - { - ptr obj = S_get_code_obj(RELOC_TYPE(entry), oldco, a, item_off); - obj = vfasl_encode_relocation(vfi, obj); - S_set_code_obj("vfasl", abs_reloc_variant((RELOC_TYPE(entry))), p, a, obj, item_off); - } - } - } - RELOCCODE(t) = (ptr)(ptr_diff(p, vfi -> base_addr)); - CODERELOC(p) = (ptr)(ptr_diff(t, vfi -> base_addr)); - } - } - } - } - } - } - } - else if ((iptr)tf == type_thread) - { - vfasl_fail(vfi, "thread"); - return(0); - } - else if ((iptr)tf == type_rtd_counts) - { - vfasl_fail(vfi, "rtd-counts"); - return(0); - } - else if ((iptr)tf == type_phantom) - { - vfasl_fail(vfi, "phantom"); - return(0); - } - else - { - S_error_abort("vfasl-sweep: illegal typed object type"); - } - } - else if (t == type_pair) - { - { - ISPC p_at_spc = SPACE(p); - if (p_at_spc == space_ephemeron) - { - vfasl_fail(vfi, "ephemeron"); - return(0); - } - else if (p_at_spc == space_weakpair) - { - vfasl_fail(vfi, "weakpair"); - return(0); - } - else - { - uptr p_sz = size_pair; - result_sz = p_sz; - vfasl_relocate(vfi, &INITCAR(p)); - vfasl_relocate(vfi, &INITCDR(p)); - } - } - } - else if (t == type_closure) - { - ptr code = CLOSCODE(p); - code = vfasl_relocate_code(vfi, code); - if ((CODETYPE(code)) & (code_flag_continuation << code_flags_offset)) - { - vfasl_fail(vfi, "closure"); - return(0); - } - else - { - if ((CODETYPE(code)) & (code_flag_mutable_closure << code_flags_offset)) - { - vfasl_fail(vfi, "mutable closure"); - return(0); - } - { - uptr len = CODEFREE(code); - { - uptr p_sz = size_closure(len); - result_sz = p_sz; - { - ptr rel_code = (ptr)(ptr_diff(code, vfi -> base_addr)); - SETCLOSCODE(p, rel_code); - { - uptr idx, p_len = len; - ptr *p_p = &CLOSIT(p, 0); - for (idx = 0; idx < p_len; idx++) - { - vfasl_relocate(vfi, &(p_p[idx])); - } - } - } - } - } - } - } - else if (t == type_symbol) - { - uptr p_sz = size_symbol; - result_sz = p_sz; - vfasl_relocate(vfi, &INITSYMPLIST(p)); - vfasl_relocate(vfi, &INITSYMNAME(p)); - vfasl_relocate(vfi, &INITSYMSPLIST(p)); - vfasl_relocate(vfi, &INITSYMHASH(p)); - } - else if (t == type_flonum) - { - uptr p_sz = size_flonum; - result_sz = p_sz; - } - else - { - S_error_abort("vfasl-sweep: illegal type"); - } - } - return result_sz; -} - diff --git a/src/ChezScheme/c/Makefile.ti3nt b/src/ChezScheme/c/Makefile.ti3nt index 09beea9841..c1450aba97 100644 --- a/src/ChezScheme/c/Makefile.ti3nt +++ b/src/ChezScheme/c/Makefile.ti3nt @@ -53,7 +53,7 @@ csrc=statics.c segment.c alloc.c symbol.c intern.c gcwrapper.c gc-011.c gc-par.c windows.c\ schlib.c thread.c expeditor.c scheme.c compress-io.c random.c -cobj=statics.obj segment.obj alloc.obj symbol.obj intern.obj gcwrapper.obj gc-011.c gc-par.obj gc-oce.obj gc-ocd.obj\ +cobj=statics.obj segment.obj alloc.obj symbol.obj intern.obj gcwrapper.obj gc-011.obj gc-par.obj gc-oce.obj gc-ocd.obj\ number.obj schsig.obj io.obj new-io.obj print.obj fasl.obj vfasl.obj stats.obj\ foreign.obj prim.obj prim5.obj flushcache.obj\ windows.obj\ diff --git a/src/ChezScheme/c/Mf-a6fb b/src/ChezScheme/c/Mf-a6fb index 071326ba93..51c51f8017 100644 --- a/src/ChezScheme/c/Mf-a6fb +++ b/src/ChezScheme/c/Mf-a6fb @@ -17,8 +17,6 @@ m ?= a6fb Cpu ?= X86_64 mdinclude = -I/usr/local/include -I/usr/X11R6/include -mdclib = -L/usr/local/lib -liconv -lm ${ncursesLib} ${threadLibs} -C = ${CC} ${CPPFLAGS} ${warningFlags} ${optFlags} ${threadFlags} ${CFLAGS} o = o mdsrc ?= i3le.c mdobj ?= i3le.o @@ -38,10 +36,10 @@ ${KernelLib}: ${kernelobj} ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} ${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} - $C -rdynamic -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} + $C -o ${Scheme} ${Main} ${Kernel} ${KernelLinkLibs} ${LDFLAGS} ${LIBS} ../zlib/configure.log: - (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags} -m64" ./configure --64) + (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS}" ./configure --64) ../lz4/lib/liblz4.a: ${LZ4Sources} - (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags} -m64" ${MAKE} liblz4.a) + (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS}" ${MAKE} liblz4.a) diff --git a/src/ChezScheme/c/Mf-a6le b/src/ChezScheme/c/Mf-a6le index 9e1b783388..e9705e9111 100644 --- a/src/ChezScheme/c/Mf-a6le +++ b/src/ChezScheme/c/Mf-a6le @@ -16,8 +16,6 @@ m ?= a6le Cpu ?= X86_64 -mdclib = -lm -ldl ${ncursesLib} ${threadLibs} -lrt -C = ${CC} ${CPPFLAGS} -m64 -msse2 ${warningFlags} ${optFlags} ${threadFlags} ${CFLAGS} o = o mdsrc ?= i3le.c mdobj ?= i3le.o @@ -37,10 +35,10 @@ ${KernelLib}: ${kernelobj} ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} ${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} - $C -rdynamic -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} + $C -o ${Scheme} ${Main} ${Kernel} ${KernelLinkLibs} ${LDFLAGS} ${LIBS} ../zlib/configure.log: - (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags} -m64" ./configure --64) + (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS}" ./configure --64) ../lz4/lib/liblz4.a: ${LZ4Sources} - (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags} -m64" ${MAKE} liblz4.a) + (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS}" ${MAKE} liblz4.a) diff --git a/src/ChezScheme/c/Mf-a6nb b/src/ChezScheme/c/Mf-a6nb index 07657aebb7..81a9983f71 100644 --- a/src/ChezScheme/c/Mf-a6nb +++ b/src/ChezScheme/c/Mf-a6nb @@ -17,8 +17,6 @@ m ?= a6nb Cpu ?= X86_64 mdinclude = -I/usr/X11R7/include -I/usr/pkg/include -I/usr/pkg/include/ncurses -I/usr/local/include -I/usr/X11R6/include -mdclib = /usr/lib/i18n/libiconv_std.a -lm /usr/pkg/lib/libncurses.a ${threadLibs} -C = ${CC} ${CPPFLAGS} -m64 ${warningFlags} ${optFlags} -O ${threadFlags} ${CFLAGS} o = o mdsrc ?= i3le.c mdobj ?= i3le.o @@ -38,11 +36,11 @@ ${KernelLib}: ${kernelobj} ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} ${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} - $C -rdynamic -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} + $C -o ${Scheme} ${Main} ${Kernel} ${KernelLinkLibs} ${LDFLAGS} ${LIBS} paxctl +m ${Scheme} ../zlib/configure.log: - (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags} -m64" ./configure --64) + (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS}" ./configure --64) ../lz4/lib/liblz4.a: ${LZ4Sources} - (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags} -m64" ${MAKE} liblz4.a) + (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS}" ${MAKE} liblz4.a) diff --git a/src/ChezScheme/c/Mf-a6nt b/src/ChezScheme/c/Mf-a6nt index 0068e1ff66..19e3e98967 100644 --- a/src/ChezScheme/c/Mf-a6nt +++ b/src/ChezScheme/c/Mf-a6nt @@ -39,10 +39,8 @@ make.bat: vs.bat # ------------------------------------------------------- # For cross-compilation, triggered by setting cross=t o=o -C = ${CC} ${CPPFLAGS} ${warningFlags} ${optFlags} ${CFLAGS} - ${Scheme}${cross:t=}: ${Main} ${Kernel} ${KernelLinkDeps} - $C -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} -lshell32 -luser32 -lole32 -lrpcrt4 -luuid + $C -o ${Scheme} ${Main} ${Kernel} ${KernelLinkLibs} ${LDFLAGS} ${LIBS} .c.$o: $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c diff --git a/src/ChezScheme/c/Mf-a6ob b/src/ChezScheme/c/Mf-a6ob index 40b2ee4795..19e843aa29 100644 --- a/src/ChezScheme/c/Mf-a6ob +++ b/src/ChezScheme/c/Mf-a6ob @@ -17,8 +17,6 @@ m ?= a6ob Cpu ?= X86_64 mdinclude = -I/usr/local/include -I/usr/X11R6/include -mdclib = -L/usr/local/lib -liconv -lm ${ncursesLib} ${threadLibs} -C = ${CC} ${CPPFLAGS} ${warningFlags} ${optFlags} ${threadFlags} ${CFLAGS} o = o mdsrc ?= i3le.c mdobj ?= i3le.o @@ -38,10 +36,10 @@ ${KernelLib}: ${kernelobj} ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} ${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} - $C -rdynamic -Wl,--export-dynamic -Wl,-zwxneeded -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} + $C -o ${Scheme} ${Main} ${Kernel} ${KernelLinkLibs} ${LDFLAGS} ${LIBS} ../zlib/configure.log: - (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags} -m64" ./configure --64) + (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS}" ./configure --64) ../lz4/lib/liblz4.a: ${LZ4Sources} - (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags} -m64" ${MAKE} liblz4.a) + (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS}" ${MAKE} liblz4.a) diff --git a/src/ChezScheme/c/Mf-a6osx b/src/ChezScheme/c/Mf-a6osx index deb4576d14..247d52d2d3 100644 --- a/src/ChezScheme/c/Mf-a6osx +++ b/src/ChezScheme/c/Mf-a6osx @@ -16,8 +16,7 @@ m ?= a6osx Cpu ?= X86_64 -mdclib = -liconv -lm ${ncursesLib} -C = ${CC} ${CPPFLAGS} -m64 ${warningFlags} ${optFlags} -I/opt/X11/include/ ${CFLAGS} +mdinclude = -I/opt/X11/include/ o = o mdsrc ?= i3le.c mdobj ?= i3le.o @@ -26,7 +25,7 @@ mdobj ?= i3le.o .SUFFIXES: .c .o .c.o: - $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c + $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} ${mdinclude} $*.c include Mf-base @@ -37,10 +36,10 @@ ${KernelLib}: ${kernelobj} ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} ${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} - $C -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} + $C -o ${Scheme} ${Main} ${Kernel} ${KernelLinkLibs} ${LDFLAGS} ${LIBS} ../zlib/configure.log: - (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags} -m64" ./configure --64) + (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS}" ./configure --64) ../lz4/lib/liblz4.a: ${LZ4Sources} - (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags} -m64" ${MAKE} liblz4.a) + (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS}" ${MAKE} liblz4.a) diff --git a/src/ChezScheme/c/Mf-a6s2 b/src/ChezScheme/c/Mf-a6s2 index e0150a8ca7..b497e190c9 100644 --- a/src/ChezScheme/c/Mf-a6s2 +++ b/src/ChezScheme/c/Mf-a6s2 @@ -16,8 +16,6 @@ m ?= a6s2 Cpu ?= X86_64 -mdclib = -lnsl -ldl -lm ${threadLibs} ${cursesLib} -lrt -C = ${CC} ${CPPFLAGS} -m64 ${warningFlags} ${optFlags} ${threadFlags} ${CFLAGS} o = o mdsrc ?= i3le.c mdobj ?= i3le.o @@ -37,10 +35,10 @@ ${KernelLib}: ${kernelobj} ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} ${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} - $C -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} + $C -o ${Scheme} ${Main} ${Kernel} ${KernelLinkLibs} ${LDFLAGS} ${LIBS} ../zlib/configure.log: - (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags} -m64" ./configure --64) + (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS}" ./configure --64) ../lz4/lib/liblz4.a: ${LZ4Sources} - (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags} -m64" ${MAKE} liblz4.a) + (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS}" ${MAKE} liblz4.a) diff --git a/src/ChezScheme/c/Mf-arm32le b/src/ChezScheme/c/Mf-arm32le index d87df071b6..9d095d2367 100644 --- a/src/ChezScheme/c/Mf-arm32le +++ b/src/ChezScheme/c/Mf-arm32le @@ -16,8 +16,6 @@ m ?= arm32le Cpu ?= ARMV6 -mdclib = -lm -ldl ${ncursesLib} ${threadLibs} -lrt -C = ${CC} ${CPPFLAGS} ${warningFlags} ${optFlags} ${CFLAGS} o = o mdsrc ?= arm32le.c mdobj ?= arm32le.o @@ -37,10 +35,10 @@ ${KernelLib}: ${kernelobj} ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} ${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} - $C -rdynamic -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} + $C -o ${Scheme} ${Main} ${Kernel} ${KernelLinkLibs} ${LDFLAGS} ${LIBS} ../zlib/configure.log: - (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags}" ./configure) + (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS}" ./configure) ../lz4/lib/liblz4.a: ${LZ4Sources} - (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags}" ${MAKE} liblz4.a) + (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS}" ${MAKE} liblz4.a) diff --git a/src/ChezScheme/c/Mf-arm64le b/src/ChezScheme/c/Mf-arm64le index ec1d40f8fe..2bb34e21c5 100644 --- a/src/ChezScheme/c/Mf-arm64le +++ b/src/ChezScheme/c/Mf-arm64le @@ -16,8 +16,6 @@ m ?= tarm64le Cpu ?= AARCH64 -mdclib = -lm -ldl ${ncursesLib} -lrt ${threadLibs} -C = ${CC} ${CPPFLAGS} ${warningFlags} ${optFlags} ${CFLAGS} o = o mdsrc ?= arm32le.c mdobj ?= arm32le.o @@ -37,10 +35,10 @@ ${KernelLib}: ${kernelobj} ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} ${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} - $C -rdynamic -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} + $C -o ${Scheme} ${Main} ${Kernel} ${KernelLinkLibs} ${LDFLAGS} ${LIBS} ../zlib/configure.log: - (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags}" ./configure) + (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS}" ./configure) ../lz4/lib/liblz4.a: ${LZ4Sources} - (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags}" ${MAKE} liblz4.a) + (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS}" ${MAKE} liblz4.a) diff --git a/src/ChezScheme/c/Mf-arm64osx b/src/ChezScheme/c/Mf-arm64osx new file mode 100644 index 0000000000..d73163a0b3 --- /dev/null +++ b/src/ChezScheme/c/Mf-arm64osx @@ -0,0 +1,45 @@ +# Mf-a6osx +# Copyright 1984-2017 Cisco Systems, Inc. +# +# Licensed under the Apache License, Version 2.0 (the "License"); +# you may not use this file except in compliance with the License. +# You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. + +m ?= arm64osx +Cpu ?= AARCH64 + +mdinclude = -I/opt/X11/include/ +o = o +mdsrc ?= arm32le.c +mdobj ?= arm32le.o + +.SUFFIXES: +.SUFFIXES: .c .o + +.c.o: + $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} ${mdinclude} $*.c + +include Mf-base + +${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} + ${LD} -r -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} + +${KernelLib}: ${kernelobj} + ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} + +${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} + $C -o ${Scheme} ${Main} ${Kernel} ${KernelLinkLibs} ${LDFLAGS} ${LIBS} + +../zlib/configure.log: + (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS}" ./configure) + +../lz4/lib/liblz4.a: ${LZ4Sources} + (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS}" ${MAKE} liblz4.a) diff --git a/src/ChezScheme/c/Mf-base b/src/ChezScheme/c/Mf-base index 5844703f6c..2dddc636a7 100644 --- a/src/ChezScheme/c/Mf-base +++ b/src/ChezScheme/c/Mf-base @@ -72,7 +72,6 @@ gc-011.o gc-par.o gc-ocd.o gc-oce.o: gc.c gc-011.o gc-ocd.o: ${Include}/gc-ocd.inc gc-oce.o: ${Include}/gc-oce.inc gc-par.o: ${Include}/gc-par.inc -vfasl.o: ${Include}/vfasl.inc gcwrapper.o: ${Include}/heapcheck.inc ../zlib/zlib.h ../zlib/zconf.h: ../zlib/configure.log @@ -84,6 +83,10 @@ LZ4Sources=../lz4/lib/lz4.h ../lz4/lib/lz4frame.h \ ../lz4/lib/lz4.c ../lz4/lib/lz4frame.c \ ../lz4/lib/lz4hc.c ../lz4/lib/xxhash.c +.PHONY: run +run: + env SCHEMEHEAPDIRS=../boot/$m/ ../bin/$m/scheme $(ARGS) + clean: rm -f *.$o ${mdclean} rm -f Make.out diff --git a/src/ChezScheme/c/Mf-i3fb b/src/ChezScheme/c/Mf-i3fb index a604efa732..eb21e1118c 100644 --- a/src/ChezScheme/c/Mf-i3fb +++ b/src/ChezScheme/c/Mf-i3fb @@ -17,8 +17,6 @@ m ?= i3fb Cpu ?= I386 mdinclude = -I/usr/local/include -I/usr/X11R6/include -mdclib = -L/usr/local/lib -liconv -lm ${ncursesLib} ${threadLibs} -C = ${CC} ${CPPFLAGS} ${warningFlags} ${optFlags} ${threadFlags} ${CFLAGS} o = o mdsrc ?= i3le.c mdobj ?= i3le.o @@ -38,10 +36,10 @@ ${KernelLib}: ${kernelobj} ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} ${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} - $C -rdynamic -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} + $C -o ${Scheme} ${Main} ${Kernel} ${KernelLinkLibs} ${LDFLAGS} ${LIBS} ../zlib/configure.log: - (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags} -m32" ./configure) + (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS}" ./configure) ../lz4/lib/liblz4.a: ${LZ4Sources} - (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags} -m32" ${MAKE} liblz4.a) + (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS}" ${MAKE} liblz4.a) diff --git a/src/ChezScheme/c/Mf-i3le b/src/ChezScheme/c/Mf-i3le index 6a8e95fa26..801f9bf447 100644 --- a/src/ChezScheme/c/Mf-i3le +++ b/src/ChezScheme/c/Mf-i3le @@ -16,8 +16,6 @@ m ?= i3le Cpu ?= I386 -mdclib = -lm -ldl ${ncursesLib} ${threadLibs} -lrt -C = ${CC} ${CPPFLAGS} -m32 -msse2 ${warningFlags} ${optFlags} ${threadFlags} ${CFLAGS} o = o mdsrc ?= i3le.c mdobj ?= i3le.o @@ -37,10 +35,10 @@ ${KernelLib}: ${kernelobj} ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} ${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} - $C -rdynamic -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} + $C -o ${Scheme} ${Main} ${Kernel} ${KernelLinkLibs} ${LDFLAGS} ${LIBS} ../zlib/configure.log: - (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags} -m32" ./configure) + (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS}" ./configure) ../lz4/lib/liblz4.a: ${LZ4Sources} - (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags} -m32" ${MAKE} liblz4.a) + (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS}" ${MAKE} liblz4.a) diff --git a/src/ChezScheme/c/Mf-i3nb b/src/ChezScheme/c/Mf-i3nb index 70428c0203..84d10bdf66 100644 --- a/src/ChezScheme/c/Mf-i3nb +++ b/src/ChezScheme/c/Mf-i3nb @@ -17,8 +17,6 @@ m ?= i3nb Cpu ?= I386 mdinclude = -I/usr/X11R7/include -I/usr/pkg/include -I/usr/pkg/include/ncurses -I/usr/X11R6/include -mdclib = /usr/lib/i18n/libiconv_std.a -lm ${threadLibs} /usr/pkg/lib/libncurses.a -C = ${CC} ${CPPFLAGS} ${warningFlags} ${optFlags} ${threadFlags} ${CFLAGS} o = o mdsrc ?= i3le.c mdobj ?= i3le.o @@ -38,11 +36,11 @@ ${KernelLib}: ${kernelobj} ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} ${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} - $C -rdynamic -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} + $C -o ${Scheme} ${Main} ${Kernel} ${KernelLinkLibs} ${LDFLAGS} ${LIBS} paxctl +m ${Scheme} ../zlib/configure.log: - (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags} -m32" ./configure) + (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS}" ./configure) ../lz4/lib/liblz4.a: ${LZ4Sources} - (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags} -m32" ${MAKE} liblz4.a) + (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS}" ${MAKE} liblz4.a) diff --git a/src/ChezScheme/c/Mf-i3nt b/src/ChezScheme/c/Mf-i3nt index b7dfd41b1f..b7bd5bc32d 100644 --- a/src/ChezScheme/c/Mf-i3nt +++ b/src/ChezScheme/c/Mf-i3nt @@ -39,13 +39,13 @@ make.bat: vs.bat # ------------------------------------------------------- # For cross-compilation, triggered by setting cross=t o=o -C = ${CC} ${CPPFLAGS} ${warningFlags} ${optFlags} ${CFLAGS} -D__MINGW_USE_VC2005_COMPAT +MORE_CFLAGS = -D__MINGW_USE_VC2005_COMPAT ${Scheme}${cross:t=}: ${Main} ${Kernel} ${KernelLinkDeps} - $C -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} -lshell32 -luser32 -lole32 -lrpcrt4 -luuid + $C ${MORE_CFLAGS} -o ${Scheme} ${Main} ${Kernel} ${KernelLinkLibs} ${LDFLAGS} ${LIBS} .c.$o: - $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c + $C ${MORE_CFLAGS} -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c ${KernelLib}: ${kernelobj} ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} diff --git a/src/ChezScheme/c/Mf-i3ob b/src/ChezScheme/c/Mf-i3ob index 59204ea5ba..6bb27a47e0 100644 --- a/src/ChezScheme/c/Mf-i3ob +++ b/src/ChezScheme/c/Mf-i3ob @@ -17,8 +17,6 @@ m ?= i3ob Cpu ?= I386 mdinclude = -I/usr/local/include -I/usr/X11R6/include -mdclib = -L/usr/local/lib -liconv -lm ${ncursesLib} ${threadLibs} -C = ${CC} ${CPPFLAGS} ${warningFlags} ${optFlags} ${threadFlags} ${CFLAGS} o = o mdsrc ?= i3le.c mdobj ?= i3le.o @@ -38,10 +36,10 @@ ${KernelLib}: ${kernelobj} ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} ${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} - $C -rdynamic -Wl,--export-dynamic -Wl,-zwxneeded -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} + $C -o ${Scheme} ${Main} ${Kernel} ${KernelLinkLibs} ${LDFLAGS} ${LIBS} ../zlib/configure.log: - (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags} -m32" ./configure) + (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS}" ./configure) ../lz4/lib/liblz4.a: ${LZ4Sources} - (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags} -m32" ${MAKE} liblz4.a) + (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS}" ${MAKE} liblz4.a) diff --git a/src/ChezScheme/c/Mf-i3osx b/src/ChezScheme/c/Mf-i3osx index 5f9be957a7..710e9ec515 100644 --- a/src/ChezScheme/c/Mf-i3osx +++ b/src/ChezScheme/c/Mf-i3osx @@ -16,8 +16,7 @@ m ?= i3osx Cpu ?= I386 -mdclib = -liconv -lm ${ncursesLib} -C = ${CC} ${CPPFLAGS} -m32 -msse2 ${warningFlags} ${optFlags} -I/opt/X11/include/ ${CFLAGS} +mdinclude = -I/opt/X11/include/ o = o mdsrc ?= i3le.c mdobj ?= i3le.o @@ -26,7 +25,7 @@ mdobj ?= i3le.o .SUFFIXES: .c .o .c.o: - $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c + $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} ${mdinclude} $*.c include Mf-base @@ -37,10 +36,10 @@ ${KernelLib}: ${kernelobj} ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} ${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} - $C -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} + $C -o ${Scheme} ${Main} ${Kernel} ${KernelLinkLibs} ${LDFLAGS} ${LIBS} ../zlib/configure.log: - (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags} -m32" ./configure) + (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS}" ./configure) ../lz4/lib/liblz4.a: ${LZ4Sources} - (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags} -m32" ${MAKE} liblz4.a) + (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS}" ${MAKE} liblz4.a) diff --git a/src/ChezScheme/c/Mf-i3qnx b/src/ChezScheme/c/Mf-i3qnx index ef2f87952b..3395c6ce50 100644 --- a/src/ChezScheme/c/Mf-i3qnx +++ b/src/ChezScheme/c/Mf-i3qnx @@ -16,8 +16,6 @@ m ?= i3qnx Cpu ?= I386 -mdclib = -lm /usr/local/lib/libiconv.so -lsocket ${ncursesLib} -C = qcc ${CPPFLAGS} -m32 -N2048K ${warningFlags} ${optFlags} ${CFLAGS} o = o mdsrc ?= i3le.c mdobj ?= i3le.o @@ -38,10 +36,10 @@ ${KernelLib}: ${kernelobj} ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} ${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} - $C -Wl,--export-dynamic -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} + $C -Wl,--export-dynamic -o ${Scheme} ${Main} ${Kernel} ${KernelLinkLibs} ${LDFLAGS} ${LIBS} ../zlib/configure.log: - (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} -m32" ./configure) + (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS}" ./configure) ../lz4/lib/liblz4.a: ${LZ4Sources} - (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} -m32" ${MAKE} liblz4.a) + (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS}" ${MAKE} liblz4.a) diff --git a/src/ChezScheme/c/Mf-i3s2 b/src/ChezScheme/c/Mf-i3s2 index 9f30aa1ca0..24930a36f2 100644 --- a/src/ChezScheme/c/Mf-i3s2 +++ b/src/ChezScheme/c/Mf-i3s2 @@ -16,8 +16,6 @@ m ?= i3s2 Cpu ?= I386 -mdclib = -lnsl -ldl -lm ${cursesLib} ${threadLibs} -lrt -C = ${CC} ${CFLAGS} -m32 ${warningFlags} ${optFlags} ${threadFlags} ${CPPFLAGS} o = o mdsrc ?= i3le.c mdobj ?= i3le.o @@ -37,10 +35,10 @@ ${KernelLib}: ${kernelobj} ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} ${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} - $C -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} + $C -o ${Scheme} ${Main} ${Kernel} ${KernelLinkLibs} ${LDFLAGS} ${LIBS} ../zlib/configure.log: - (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} -m32" ./configure) + (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS}" ./configure) ../lz4/lib/liblz4.a: ${LZ4Sources} - (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} -m32" ${MAKE} liblz4.a) + (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS}" ${MAKE} liblz4.a) diff --git a/src/ChezScheme/c/Mf-ppc32le b/src/ChezScheme/c/Mf-ppc32le index 0dde10b84e..6cd75d8a16 100644 --- a/src/ChezScheme/c/Mf-ppc32le +++ b/src/ChezScheme/c/Mf-ppc32le @@ -16,8 +16,6 @@ m ?= ppc32le Cpu ?= PPC32 -mdclib = -lm -ldl ${ncursesLib} -lrt ${threadLibs} -C = ${CC} ${CPPFLAGS} -m32 ${warningFlags} ${optFlags} ${threadFlags} ${CFLAGS} o = o mdsrc ?= ppc32.c mdobj ?= ppc32.o @@ -37,10 +35,10 @@ ${KernelLib}: ${kernelobj} ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} ${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} - $C -rdynamic -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} + $C -o ${Scheme} ${Main} ${Kernel} ${KernelLinkLibs} ${LDFLAGS} ${LIBS} ../zlib/configure.log: - (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags} -m32" ./configure) + (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS}" ./configure) ../lz4/lib/liblz4.a: ${LZ4Sources} - (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags} -m32" ${MAKE} liblz4.a) + (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS}" ${MAKE} liblz4.a) diff --git a/src/ChezScheme/c/Mf-ppc32osx b/src/ChezScheme/c/Mf-ppc32osx new file mode 100644 index 0000000000..e6efbb1a54 --- /dev/null +++ b/src/ChezScheme/c/Mf-ppc32osx @@ -0,0 +1,32 @@ +# Mf-ppc32osx + +m ?= ppc32osx +Cpu ?= PPC32 + +mdinclude = -I/opt/X11/include/ +o = o +mdsrc ?= ppc32.c +mdobj ?= ppc32.o + +.SUFFIXES: +.SUFFIXES: .c .o + +.c.o: + $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} ${mdinclude} $*.c + +include Mf-base + +${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} + ${LD} -r -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} + +${KernelLib}: ${kernelobj} + ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} + +${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} + $C -o ${Scheme} ${Main} ${Kernel} ${KernelLinkLibs} ${LDFLAGS} ${LIBS} + +../zlib/configure.log: + (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS}" ./configure) + +../lz4/lib/liblz4.a: ${LZ4Sources} + (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS}" ${MAKE} liblz4.a) diff --git a/src/ChezScheme/c/Mf-ta6fb b/src/ChezScheme/c/Mf-ta6fb index 09d333bd9e..dc61083b98 100644 --- a/src/ChezScheme/c/Mf-ta6fb +++ b/src/ChezScheme/c/Mf-ta6fb @@ -2,7 +2,4 @@ m ?= ta6fb -threadLibs = -lpthread -threadFlags = -D_REENTRANT -pthread - include Mf-a6fb diff --git a/src/ChezScheme/c/Mf-ta6le b/src/ChezScheme/c/Mf-ta6le index ccf80f2ec6..8cae7d4fa7 100644 --- a/src/ChezScheme/c/Mf-ta6le +++ b/src/ChezScheme/c/Mf-ta6le @@ -2,7 +2,4 @@ m ?= ta6le -threadLibs = -lpthread -threadFlags = -D_REENTRANT -pthread - include Mf-a6le diff --git a/src/ChezScheme/c/Mf-ta6nb b/src/ChezScheme/c/Mf-ta6nb index 27f9774e1f..bf7af020df 100644 --- a/src/ChezScheme/c/Mf-ta6nb +++ b/src/ChezScheme/c/Mf-ta6nb @@ -1,8 +1,6 @@ + # Mf-ta6nb m ?= ta6nb -threadLibs = -lpthread -threadFlags = -D_REENTRANT -pthread - include Mf-a6nb diff --git a/src/ChezScheme/c/Mf-ta6ob b/src/ChezScheme/c/Mf-ta6ob index 91e30816a4..8c9c96cc85 100644 --- a/src/ChezScheme/c/Mf-ta6ob +++ b/src/ChezScheme/c/Mf-ta6ob @@ -2,7 +2,4 @@ m ?= ta6ob -threadLibs = -lpthread -threadFlags = -D_REENTRANT -pthread - include Mf-a6ob diff --git a/src/ChezScheme/c/Mf-ta6s2 b/src/ChezScheme/c/Mf-ta6s2 index 72ba86dad2..0f53ae4d2c 100644 --- a/src/ChezScheme/c/Mf-ta6s2 +++ b/src/ChezScheme/c/Mf-ta6s2 @@ -2,7 +2,4 @@ m ?= ta6s2 -threadLibs = -lpthread -threadFlags = -D_REENTRANT - include Mf-a6s2 diff --git a/src/ChezScheme/c/Mf-tarm32le b/src/ChezScheme/c/Mf-tarm32le index dec8873185..114107274e 100644 --- a/src/ChezScheme/c/Mf-tarm32le +++ b/src/ChezScheme/c/Mf-tarm32le @@ -2,6 +2,4 @@ m ?= tarm32le -threadLibs = -lpthread - include Mf-arm32le diff --git a/src/ChezScheme/c/Mf-tarm64le b/src/ChezScheme/c/Mf-tarm64le index ff52cd0959..f3b71782f6 100644 --- a/src/ChezScheme/c/Mf-tarm64le +++ b/src/ChezScheme/c/Mf-tarm64le @@ -2,6 +2,4 @@ m ?= tarm64le -threadLibs = -lpthread - include Mf-arm64le diff --git a/src/ChezScheme/c/Mf-tarm64osx b/src/ChezScheme/c/Mf-tarm64osx new file mode 100644 index 0000000000..e4d05eb21f --- /dev/null +++ b/src/ChezScheme/c/Mf-tarm64osx @@ -0,0 +1,5 @@ +# Mf-tarm64osx + +m ?= tarm64osx + +include Mf-arm64osx diff --git a/src/ChezScheme/c/Mf-ti3fb b/src/ChezScheme/c/Mf-ti3fb index 11a90f5f44..e2d380dad6 100644 --- a/src/ChezScheme/c/Mf-ti3fb +++ b/src/ChezScheme/c/Mf-ti3fb @@ -2,7 +2,4 @@ m ?= ti3fb -threadLibs = -lpthread -threadFlags = -D_REENTRANT -pthread - include Mf-i3fb diff --git a/src/ChezScheme/c/Mf-ti3le b/src/ChezScheme/c/Mf-ti3le index 5aa4ba4133..606a736b77 100644 --- a/src/ChezScheme/c/Mf-ti3le +++ b/src/ChezScheme/c/Mf-ti3le @@ -2,7 +2,4 @@ m ?= ti3le -threadLibs = -lpthread -threadFlags = -D_REENTRANT -pthread - include Mf-i3le diff --git a/src/ChezScheme/c/Mf-ti3nb b/src/ChezScheme/c/Mf-ti3nb index b1100f95d6..e32895d500 100644 --- a/src/ChezScheme/c/Mf-ti3nb +++ b/src/ChezScheme/c/Mf-ti3nb @@ -2,7 +2,4 @@ m ?= ti3nb -threadLibs = -lpthread -threadFlags = -D_REENTRANT -pthread - include Mf-i3nb diff --git a/src/ChezScheme/c/Mf-ti3ob b/src/ChezScheme/c/Mf-ti3ob index d0cbfbf71c..bc3c1afd82 100644 --- a/src/ChezScheme/c/Mf-ti3ob +++ b/src/ChezScheme/c/Mf-ti3ob @@ -2,7 +2,4 @@ m ?= ti3ob -threadLibs = -lpthread -threadFlags = -D_REENTRANT -pthread - include Mf-i3ob diff --git a/src/ChezScheme/c/Mf-ti3s2 b/src/ChezScheme/c/Mf-ti3s2 index 970c5c0070..b73c553688 100644 --- a/src/ChezScheme/c/Mf-ti3s2 +++ b/src/ChezScheme/c/Mf-ti3s2 @@ -2,7 +2,4 @@ m ?= ti3s2 -threadLibs = -lpthread -threadFlags = -D_REENTRANT - include Mf-i3s2 diff --git a/src/ChezScheme/c/Mf-tppc32le b/src/ChezScheme/c/Mf-tppc32le index 6da0615e86..b3c7f071b4 100644 --- a/src/ChezScheme/c/Mf-tppc32le +++ b/src/ChezScheme/c/Mf-tppc32le @@ -2,7 +2,4 @@ m ?= tppc32le -threadLibs = -lpthread -threadFlags = -D_REENTRANT -pthread - include Mf-ppc32le diff --git a/src/ChezScheme/c/Mf-tppc32osx b/src/ChezScheme/c/Mf-tppc32osx new file mode 100644 index 0000000000..2a1a6584ed --- /dev/null +++ b/src/ChezScheme/c/Mf-tppc32osx @@ -0,0 +1,5 @@ +# Mf-tppc32osx + +m ?= tppc32osx + +include Mf-ppc32osx diff --git a/src/ChezScheme/c/alloc.c b/src/ChezScheme/c/alloc.c index 4c83c5c050..cbeac73d54 100644 --- a/src/ChezScheme/c/alloc.c +++ b/src/ChezScheme/c/alloc.c @@ -18,7 +18,7 @@ #include "popcount.h" /* locally defined functions */ -static void maybe_fire_collector PROTO((void)); +static void maybe_queue_fire_collector(thread_gc *tgc); void S_alloc_init() { ISPC s; IGEN g; UINT i; @@ -60,6 +60,10 @@ void S_alloc_init() { find_room(tc, space_new, 0, type_typed_object, size_fxvector(0), S_G.null_fxvector); FXVECTOR_TYPE(S_G.null_fxvector) = (0 << fxvector_length_offset) | type_fxvector; + S_protect(&S_G.null_flvector); + find_room(tc, space_new, 0, type_typed_object, size_flvector(0), S_G.null_flvector); + FXVECTOR_TYPE(S_G.null_flvector) = (0 << flvector_length_offset) | type_flvector; + S_protect(&S_G.null_bytevector); find_room(tc, space_new, 0, type_typed_object, size_bytevector(0), S_G.null_bytevector); BYTEVECTOR_TYPE(S_G.null_bytevector) = (0 << bytevector_length_offset) | type_bytevector; @@ -72,10 +76,6 @@ void S_alloc_init() { find_room(tc, space_new, 0, type_typed_object, size_vector(0), S_G.null_immutable_vector); VECTTYPE(S_G.null_immutable_vector) = (0 << vector_length_offset) | type_vector | vector_immutable_flag; - S_protect(&S_G.null_immutable_fxvector); - find_room(tc, space_new, 0, type_typed_object, size_fxvector(0), S_G.null_immutable_fxvector); - FXVECTOR_TYPE(S_G.null_immutable_fxvector) = (0 << fxvector_length_offset) | type_fxvector | fxvector_immutable_flag; - S_protect(&S_G.null_immutable_bytevector); find_room(tc, space_new, 0, type_typed_object, size_bytevector(0), S_G.null_immutable_bytevector); BYTEVECTOR_TYPE(S_G.null_immutable_bytevector) = (0 << bytevector_length_offset) | type_bytevector | bytevector_immutable_flag; @@ -96,7 +96,6 @@ void S_protect(p) ptr *p; { S_G.protected[S_G.protect_next++] = p; } -/* S_reset_scheme_stack is always called with mutex */ void S_reset_scheme_stack(tc, n) ptr tc; iptr n; { ptr *x; iptr m; @@ -137,6 +136,9 @@ ptr S_compute_bytes_allocated(xg, xs) ptr xg; ptr xs; { ISPC s, smax, smin; IGEN g, gmax, gmin; uptr n; + tc_mutex_acquire(); + alloc_mutex_acquire(); + gmin = (IGEN)UNFIX(xg); if (gmin < 0) { gmin = 0; @@ -180,6 +182,9 @@ ptr S_compute_bytes_allocated(xg, xs) ptr xg; ptr xs; { if (gmin == 0 && smin <= space_new && space_new <= smax) n -= (uptr)REAL_EAP(tc) - (uptr)AP(tc); + alloc_mutex_release(); + tc_mutex_release(); + return Sunsigned(n); } @@ -187,12 +192,22 @@ ptr S_bytes_finalized() { return Sunsigned(S_G.bytes_finalized); } -static void maybe_fire_collector() { +/* called with alloc mutex */ +static void maybe_queue_fire_collector(thread_gc *tgc) { if ((S_G.bytes_of_generation[0] + S_G.bytesof[0][countof_phantom]) - S_G.g0_bytes_after_last_gc >= S_G.collect_trip_bytes) - S_fire_collector(); + tgc->queued_fire = 1; } -/* suitable mutex (either tc_mutex or gc_tc_mutex) must be held */ +void S_maybe_fire_collector(thread_gc *tgc) { + if ((tgc->during_alloc == 0) && (!IS_ALLOC_MUTEX_OWNER() || IS_TC_MUTEX_OWNER())) { + if (tgc->queued_fire) { + tgc->queued_fire = 0; + S_fire_collector(); + } + } +} + +/* allocation mutex must be held (or single-threaded guaranteed because collecting) */ static void close_off_segment(thread_gc *tgc, ptr old, ptr base_loc, ptr sweep_loc, ISPC s, IGEN g) { if (base_loc) { @@ -219,18 +234,11 @@ ptr S_find_more_gc_room(thread_gc *tgc, ISPC s, IGEN g, iptr n, ptr old) { ptr new; iptr new_bytes; -#ifdef PTHREADS - if (S_use_gc_tc_mutex) - gc_tc_mutex_acquire(); - else - tc_mutex_acquire(); -#else - tc_mutex_acquire(); -#endif + alloc_mutex_acquire(); close_off_segment(tgc, old, tgc->base_loc[g][s], tgc->sweep_loc[g][s], s, g); - S_pants_down += 1; + tgc->during_alloc += 1; nsegs = (uptr)(n + ptr_bytes + bytes_per_segment - 1) >> segment_offset_bits; @@ -247,23 +255,17 @@ ptr S_find_more_gc_room(thread_gc *tgc, ISPC s, IGEN g, iptr n, ptr old) { tgc->bytes_left[g][s] = (new_bytes - n) - ptr_bytes; tgc->next_loc[g][s] = (ptr)((uptr)new + n); - if (g == 0 && S_pants_down == 1) maybe_fire_collector(); + if (tgc->during_alloc == 1) maybe_queue_fire_collector(tgc); - S_pants_down -= 1; + tgc->during_alloc -= 1; + + alloc_mutex_release(); + S_maybe_fire_collector(tgc); -#ifdef PTHREADS - if (S_use_gc_tc_mutex) - gc_tc_mutex_release(); - else - tc_mutex_release(); -#else - tc_mutex_release(); -#endif - return new; } -/* tc_mutex must be held */ +/* allocation mutex must be held (or single-threaded guaranteed because collecting) */ void S_close_off_thread_local_segment(ptr tc, ISPC s, IGEN g) { thread_gc *tgc = THREAD_GC(tc); @@ -275,7 +277,8 @@ void S_close_off_thread_local_segment(ptr tc, ISPC s, IGEN g) { tgc->sweep_loc[g][s] = (ptr)0; } -/* S_reset_allocation_pointer is always called with mutex */ +/* S_reset_allocation_pointer is always called with allocation mutex + (or single-threaded guaranteed because collecting) */ /* We always allocate exactly one segment for the allocation area, since we can get into hot water with formerly locked objects, specifically symbols and impure records, that cross segment boundaries. This allows @@ -287,10 +290,11 @@ void S_close_off_thread_local_segment(ptr tc, ISPC s, IGEN g) { void S_reset_allocation_pointer(tc) ptr tc; { iptr seg; + thread_gc *tgc = THREAD_GC(tc); - S_pants_down += 1; + tgc->during_alloc += 1; - seg = S_find_segments(THREAD_GC(tc), space_new, 0, 1); + seg = S_find_segments(tgc, space_new, 0, 1); /* NB: if allocate_segments didn't already ensure we don't use the last segment of memory, we'd have to reject it here so cp2-alloc can avoid a carry check for @@ -303,19 +307,19 @@ void S_reset_allocation_pointer(tc) ptr tc; { S_G.bytes_of_space[0][space_new] += bytes_per_segment; S_G.bytes_of_generation[0] += bytes_per_segment; - if (S_pants_down == 1) maybe_fire_collector(); + if (tgc->during_alloc == 1) maybe_queue_fire_collector(THREAD_GC(tc)); AP(tc) = build_ptr(seg, 0); REAL_EAP(tc) = EAP(tc) = (ptr)((uptr)AP(tc) + bytes_per_segment); - S_pants_down -= 1; + tgc->during_alloc -= 1; } void S_record_new_dirty_card(thread_gc *tgc, ptr *ppp, IGEN to_g) { uptr card = (uptr)TO_PTR(ppp) >> card_offset_bits; dirtycardinfo *ndc; - gc_tc_mutex_acquire(); + alloc_mutex_acquire(); ndc = S_G.new_dirty_cards; if (ndc != NULL && ndc->card == card) { if (to_g < ndc->youngest) ndc->youngest = to_g; @@ -327,9 +331,10 @@ void S_record_new_dirty_card(thread_gc *tgc, ptr *ppp, IGEN to_g) { ndc->next = next; S_G.new_dirty_cards = ndc; } - gc_tc_mutex_release(); + alloc_mutex_release(); } +/* allocation mutex must be held (or only one thread due to call by collector) */ FORCEINLINE void mark_segment_dirty(seginfo *si, IGEN from_g, IGEN to_g) { IGEN old_to_g = si->min_dirty_byte; if (to_g < old_to_g) { @@ -363,13 +368,16 @@ void S_dirty_set(ptr *loc, ptr x) { } else { IGEN from_g = si->generation; if (from_g != 0) { + alloc_mutex_acquire(); si->dirty_bytes[((uptr)TO_PTR(loc) >> card_offset_bits) & ((1 << segment_card_offset_bits) - 1)] = 0; mark_segment_dirty(si, from_g, 0); + alloc_mutex_release(); } } } } +/* only called by GC, so no other thread is running */ void S_mark_card_dirty(uptr card, IGEN to_g) { uptr loc = card << card_offset_bits; uptr seg = addr_get_segment(loc); @@ -381,7 +389,8 @@ void S_mark_card_dirty(uptr card, IGEN to_g) { } } -/* scan remembered set from P to ENDP, transfering to dirty vector */ +/* scan remembered set from P to ENDP, transfering to dirty vector; + allocation mutex must be held */ void S_scan_dirty(ptr *p, ptr *endp) { uptr this, last; @@ -419,7 +428,7 @@ void S_scan_remembered_set() { ptr tc = get_thread_context(); uptr ap, eap, real_eap; - tc_mutex_acquire(); + alloc_mutex_acquire(); ap = (uptr)AP(tc); eap = (uptr)EAP(tc); @@ -438,7 +447,8 @@ void S_scan_remembered_set() { S_reset_allocation_pointer(tc); } - tc_mutex_release(); + alloc_mutex_release(); + S_maybe_fire_collector(THREAD_GC(tc)); } /* S_get_more_room is called from genereated machine code when there is @@ -466,14 +476,7 @@ ptr S_get_more_room_help(ptr tc, uptr ap, uptr type, uptr size) { eap = (uptr)EAP(tc); real_eap = (uptr)REAL_EAP(tc); -#ifdef PTHREADS - if (S_use_gc_tc_mutex) - gc_tc_mutex_acquire(); - else - tc_mutex_acquire(); -#else - tc_mutex_acquire(); -#endif + alloc_mutex_acquire(); S_scan_dirty(TO_VOIDP(eap), TO_VOIDP(real_eap)); eap = real_eap; @@ -508,14 +511,8 @@ ptr S_get_more_room_help(ptr tc, uptr ap, uptr type, uptr size) { } } -#ifdef PTHREADS - if (S_use_gc_tc_mutex) - gc_tc_mutex_release(); - else - tc_mutex_release(); -#else - tc_mutex_release(); -#endif + alloc_mutex_release(); + S_maybe_fire_collector(THREAD_GC(tc)); return x; } @@ -698,12 +695,28 @@ ptr S_fxvector(n) iptr n; { return p; } +ptr S_flvector(n) iptr n; { + ptr tc; + ptr p; iptr d; + + if (n == 0) return S_G.null_flvector; + + if ((uptr)n > (uptr)maximum_flvector_length) + S_error("", "invalid flvector size request"); + + tc = get_thread_context(); + + d = size_flvector(n); + newspace_find_room(tc, type_typed_object, d, p); + FLVECTOR_TYPE(p) = (n << flvector_length_offset) | type_flvector; + return p; +} + ptr S_bytevector(n) iptr n; { - return S_bytevector2(n, 0); + return S_bytevector2(get_thread_context(), n, 0); } -ptr S_bytevector2(n, immobile) iptr n; IBOOL immobile; { - ptr tc; +ptr S_bytevector2(tc, n, immobile) ptr tc; iptr n; IBOOL immobile; { ptr p; iptr d; if (n == 0) return S_G.null_bytevector; @@ -711,8 +724,6 @@ ptr S_bytevector2(n, immobile) iptr n; IBOOL immobile; { if ((uptr)n > (uptr)maximum_bytevector_length) S_error("", "invalid bytevector size request"); - tc = get_thread_context(); - d = size_bytevector(n); if (immobile) find_room(tc, space_immobile_data, 0, type_typed_object, d, p); @@ -730,14 +741,6 @@ ptr S_null_immutable_vector() { return v; } -ptr S_null_immutable_fxvector() { - ptr tc = get_thread_context(); - ptr v; - find_room(tc, space_new, 0, type_typed_object, size_fxvector(0), v); - VECTTYPE(v) = (0 << fxvector_length_offset) | type_fxvector | fxvector_immutable_flag; - return v; -} - ptr S_null_immutable_bytevector() { ptr tc = get_thread_context(); ptr v; @@ -780,7 +783,7 @@ ptr Srecord_type(ptr r) { } ptr Srecord_type_parent(ptr rtd) { - return RECORDDESCPARENT(rtd); + return rtd_parent(rtd); } uptr Srecord_type_size(ptr rtd) { diff --git a/src/ChezScheme/c/arm32le.c b/src/ChezScheme/c/arm32le.c index f2cd6aec3f..085ef0be5b 100644 --- a/src/ChezScheme/c/arm32le.c +++ b/src/ChezScheme/c/arm32le.c @@ -41,11 +41,17 @@ void S_doflush(uptr start, uptr end) { void S_machine_init() { int l1_dcache_line_size, l1_icache_line_size; +#if defined(__linux__) if ((l1_dcache_line_size = sysconf(_SC_LEVEL1_DCACHE_LINESIZE)) <= 0) { l1_dcache_line_size = DEFAULT_L1_MAX_CACHE_LINE_SIZE; } if ((l1_icache_line_size = sysconf(_SC_LEVEL1_ICACHE_LINESIZE)) <= 0) { l1_icache_line_size = DEFAULT_L1_MAX_CACHE_LINE_SIZE; } +#else + l1_dcache_line_size = DEFAULT_L1_MAX_CACHE_LINE_SIZE; + l1_icache_line_size = DEFAULT_L1_MAX_CACHE_LINE_SIZE; +#endif + l1_max_cache_line_size = l1_dcache_line_size > l1_icache_line_size ? l1_dcache_line_size : l1_icache_line_size; } diff --git a/src/ChezScheme/c/atomic.h b/src/ChezScheme/c/atomic.h index ade52a72fa..854de274b5 100644 --- a/src/ChezScheme/c/atomic.h +++ b/src/ChezScheme/c/atomic.h @@ -37,38 +37,38 @@ # define CAS_ANY_FENCE(a, old, new) ((*(a) == (old)) ? (*(a) = (new), 1) : 0) #elif defined(__arm64__) FORCEINLINE int CAS_LOAD_ACQUIRE(volatile void *addr, void *old_val, void *new_val) { - int ret; + long ret; __asm__ __volatile__ ("mov %0, #0\n\t" "0:\n\t" - "ldaxr r12, [%1, #0]\n\t" - "cmp r12, %2\n\t" + "ldaxr x12, [%1, #0]\n\t" + "cmp x12, %2\n\t" "bne 1f\n\t" - "stxr r7, %3, [%1, #0]\n\t" - "cmp r7, #0\n\t" + "stxr x7, %3, [%1, #0]\n\t" + "cmp x7, #0\n\t" "bne 1f\n\t" "moveq %0, #1\n\t" "1:\n\t" : "=&r" (ret) : "r" (addr), "r" (old_val), "r" (new_val) - : "cc", "memory", "r12", "r7"); + : "cc", "memory", "x12", "x7"); return ret; } /* same as above, but ldaxr -> ldxr and stxr -> stlxr */ FORCEINLINE int CAS_STORE_RELEASE(volatile void *addr, void *old_val, void *new_val) { - int ret; + long ret; __asm__ __volatile__ ("mov %0, #0\n\t" "0:\n\t" - "ldxr r12, [%1, #0]\n\t" - "cmp r12, %2\n\t" + "ldxr x12, [%1, #0]\n\t" + "cmp x12, %2\n\t" "bne 1f\n\t" - "stlxr r7, %3, [%1, #0]\n\t" - "cmp r7, #0\n\t" + "stlxr x7, %3, [%1, #0]\n\t" + "cmp x7, #0\n\t" "bne 1f\n\t" "moveq %0, #1\n\t" "1:\n\t" : "=&r" (ret) : "r" (addr), "r" (old_val), "r" (new_val) - : "cc", "memory", "r12", "r7"); + : "cc", "memory", "x12", "x7"); return ret; } #elif defined(__arm__) @@ -83,6 +83,7 @@ FORCEINLINE int S_cas_any_fence(volatile void *addr, void *old_val, void *new_va "strex r7, %3, [%1, #0]\n\t" "cmp r7, #0\n\t" "bne 1f\n\t" + "it eq\n\t" "moveq %0, #1\n\t" "1:\n\t" : "=&r" (ret) diff --git a/src/ChezScheme/c/expeditor.c b/src/ChezScheme/c/expeditor.c index 044ac791e2..6dd849ba34 100644 --- a/src/ChezScheme/c/expeditor.c +++ b/src/ChezScheme/c/expeditor.c @@ -530,21 +530,22 @@ static void s_ee_write_char(wchar_t c) { } #else /* WIN32 */ + #include <limits.h> #ifdef DISABLE_CURSES -#include "nocurses.h" +# include "nocurses.h" #elif defined(SOLARIS) -#define NCURSES_CONST -#define CHTYPE int -#include </usr/include/curses.h> -#include </usr/include/term.h> +# define NCURSES_CONST +# define CHTYPE int +# include </usr/include/curses.h> +# include </usr/include/term.h> #elif defined(NETBSD) -#include <ncurses.h> -#include <ncurses/term.h> -#else /* NETBSD */ -#include <curses.h> -#include <term.h> -#endif /* SOLARIS */ +# include <ncurses.h> +# include <ncurses/term.h> +#else +# include <curses.h> +# include <term.h> +#endif #include <termios.h> #include <signal.h> #include <time.h> @@ -552,12 +553,12 @@ static void s_ee_write_char(wchar_t c) { #include <sys/ioctl.h> #include <wchar.h> #include <locale.h> -#if !defined(__GLIBC__) && !defined(__OpenBSD__) && !defined(__NetBSD__) && !defined(__linux__) -#include <xlocale.h> +#if !defined(__GLIBC__) && !defined(__OpenBSD__) && !defined(__NetBSD__) && !defined(__linux__) && !defined(NO_USELOCALE) +# include <xlocale.h> #endif #if defined(TIOCGWINSZ) && defined(SIGWINCH) && defined(EINTR) -#define HANDLE_SIGWINCH +# define HANDLE_SIGWINCH #endif #ifdef USE_MBRTOWC_L @@ -588,7 +589,9 @@ static void handle_sigwinch(UNUSED int sig) { #define STDOUT_FD 1 static IBOOL disable_auto_margin = 0, avoid_last_column = 0; +#ifndef NO_USELOCALE static locale_t term_locale; +#endif static mbstate_t term_in_mbs; static mbstate_t term_out_mbs; @@ -643,7 +646,9 @@ static IBOOL s_ee_init_term(void) { sigaction(SIGWINCH, &act, (struct sigaction *)0); #endif +#ifndef NO_USELOCALE term_locale = newlocale(LC_ALL_MASK, "", NULL); +#endif memset(&term_out_mbs, 0, sizeof(term_out_mbs)); memset(&term_in_mbs, 0, sizeof(term_in_mbs)); @@ -659,7 +664,6 @@ static IBOOL s_ee_init_term(void) { only if blockp is false */ static ptr s_ee_read_char(IBOOL blockp) { ptr msg; int fd = STDIN_FD; int n; char buf[1]; wchar_t wch; size_t sz; - locale_t old_locale; #ifdef PTHREADS ptr tc = get_thread_context(); #endif @@ -697,14 +701,19 @@ static ptr s_ee_read_char(IBOOL blockp) { if (buf[0] == '\0') { return Schar('\0'); } else { - old_locale = uselocale(term_locale); +#ifndef NO_USELOCALE + locale_t old_locale = uselocale(term_locale); +#endif sz = mbrtowc(&wch, buf, 1, &term_out_mbs); +#ifndef NO_USELOCALE uselocale(old_locale); +#endif if (sz == 1) { return Schar(wch); } } - } + } else + sz = 0; } while ((n < 0 && errno == EINTR) || (n == 1 && sz == (size_t)-2)); @@ -1041,16 +1050,21 @@ static ptr s_ee_get_clipboard(void) { } static void s_ee_write_char(wchar_t wch) { - locale_t old; char buf[MB_LEN_MAX]; size_t n; + char buf[MB_LEN_MAX]; size_t n; +#ifndef NO_USELOCALE + locale_t old = uselocale(term_locale); +#endif - old = uselocale(term_locale); n = wcrtomb(buf, wch, &term_in_mbs); if (n == (size_t)-1) { putchar('?'); } else { fwrite(buf, 1, n, stdout); } + +#ifndef NO_USELOCALE uselocale(old); +#endif } #endif /* WIN32 */ diff --git a/src/ChezScheme/c/externs.h b/src/ChezScheme/c/externs.h index d91936c324..059ed85c4c 100644 --- a/src/ChezScheme/c/externs.h +++ b/src/ChezScheme/c/externs.h @@ -62,7 +62,8 @@ off64_t lseek64(int,off64_t,int); extern void S_alloc_init PROTO((void)); extern void S_protect PROTO((ptr *p)); extern void S_reset_scheme_stack PROTO((ptr tc, iptr n)); -extern void S_reset_allocation_pointer PROTO((ptr tc)); +extern void S_reset_allocation_pointer PROTO((ptr tc)); /* call S_maybe_fire_collector afterward outside alloc mutex */ +extern void S_maybe_fire_collector(thread_gc *tgc); extern ptr S_compute_bytes_allocated PROTO((ptr xg, ptr xs)); extern ptr S_bytes_finalized PROTO(()); extern ptr S_find_more_room PROTO((ISPC s, IGEN g, iptr n, ptr old)); @@ -85,8 +86,9 @@ extern ptr S_tlc PROTO((ptr keyval, ptr tconc, ptr next)); extern ptr S_vector_in PROTO((ptr tc, ISPC s, IGEN g, iptr n)); extern ptr S_vector PROTO((iptr n)); extern ptr S_fxvector PROTO((iptr n)); +extern ptr S_flvector PROTO((iptr n)); extern ptr S_bytevector PROTO((iptr n)); -extern ptr S_bytevector2 PROTO((iptr n, IBOOL immobile)); +extern ptr S_bytevector2 PROTO((ptr tc, iptr n, IBOOL immobile)); extern ptr S_null_immutable_vector PROTO((void)); extern ptr S_null_immutable_fxvector PROTO((void)); extern ptr S_null_immutable_bytevector PROTO((void)); @@ -111,11 +113,11 @@ extern void S_phantom_bytevector_adjust PROTO((ptr ph, uptr new_sz)); /* fasl.c */ extern void S_fasl_init PROTO((void)); -ptr S_fasl_read PROTO((INT fd, IFASLCODE situation, ptr path, ptr externals)); -ptr S_bv_fasl_read PROTO((ptr bv, int ty, uptr offset, uptr len, ptr path, ptr externals)); -ptr S_boot_read PROTO((INT fd, const char *path)); -char *S_format_scheme_version PROTO((uptr n)); -char *S_lookup_machine_type PROTO((uptr n)); +extern ptr S_fasl_read PROTO((INT fd, IFASLCODE situation, ptr path, ptr externals)); +extern ptr S_bv_fasl_read PROTO((ptr bv, int ty, uptr offset, uptr len, ptr path, ptr externals)); +extern ptr S_boot_read PROTO((INT fd, const char *path)); +extern char *S_format_scheme_version PROTO((uptr n)); +extern char *S_lookup_machine_type PROTO((uptr n)); extern void S_set_code_obj PROTO((char *who, IFASLCODE typ, ptr p, iptr n, ptr x, iptr o)); extern ptr S_get_code_obj PROTO((IFASLCODE typ, ptr p, iptr n, iptr o)); @@ -129,10 +131,8 @@ extern void S_swap_dounderflow_header_endian PROTO((ptr code)); #endif /* vfasl.c */ -extern ptr S_to_vfasl PROTO((ptr v)); extern ptr S_vfasl PROTO((ptr bv, void *stream, iptr offset, iptr len)); extern ptr S_vfasl_to PROTO((ptr v)); -extern IBOOL S_vfasl_can_combinep(ptr v); /* flushcache.c */ extern void S_record_code_mod PROTO((ptr tc, uptr addr, uptr bytes)); @@ -199,6 +199,8 @@ extern ptr S_intern4 PROTO((ptr sym)); extern void S_intern_gensym PROTO((ptr g)); extern void S_retrofit_nonprocedure_code PROTO((void)); extern ptr S_mkstring PROTO((const string_char *s, iptr n)); +extern I32 S_symbol_hash32(ptr str); +extern I64 S_symbol_hash64(ptr str); /* io.c */ extern IBOOL S_file_existsp PROTO((const char *inpath, IBOOL followp)); @@ -280,6 +282,7 @@ extern void S_mutex_free PROTO((scheme_mutex_t *m)); extern void S_mutex_acquire PROTO((scheme_mutex_t *m)); extern INT S_mutex_tryacquire PROTO((scheme_mutex_t *m)); extern void S_mutex_release PROTO((scheme_mutex_t *m)); +extern IBOOL S_mutex_is_owner PROTO((scheme_mutex_t *m)); extern s_thread_cond_t *S_make_condition PROTO((void)); extern void S_condition_free PROTO((s_thread_cond_t *c)); extern IBOOL S_condition_wait PROTO((s_thread_cond_t *c, scheme_mutex_t *m, ptr t)); @@ -380,7 +383,7 @@ extern INT matherr PROTO((struct exception *x)); /* segment.c */ extern void S_segment_init PROTO((void)); -extern void *S_getmem PROTO((iptr bytes, IBOOL zerofill)); +extern void *S_getmem PROTO((iptr bytes, IBOOL zerofill, IBOOL for_code)); extern void S_freemem PROTO((void *addr, iptr bytes)); extern iptr S_find_segments PROTO((thread_gc *creator, ISPC s, IGEN g, iptr n)); extern void S_free_chunk PROTO((chunkinfo *chunk)); @@ -390,6 +393,8 @@ extern uptr S_maxmembytes PROTO((void)); extern void S_resetmaxmembytes PROTO((void)); extern void S_adjustmembytes PROTO((iptr amt)); extern void S_move_to_chunk_list PROTO((chunkinfo *chunk, chunkinfo **pchunk_list)); +extern void S_thread_start_code_write(void); +extern void S_thread_end_code_write(void); /* stats.c */ extern void S_stats_init PROTO((void)); @@ -404,6 +409,7 @@ extern void S_gettime PROTO((INT typeno, struct timespec *tp)); /* symbol.c */ extern ptr S_symbol_value PROTO((ptr sym)); +extern ptr S_symbol_racy_value PROTO((ptr sym)); extern void S_set_symbol_value PROTO((ptr sym, ptr val)); /* machine-dependent .c files, e.g., x88k.c */ diff --git a/src/ChezScheme/c/fasl.c b/src/ChezScheme/c/fasl.c index 6f157bc699..25bc6a3802 100644 --- a/src/ChezScheme/c/fasl.c +++ b/src/ChezScheme/c/fasl.c @@ -14,6 +14,10 @@ * limitations under the License. */ +/* The fasl writer is in "fasl.ss". + There's a second fasl reader and writer in "strip.ss", so it has + to be kept in sync with this one. */ + /* fasl representation: * * <fasl-file> -> <fasl-group>* @@ -48,8 +52,12 @@ * * -> {fxvector}<uptr n><iptr elt1>...<iptr eltn> * + * -> {flvector}<uptr n><uptr elthi1><uptr eltlo1>...<uptr elthin><uptr eltlon> + * * -> {bytevector}<uptr n><octet elt1>...<octet eltn> * + * -> {stencil-vector}<uptr mask><octet elt1>...<octet eltn> + * * -> {immediate}<uptr> * * -> {small-integer}<iptr> @@ -113,6 +121,8 @@ * ... * <faslreloc> # last relocation entry * + * -> {begin}<va>...<val> # all but last is intended to be a {graph-def} + * * <faslreloc> -> <byte type-etc> # bit 0: extended entry, bit 1: expect item offset, bit 2+: type * <uptr code-offset> * <uptr item-offset> # omitted if bit 1 of type-etc is 0 @@ -320,7 +330,6 @@ ptr S_bv_fasl_read(ptr bv, int ty, uptr offset, uptr len, ptr path, ptr external ptr tc = get_thread_context(); ptr x; struct unbufFaslFileObj uffo; - /* acquire mutex in case we modify code pages */ uffo.path = path; uffo.type = UFFO_TYPE_BV; x = bv_fasl_entry(tc, bv, ty, offset, len, &uffo, externals); @@ -499,6 +508,8 @@ static ptr fasl_entry(ptr tc, IFASLCODE situation, unbufFaslFile uf, ptr externa Scompact_heap(); } + S_thread_start_code_write(); + switch (ty) { case fasl_type_gzip: case fasl_type_lz4: { @@ -546,6 +557,7 @@ static ptr fasl_entry(ptr tc, IFASLCODE situation, unbufFaslFile uf, ptr externa return (ptr)0; } S_flush_instruction_cache(tc); + S_thread_end_code_write(); return x; } else { uf_skipbytes(uf, size); @@ -557,6 +569,8 @@ static ptr bv_fasl_entry(ptr tc, ptr bv, int ty, uptr offset, uptr len, unbufFas ptr x; ptr strbuf = S_G.null_string; struct faslFileObj ffo; + S_thread_start_code_write(); + if (ty == fasl_type_vfasl) { x = S_vfasl(bv, NULL, offset, len); } else if (ty == fasl_type_fasl) { @@ -571,6 +585,8 @@ static ptr bv_fasl_entry(ptr tc, ptr bv, int ty, uptr offset, uptr len, unbufFas } S_flush_instruction_cache(tc); + S_thread_end_code_write(); + return x; } @@ -602,6 +618,25 @@ static void bytesin(octet *s, iptr n, faslFile f) { } } +static void code_bytesin(octet *s, iptr n, faslFile f) { +#ifdef CANNOT_READ_DIRECTLY_INTO_CODE + while (1) { + iptr avail = f->end - f->next; + if (avail < n) { + bytesin(s, avail, f); + n -= avail; + s += avail; + fillFaslFile(f); + } else { + bytesin(s, n, f); + break; + } + } +#else + bytesin(s, n, f); +#endif +} + static void toolarge(ptr path) { S_error1("", "fasl value too large for this machine type in ~a", path); } @@ -749,14 +784,13 @@ static void faslin(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f) { while (n--) faslin(tc, p++, t, pstrbuf, f); if (ty == fasl_type_immutable_vector) { if (Svector_length(*x) == 0) - *x = NULLIMMUTABLEVECTOR(tc); + *x = S_G.null_immutable_vector; else VECTTYPE(*x) |= vector_immutable_flag; } return; } - case fasl_type_fxvector: - case fasl_type_immutable_fxvector: { + case fasl_type_fxvector: { iptr n; ptr *p; n = uptrin(f); *x = S_fxvector(n); @@ -766,11 +800,19 @@ static void faslin(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f) { if (!FIXRANGE(t)) toolarge(f->uf->path); *p++ = FIX(t); } - if (ty == fasl_type_immutable_fxvector) { - if (Sfxvector_length(*x) == 0) - *x = NULLIMMUTABLEFXVECTOR(tc); - else - FXVECTOR_TYPE(*x) |= fxvector_immutable_flag; + return; + } + case fasl_type_flvector: { + iptr n; double *p; + n = uptrin(f); + *x = S_flvector(n); + p = &FLVECTIT(*x, 0); + while (n--) { + ptr fl; + faslin(tc, &fl, t, pstrbuf, f); + if (!Sflonump(fl)) + S_error1("", "not a flonum in flvector ~a", f->uf->path); + *p++ = Sflonum_value(fl); } return; } @@ -782,7 +824,7 @@ static void faslin(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f) { bytesin(&BVIT(*x,0), n, f); if (ty == fasl_type_immutable_bytevector) { if (Sbytevector_length(*x) == 0) - *x = NULLIMMUTABLEBYTEVECTOR(tc); + *x = S_G.null_immutable_bytevector; else BYTEVECTOR_TYPE(*x) |= bytevector_immutable_flag; } @@ -888,7 +930,7 @@ static void faslin(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f) { } faslin(tc, &INITCAR(keyval), t, pstrbuf, f); faslin(tc, &INITCDR(keyval), t, pstrbuf, f); - i = ((uptr)Scar(keyval) >> primary_type_bits) & (veclen - 1); + i = eq_hash(Scar(keyval)) & (veclen - 1); INITVECTIT(v, i) = S_tlc(keyval, ht, Svector_ref(v, i)); n -= 1; } @@ -980,7 +1022,7 @@ static void faslin(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f) { for (i = 0; i != n; i += 1) Sstring_set(str, i, uptrin(f)); if (ty == fasl_type_immutable_string) { if (n == 0) - str = NULLIMMUTABLESTRING(tc); + str = S_G.null_immutable_string; else STRTYPE(str) |= string_immutable_flag; } @@ -1028,7 +1070,7 @@ static void faslin(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f) { if (pinfos != Snil) { S_G.profile_counters = Scons(S_weak_cons(co, pinfos), S_G.profile_counters); } - bytesin((octet *)&CODEIT(co, 0), n, f); + code_bytesin((octet *)&CODEIT(co, 0), n, f); #ifdef PORTABLE_BYTECODE_BIGENDIAN swap_code_endian((octet *)&CODEIT(co, 0), n); #endif @@ -1299,7 +1341,7 @@ static IBOOL rtd_equiv(x, y) ptr x, y; { /* recognize `base-rtd` shape: */ || ((RECORDINSTTYPE(x) == x) && (RECORDINSTTYPE(y) == y))) && - RECORDDESCPARENT(x) == RECORDDESCPARENT(y) && + rtd_parent(x) == rtd_parent(y) && equalp(RECORDDESCPM(x), RECORDDESCPM(y)) && equalp(RECORDDESCMPM(x), RECORDDESCMPM(y)) && equalp(RECORDDESCFLDS(x), RECORDDESCFLDS(y)) && @@ -1511,19 +1553,27 @@ ptr S_get_code_obj(typ, p, n, o) IFASLCODE typ; iptr n, o; ptr p; { return (ptr)(item - o); } - #ifdef PORTABLE_BYTECODE /* Address pieces in a movz,movk,movk,movk sequence are upper 16 bits */ #define ADDRESS_BITS_SHIFT 16 -#define ADDRESS_BITS_MASK ((U32)0xffff0000) +#define ADDRESS_BITS_MASK ((U32)0xFFFF0000) +#define DEST_REG_MASK 0xF00 static void pb_set_abs(void *address, uptr item) { - ((U32 *)address)[0] = ((((U32 *)address)[0] & ~ADDRESS_BITS_MASK) | ((item & 0xFFFF) << ADDRESS_BITS_SHIFT)); - ((U32 *)address)[1] = ((((U32 *)address)[1] & ~ADDRESS_BITS_MASK) | (((item >> 16) & 0xFFFF) << ADDRESS_BITS_SHIFT)); + /* First word can have an arbitrary value due to vfasl offset + storage, so get the target register from the end: */ #if ptr_bytes == 8 - ((U32 *)address)[2] = ((((U32 *)address)[2] & ~ADDRESS_BITS_MASK) | (((item >> 32) & 0xFFFF) << ADDRESS_BITS_SHIFT)); - ((U32 *)address)[3] = ((((U32 *)address)[3] & ~ADDRESS_BITS_MASK) | (((item >> 48) & 0xFFFF) << ADDRESS_BITS_SHIFT)); + int dest_reg = ((U32 *)address)[3] & DEST_REG_MASK; +#else + int dest_reg = ((U32 *)address)[1] & DEST_REG_MASK; +#endif + + ((U32 *)address)[0] = (pb_mov16_pb_zero_bits_pb_shift0 | dest_reg | ((item & 0xFFFF) << ADDRESS_BITS_SHIFT)); + ((U32 *)address)[1] = (pb_mov16_pb_keep_bits_pb_shift1 | dest_reg | (((item >> 16) & 0xFFFF) << ADDRESS_BITS_SHIFT)); +#if ptr_bytes == 8 + ((U32 *)address)[2] = (pb_mov16_pb_keep_bits_pb_shift2 | dest_reg | (((item >> 32) & 0xFFFF) << ADDRESS_BITS_SHIFT)); + ((U32 *)address)[3] = (pb_mov16_pb_keep_bits_pb_shift3 | dest_reg | (((item >> 48) & 0xFFFF) << ADDRESS_BITS_SHIFT)); #endif } @@ -1537,17 +1587,17 @@ static uptr pb_get_abs(void *address) { ); } -#endif /* AARCH64 */ +#endif /* PORTABLE_BYTECODE */ #ifdef ARMV6 static void arm32_set_abs(void *address, uptr item) { /* code generator produces ldrlit destreg, 0; brai 0; long 0 */ - /* we change long 0 => long item */ - *((U32 *)address + 2) = item; + /* given address is at long 0, which we change to `item` */ + *((U32 *)address) = item; } static uptr arm32_get_abs(void *address) { - return *((U32 *)address + 2); + return *((U32 *)address); } #define MAKE_B(n) (0xEA000000 | (n)) @@ -1600,11 +1650,24 @@ static uptr arm32_get_jump(void *address) { #define ADDRESS_BITS_SHIFT 5 #define ADDRESS_BITS_MASK ((U32)0x1fffe0) +/* Dest register in either movz or movk: */ +#define DEST_REG_MASK 0x1F + +#define MOVZ_OPCODE 0xD2800000 +#define MOVK_OPCODE 0xF2800000 +#define SHIFT16_OPCODE 0x00200000 +#define SHIFT32_OPCODE 0x00400000 +#define SHIFT48_OPCODE 0x00600000 + static void arm64_set_abs(void *address, uptr item) { - ((U32 *)address)[0] = ((((U32 *)address)[0] & ~ADDRESS_BITS_MASK) | ((item & 0xFFFF) << ADDRESS_BITS_SHIFT)); - ((U32 *)address)[1] = ((((U32 *)address)[1] & ~ADDRESS_BITS_MASK) | (((item >> 16) & 0xFFFF) << ADDRESS_BITS_SHIFT)); - ((U32 *)address)[2] = ((((U32 *)address)[2] & ~ADDRESS_BITS_MASK) | (((item >> 32) & 0xFFFF) << ADDRESS_BITS_SHIFT)); - ((U32 *)address)[3] = ((((U32 *)address)[3] & ~ADDRESS_BITS_MASK) | (((item >> 48) & 0xFFFF) << ADDRESS_BITS_SHIFT)); + /* First word can have an arbitrary value due to vfasl offset + storage, so get the target register from the end: */ + int dest_reg = ((U32 *)address)[3] & DEST_REG_MASK; + + ((U32 *)address)[0] = (MOVZ_OPCODE | dest_reg | ((item & 0xFFFF) << ADDRESS_BITS_SHIFT)); + ((U32 *)address)[1] = (MOVK_OPCODE | SHIFT16_OPCODE | dest_reg | (((item >> 16) & 0xFFFF) << ADDRESS_BITS_SHIFT)); + ((U32 *)address)[2] = (MOVK_OPCODE | SHIFT32_OPCODE | dest_reg | (((item >> 32) & 0xFFFF) << ADDRESS_BITS_SHIFT)); + ((U32 *)address)[3] = (MOVK_OPCODE | SHIFT48_OPCODE | dest_reg | (((item >> 48) & 0xFFFF) << ADDRESS_BITS_SHIFT)); } static uptr arm64_get_abs(void *address) { @@ -1621,21 +1684,26 @@ static uptr arm64_get_abs(void *address) { #define UPDATE_ADDIS(item, instr) (((instr) & ~0xFFFF) | (((item) >> 16) & 0xFFFF)) #define UPDATE_ADDI(item, instr) (((instr) & ~0xFFFF) | ((item) & 0xFFFF)) -#define MAKE_B(disp, callp) ((18 << 26) | (((disp) & 0xFFFFFF) << 2) | (callp)) -#define MAKE_ADDIS(item) ((15 << 26) | (((item) >> 16) & 0xFFFF)) -#define MAKE_ORI(item) ((24 << 26) | ((item) & 0xFFFF)) -#define MAKE_NOP ((24 << 26)) -#define MAKE_MTCTR ((31 << 26) | (9 << 16) | (467 << 1)) -#define MAKE_BCTR(callp) ((19 << 26) | (20 << 21) | (528 << 1) | (callp)) +#define MAKE_B(disp, callp) ((18 << 26) | (((disp) & 0xFFFFFF) << 2) | (callp)) +#define MAKE_ADDIS(item) ((15 << 26) | (((item) >> 16) & 0xFFFF)) +#define MAKE_ADDI(item) ((14 << 26) | ((item) & 0xFFFF)) +#define MAKE_ORI(item) ((24 << 26) | ((item) & 0xFFFF)) +#define MAKE_NOP ((24 << 26)) +#define MAKE_MTCTR ((31 << 26) | (9 << 16) | (467 << 1)) +#define MAKE_BCTR(callp) ((19 << 26) | (20 << 21) | (528 << 1) | (callp)) + +#define DEST_REG_MASK (0x1F << 21) static void ppc32_set_abs(void *address, uptr item) { /* code generator produces addis destreg, %r0, 0 (hi) ; addi destreg, destreg, 0 (lo) */ /* we change 0 (hi) => upper 16 bits of address */ /* we change 0 (lo) => lower 16 bits of address */ /* low part is signed: if negative, increment high part */ + /* but the first word may have been overritten for vfasl */ + int dest_reg = (*((U32 *)address + 1)) & DEST_REG_MASK; item = item + (item << 1 & 0x10000); - *((U32 *)address + 0) = UPDATE_ADDIS(item, *((U32 *)address + 0)); - *((U32 *)address + 1) = UPDATE_ADDI(item, *((U32 *)address + 1)); + *((U32 *)address + 0) = dest_reg | MAKE_ADDIS(item); + *((U32 *)address + 1) = dest_reg | dest_reg >> 5 | MAKE_ADDI(item); } static uptr ppc32_get_abs(void *address) { @@ -1914,14 +1982,21 @@ static void sparc64_set_literal(address, item) void *address; uptr item; { #endif /* SPARC64 */ #ifdef PORTABLE_BYTECODE_BIGENDIAN +typedef struct { + octet *code; + uptr size; +} rpheader_t; +static rpheader_t *rpheader_stack; +static int rpheader_stack_size = 0, rpheader_stack_pos = 0; + static void swap_code_endian(octet *code, uptr len) { - octet *next_rpheader = NULL; - uptr header_size = 0; - while (len > 0) { - if (code == next_rpheader) { + if ((rpheader_stack_pos > 0) + && (code == rpheader_stack[rpheader_stack_pos-1].code)) { /* swap 8-byte segments while we're in the header */ + uptr header_size = rpheader_stack[--rpheader_stack_pos].size; + while (header_size > 0) { octet a = code[0]; octet b = code[1]; @@ -1955,28 +2030,62 @@ static void swap_code_endian(octet *code, uptr len) code[2] = b; code[3] = a; + code += 4; + len -= 4; + if (a == pb_adr) { /* delta can be negative for a mvlet-error reinstall of the return address */ - iptr delta = (int16_t)(uint16_t)(((uptr)d << 16) + c); + iptr delta = (((iptr)d << (ptr_bits - 8)) >> (ptr_bits - 20)) + ((iptr)c << 4) + (b >> 4); if (delta > 0) { /* after a few more instructions, we'll hit a header where 64-bit values needs to be swapped, instead of 32-bit values */ - octet *after_rpheader = code + 4 + delta; + octet *after_rpheader = code + delta, *rpheader; + uptr header_size; + int pos; + + 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) header_size = size_rp_compact_header; else header_size = size_rp_header; - - next_rpheader = after_rpheader - header_size; + rpheader = after_rpheader - header_size; + + if (rpheader_stack_pos == rpheader_stack_size) { + int new_size = (2 * rpheader_stack_size) + 16; + rpheader_t *new_stack; + new_stack = malloc(new_size * sizeof(rpheader_t)); + if (rpheader_stack != NULL) { + memcpy(new_stack, rpheader_stack, rpheader_stack_pos * sizeof(rpheader_t)); + free(rpheader_stack); + } + rpheader_stack_size = new_size; + rpheader_stack = new_stack; + } + + rpheader_stack[rpheader_stack_pos].code = rpheader; + rpheader_stack[rpheader_stack_pos].size = header_size; + rpheader_stack_pos++; + + /* bubble down to keep sorted */ + for (pos = rpheader_stack_pos - 2; pos > 0; --pos) { + if (rpheader_stack[pos].code < rpheader_stack[pos+1].code) { + rpheader_t tmp = rpheader_stack[pos]; + rpheader_stack[pos] = rpheader_stack[pos+1]; + rpheader_stack[pos+1] = tmp; + } + } } } - - code += 4; - len -= 4; } } + + if (rpheader_stack_pos > 0) + S_error_abort("swap endian: header stack ends non-empty"); } void S_swap_dounderflow_header_endian(ptr co) diff --git a/src/ChezScheme/c/flushcache.c b/src/ChezScheme/c/flushcache.c index d273363087..6ddcfbef2b 100644 --- a/src/ChezScheme/c/flushcache.c +++ b/src/ChezScheme/c/flushcache.c @@ -27,10 +27,10 @@ typedef struct { static uptr max_gap; -static ptr make_mod_range PROTO((uptr start, uptr end)); +static ptr make_mod_range PROTO((ptr tc, uptr start, uptr end)); -static ptr make_mod_range(uptr start, uptr end) { - ptr bv = S_bytevector(sizeof(mod_range)); +static ptr make_mod_range(ptr tc, uptr start, uptr end) { + ptr bv = S_bytevector2(tc, sizeof(mod_range), 0); mod_range_start(bv) = start; mod_range_end(bv) = end; return bv; @@ -59,7 +59,7 @@ void S_record_code_mod(ptr tc, uptr addr, uptr bytes) { #ifdef DEBUG printf(" record_code_mod new range %x to %x\n", addr, end); fflush(stdout); #endif - CODERANGESTOFLUSH(tc) = S_cons_in(tc, space_new, 0, make_mod_range(addr, end), ls); + CODERANGESTOFLUSH(tc) = S_cons_in(tc, space_new, 0, make_mod_range(tc, addr, end), ls); return; } diff --git a/src/ChezScheme/c/gc-oce.c b/src/ChezScheme/c/gc-oce.c index 71a1124661..98012fecd1 100644 --- a/src/ChezScheme/c/gc-oce.c +++ b/src/ChezScheme/c/gc-oce.c @@ -18,6 +18,7 @@ #define ENABLE_OBJECT_COUNTS #define ENABLE_BACKREFERENCE #define ENABLE_MEASURE +/* #define ENABLE_PARALLEL - could enable to preserve owenrship/creator information */ #include "gc.c" ptr S_gc_oce(ptr tc, IGEN max_cg, IGEN min_tg, IGEN max_tg, ptr count_roots) { diff --git a/src/ChezScheme/c/gc.c b/src/ChezScheme/c/gc.c index 1228289458..7739a8e4ce 100644 --- a/src/ChezScheme/c/gc.c +++ b/src/ChezScheme/c/gc.c @@ -128,14 +128,19 @@ * There are no attempts to take tc_mutex suring sweeping. To the degree that locking is needed (e.g., to allocate new segments), - `S_use_gc_tc_mutex` redirects to gc_tc_mutex. No other locks - can be taken while that one is held. + the allocation mutex is used. No other locks can be taken while + that one is held. + + Along similar lines, get_thread_context() must not be used, + because the sweepers threads are not the same as Scheme threads, + and a sweeper thread may temporarily adapt a different Scheme + thread context. * To copy from or mark on a segment, a sweeper must own the segment. A sweeper during sweeping may encounter a "remote" reference to a segment that it doesn't own; in that case, it registers the object containing the remote reference to be - re-swept by the sweeeer that owns the target of the referenced. + re-swept by the sweeeer that owns the target of the reference. A segment is owned by the thread that originally allocated it. When a GC starts, for old-space segments that are owned by @@ -164,7 +169,7 @@ continue sweeping and eventually register the remote re-sweep. An object is swept by only one sweeper at a time; if mmultiple remote references to different sweepers are discovered in an - object, it is sent to nly one of the remote sweepers, and that + object, it is sent to only one of the remote sweepers, and that sweeper will eventually send on the object to the other sweeper. At worst, each object is swept N times for N sweepers. @@ -177,8 +182,16 @@ more tha N times ---- but, again, this case rarely happens at all, and sweeping more than N times is very unlikely. - Currently, counting and backreference modes do not support - parallelism. + * In counting/backtrace/measure mode, "parallel" collection can be + used to preserve object ownership, but no extra sweeper threads + are used. So, it is not really parallel, and counting and + backtrace operations do not need locks. + + Counting needs to copy or mark a record-type or object-count + object as part of a copy or mark operation, which is otherwise + not allowed (but ok with counting, since it's not actually in + parallel). For that purpose, `relocate_pure_in_owner` + temporarily switches to the owning thread. */ @@ -190,11 +203,11 @@ static void sweep_in_old PROTO((thread_gc *tgc, ptr p)); static void sweep_object_in_old PROTO((thread_gc *tgc, ptr p)); static IBOOL object_directly_refers_to_self PROTO((ptr p)); static ptr copy_stack PROTO((thread_gc *tgc, ptr old, iptr *length, iptr clength)); -static void resweep_weak_pairs PROTO((thread_gc *tgc, seginfo *oldweakspacesegments)); +static void resweep_weak_pairs PROTO((seginfo *oldweakspacesegments)); static void forward_or_bwp PROTO((ptr *pp, ptr p)); static void sweep_generation PROTO((thread_gc *tgc)); static iptr sweep_from_stack PROTO((thread_gc *tgc)); -static void enlarge_sweep_stack PROTO((thread_gc *tgc)); +static void enlarge_stack PROTO((thread_gc *tgc, ptr *stack, ptr *stack_start, ptr *stack_limit, uptr grow_at_least)); static uptr size_object PROTO((ptr p)); static iptr sweep_typed_object PROTO((thread_gc *tgc, ptr p, IGEN from_g)); static void sweep_symbol PROTO((thread_gc *tgc, ptr p, IGEN from_g)); @@ -233,7 +246,7 @@ static uptr target_generation_space_so_far(thread_gc *tgc); static void init_measure(thread_gc *tgc, IGEN min_gen, IGEN max_gen); static void finish_measure(); static void measure(thread_gc *tgc, ptr p); -static IBOOL flush_measure_stack(thread_gc *tgc); +static void flush_measure_stack(thread_gc *tgc); static void init_measure_mask(thread_gc *tgc, seginfo *si); static void init_counting_mask(thread_gc *tgc, seginfo *si); static void push_measure(thread_gc *tgc, ptr p); @@ -266,7 +279,6 @@ static uptr get_cpu_time () { # define ACCUM_CPU_TIME(a, y, x) uptr y = get_cpu_time() - x; a += y # define REPORT_TIME(e) e static uptr collect_accum, all_accum, par_accum; -static int percentage(iptr n, iptr d) { if (d == 0) return 0; else return (n * 100) / d; } # define COUNT_SWEPT_BYTES(start, end) num_swept_bytes += ((uptr)TO_PTR(end) - (uptr)TO_PTR(start)) # define ADJUST_COUNTER(e) e #else @@ -321,11 +333,14 @@ FORCEINLINE IGEN compute_target_generation(IGEN g) { static octet *fully_marked_mask[static_generation+1]; -#define push_sweep(p) { \ - if (tgc->sweep_stack == tgc->sweep_stack_limit) enlarge_sweep_stack(tgc); \ - *(ptr *)TO_VOIDP(tgc->sweep_stack) = p; \ - tgc->sweep_stack = (ptr)((uptr)tgc->sweep_stack + ptr_bytes); \ - } +static const int sweep_stack_min_size = 256; + +#define push_sweep(p) do { \ + if (tgc->sweep_stack == tgc->sweep_stack_limit) \ + enlarge_stack(tgc, &tgc->sweep_stack, &tgc->sweep_stack_start, &tgc->sweep_stack_limit, ptr_bytes); \ + *(ptr *)TO_VOIDP(tgc->sweep_stack) = p; \ + tgc->sweep_stack = (ptr)((uptr)tgc->sweep_stack + ptr_bytes); \ + } while (0) #ifdef ENABLE_MEASURE static uptr measure_total; /* updated by `measure` */ @@ -340,7 +355,7 @@ static ptr sweep_from; # define BACKREFERENCES_ENABLED S_G.enable_object_backreferences # define SET_SWEEP_FROM(p) if (S_G.enable_object_backreferences) sweep_from = p # define WITH_TOP_BACKREFERENCE(v, e) SET_SWEEP_FROM(v); e; SET_SWEEP_FROM(Sfalse) -# define SET_BACKREFERENCE(p) sweep_from = p; +# define SET_BACKREFERENCE(p) sweep_from = p # define PUSH_BACKREFERENCE(p) ptr old_sweep_from = sweep_from; SET_SWEEP_FROM(p); # define POP_BACKREFERENCE() SET_SWEEP_FROM(old_sweep_from); # define ADD_BACKREFERENCE_FROM(p, from_p, tg) do { \ @@ -354,7 +369,7 @@ static ptr sweep_from; #else # define BACKREFERENCES_ENABLED 0 # define WITH_TOP_BACKREFERENCE(v, e) e -# define SET_BACKREFERENCE(p) +# define SET_BACKREFERENCE(p) do { } while (0) # define PUSH_BACKREFERENCE(p) # define POP_BACKREFERENCE() # define ADD_BACKREFERENCE_FROM(p, from_p, from_g) @@ -367,33 +382,35 @@ static ptr sweep_from; #ifdef ENABLE_PARALLEL +static int in_parallel_sweepers = 0; + #define HAS_SWEEPER_WRT(t_tc, tc) 1 -# define GC_TC_MUTEX_ACQUIRE() gc_tc_mutex_acquire() -# define GC_TC_MUTEX_RELEASE() gc_tc_mutex_release() - -# define SEGMENT_IS_LOCAL(si, p) (((si)->creator == tgc) || marked(si, p) || !S_use_gc_tc_mutex) -# define RECORD_REMOTE_RANGE_TO(tgc, start, size, creator) do { \ - ptr START = TO_PTR(UNTYPE_ANY(start)); \ - ptr END = (ptr)((uptr)START + (size)); \ - if ((uptr)START < (uptr)tgc->remote_range_start) \ - tgc->remote_range_start = START; \ - if ((uptr)END > (uptr)tgc->remote_range_end) \ - tgc->remote_range_end = END; \ - tgc->remote_range_tgc = creator; \ - } while (0) -# define RECORD_REMOTE_RANGE(tgc, start, size, si) RECORD_REMOTE_RANGE_TO(tgc, start, size, si->creator) -# define FLUSH_REMOTE_RANGE(tgc, s, g) do { \ - if (tgc->remote_range_start != (ptr)(uptr)-1) { \ - flush_remote_range(tgc, s, g); \ - } \ +# define GC_MUTEX_ACQUIRE() alloc_mutex_acquire() +# define GC_MUTEX_RELEASE() alloc_mutex_release() + +/* shadows `tgc` binding in context: */ +# define BLOCK_SET_THREAD(a_tgc) thread_gc *tgc = a_tgc + +# define SEGMENT_IS_LOCAL(si, p) (((si)->creator == tgc) || marked(si, p) || !in_parallel_sweepers) +# define FLUSH_REMOTE_BLOCK thread_gc *remote_tgc = NULL; +# define RECORD_REMOTE(si) remote_tgc = si->creator +# define FLUSH_REMOTE(tgc, p) do { \ + if (remote_tgc != NULL) \ + push_remote_sweep(tgc, p, remote_tgc); \ } while (0) +# define ASSERT_EMPTY_FLUSH_REMOTE() do { \ + if (remote_tgc != NULL) S_error_abort("non-empty remote flush"); \ + } while (0); -static void map_threads_to_sweepers(thread_gc *tgc); -static void parallel_sweep_dirty_and_generation(thread_gc *tgc); +static void setup_sweepers(thread_gc *tgc); +static void run_sweepers(void); +static void teardown_sweepers(void); +# define parallel_sweep_generation(tgc) run_sweepers() +# define parallel_sweep_dirty_and_generation(tgc) run_sweepers() -static void flush_remote_range(thread_gc *tgc, ISPC s, IGEN g); -static remote_range *send_and_receive_remote_ranges(thread_gc *tgc); +static void push_remote_sweep(thread_gc *tgc, ptr p, thread_gc *remote_tgc); +static void send_and_receive_remote_sweeps(thread_gc *tgc); #define SWEEPER_NONE 0 #define SWEEPER_READY 1 @@ -408,8 +425,7 @@ typedef struct { iptr num_swept_bytes; #ifdef ENABLE_TIMING - int remote_ranges_sent, remote_ranges_received; - iptr remote_ranges_bytes_sent, remote_ranges_bytes_received; + int remotes_sent, remotes_received; uptr step, sweep_accum; #endif } gc_sweeper; @@ -424,17 +440,22 @@ static int num_sweepers; #define HAS_SWEEPER_WRT(t_tc, tc) (t_tc == tc) -# define GC_TC_MUTEX_ACQUIRE() do { } while (0) -# define GC_TC_MUTEX_RELEASE() do { } while (0) +# define GC_MUTEX_ACQUIRE() do { } while (0) +# define GC_MUTEX_RELEASE() do { } while (0) + +# define BLOCK_SET_THREAD(a_tgc) do { } while (0) # define SEGMENT_IS_LOCAL(si, p) 1 -# define RECORD_REMOTE_RANGE_TO(tgc, start, size, creator) do { } while (0) -# define RECORD_REMOTE_RANGE(tgc, start, size, si) do { } while (0) -# define FLUSH_REMOTE_RANGE(tgc, s, g) do { } while (0) +# define FLUSH_REMOTE_BLOCK /* empty */ +# define RECORD_REMOTE(si) do { } while (0) +# define FLUSH_REMOTE(tgc, p) do { } while (0) +# define ASSERT_EMPTY_FLUSH_REMOTE() do { } while (0) -# define map_threads_to_sweepers(tgc) do { } while (0) +# define setup_sweepers(tgc) do { } while (0) +# define parallel_sweep_generation(tgc) do { sweep_generation(tgc); } while (0) # define parallel_sweep_dirty_and_generation(tgc) do { sweep_dirty(tgc); sweep_generation(tgc); } while (0) -# define send_and_receive_remote_ranges(tgc) NULL +# define send_and_receive_remote_sweeps(tgc) do { } while (0) +# define teardown_sweepers() do { } while (0) static void sweep_dirty PROTO((thread_gc *tgc)); # define PARALLEL_UNUSED /* empty */ @@ -493,11 +514,11 @@ uptr list_length(ptr ls) { #endif static void init_fully_marked_mask(thread_gc *tgc, IGEN g) { - GC_TC_MUTEX_ACQUIRE(); + GC_MUTEX_ACQUIRE(); if (!fully_marked_mask[g]) { init_mask(tgc, fully_marked_mask[g], g, 0xFF); } - GC_TC_MUTEX_RELEASE(); + GC_MUTEX_RELEASE(); } #ifdef PRESERVE_FLONUM_EQ @@ -535,31 +556,31 @@ static int flonum_is_forwarded_p(ptr p, seginfo *si) { /* use relocate_pure for newspace fields that can't point to younger objects or where there's no need to track generations */ -#define relocate_pure(ppp, start, size) do { \ +#define relocate_pure(ppp) do { \ ptr* PPP = ppp; ptr PP = *PPP; \ - relocate_pure_help(PPP, PP, start, size); \ + relocate_pure_help(PPP, PP); \ } while (0) -#define relocate_pure_help(ppp, pp, start, size) do { \ +#define relocate_pure_help(ppp, pp) do { \ seginfo *SI; \ if (!IMMEDIATE(pp) && (SI = MaybeSegInfo(ptr_get_segment(pp))) != NULL) { \ if (SI->old_space) \ - relocate_pure_help_help(ppp, pp, SI, start, size); \ + relocate_pure_help_help(ppp, pp, SI); \ ELSE_MEASURE_NONOLDSPACE(pp) \ } \ } while (0) -#define relocate_pure_help_help(ppp, pp, si, start, size) do { \ - if (SEGMENT_IS_LOCAL(si, pp)) { \ +#define relocate_pure_help_help(ppp, pp, si) do { \ + if (SEGMENT_IS_LOCAL(si, pp)) { \ if (FORWARDEDP(pp, si)) \ *ppp = GET_FWDADDRESS(pp); \ else if (!new_marked(si, pp)) \ mark_or_copy_pure(ppp, pp, si); \ } else \ - RECORD_REMOTE_RANGE(tgc, start, size, si); \ + RECORD_REMOTE(si); \ } while (0) -#define relocate_code(pp, si, start, size) do { \ +#define relocate_code(pp, si) do { \ if (si->old_space) { \ if (SEGMENT_IS_LOCAL(si, pp)) { \ if (FWDMARKER(pp) == forward_marker) \ @@ -567,42 +588,65 @@ static int flonum_is_forwarded_p(ptr p, seginfo *si) { else if (!new_marked(si, pp)) \ mark_or_copy_pure(&pp, pp, si); \ } else \ - RECORD_REMOTE_RANGE(tgc, start, size, si); \ + RECORD_REMOTE(si); \ } ELSE_MEASURE_NONOLDSPACE(pp) \ } while (0) #define mark_or_copy_pure(dest, p, si) do { \ if (CAN_MARK_AND(si->use_marks)) \ - (void)mark_object(tgc, p, si); \ + (void)mark_object(tgc, p, si); \ else \ - (void)copy(tgc, p, si, dest); \ + (void)copy(tgc, p, si, dest); \ } while (0) +#define relocate_pure_now(ppp) do { \ + FLUSH_REMOTE_BLOCK \ + relocate_pure(ppp); \ + ASSERT_EMPTY_FLUSH_REMOTE(); \ + } while (0) + +#if defined(ENABLE_PARALLEL) && defined(ENABLE_OBJECT_COUNTS) +static void do_relocate_pure_in_owner(thread_gc *tgc, ptr *ppp) { + seginfo *si; + ptr pp = *ppp; + if (!IMMEDIATE(pp) + && (si = MaybeSegInfo(ptr_get_segment(pp))) != NULL + && si->old_space) { + BLOCK_SET_THREAD(si->creator); + relocate_pure_now(ppp); + } else { + relocate_pure_now(ppp); + } +} +# define relocate_pure_in_owner(ppp) do_relocate_pure_in_owner(tgc, ppp) +#else +# define relocate_pure_in_owner(pp) relocate_pure(pp) +#endif /* use relocate_impure for newspace fields that can point to younger objects */ #ifdef NO_DIRTY_NEWSPACE_POINTERS -# define relocate_impure_help(PPP, PP, FROM_G, start, size) do {(void)FROM_G; relocate_pure_help(PPP, PP, start, size);} while (0) -# define relocate_impure(PPP, FROM_G, start, size) do {(void)FROM_G; relocate_pure(PPP, start, size);} while (0) +# define relocate_impure_help(PPP, PP, FROM_G) do {(void)FROM_G; relocate_pure_help(PPP, PP);} while (0) +# define relocate_impure(PPP, FROM_G) do {(void)FROM_G; relocate_pure(PPP);} while (0) #else /* !NO_DIRTY_NEWSPACE_POINTERS */ -#define relocate_impure(ppp, from_g, start, size) do { \ +#define relocate_impure(ppp, from_g) do { \ ptr* PPP = ppp; ptr PP = *PPP; IGEN FROM_G = from_g; \ - relocate_impure_help(PPP, PP, FROM_G, start, size); \ + relocate_impure_help(PPP, PP, FROM_G); \ } while (0) -#define relocate_impure_help(ppp, pp, from_g, start, size) do { \ +#define relocate_impure_help(ppp, pp, from_g) do { \ seginfo *SI; \ if (!IMMEDIATE(pp) && (SI = MaybeSegInfo(ptr_get_segment(pp))) != NULL) { \ if (SI->old_space) \ - relocate_impure_help_help(ppp, pp, from_g, SI, start, size); \ + relocate_impure_help_help(ppp, pp, from_g, SI); \ ELSE_MEASURE_NONOLDSPACE(pp) \ } \ } while (0) -#define relocate_impure_help_help(ppp, pp, from_g, si, start, size) do { \ +#define relocate_impure_help_help(ppp, pp, from_g, si) do { \ IGEN __to_g; \ if (SEGMENT_IS_LOCAL(si, pp)) { \ if (FORWARDEDP(pp, si)) { \ @@ -613,21 +657,21 @@ static int flonum_is_forwarded_p(ptr p, seginfo *si) { } else { \ __to_g = TARGET_GENERATION(si); \ } \ - if (__to_g < from_g) S_record_new_dirty_card(tgc, ppp, __to_g); \ + if (__to_g < from_g) S_record_new_dirty_card(tgc, ppp, __to_g); \ } else \ - RECORD_REMOTE_RANGE(tgc, start, size, si); \ + RECORD_REMOTE(si); \ } while (0) #define mark_or_copy_impure(to_g, dest, p, from_g, si) do { \ if (CAN_MARK_AND(si->use_marks)) \ - to_g = mark_object(tgc, p, si); \ + to_g = mark_object(tgc, p, si); \ else \ - to_g = copy(tgc, p, si, dest); \ + to_g = copy(tgc, p, si, dest); \ } while (0) #endif /* !NO_DIRTY_NEWSPACE_POINTERS */ -#define relocate_dirty(PPP, YOUNGEST, start, size) do { \ +#define relocate_dirty(PPP, YOUNGEST) do { \ seginfo *_si; ptr *_ppp = PPP, _pp = *_ppp; IGEN _pg; \ if (!IMMEDIATE(_pp) && (_si = MaybeSegInfo(ptr_get_segment(_pp))) != NULL) { \ if (!_si->old_space) { \ @@ -640,12 +684,12 @@ static int flonum_is_forwarded_p(ptr p, seginfo *si) { } else if (new_marked(_si, _pp)) { \ _pg = TARGET_GENERATION(_si); \ } else if (CAN_MARK_AND(_si->use_marks)) { \ - _pg = mark_object(tgc, _pp, _si); \ + _pg = mark_object(tgc, _pp, _si); \ } else { \ - _pg = copy(tgc, _pp, _si, _ppp); \ + _pg = copy(tgc, _pp, _si, _ppp); \ } \ } else { \ - RECORD_REMOTE_RANGE(tgc, start, size, _si); \ + RECORD_REMOTE(_si); \ _pg = 0xff; \ } \ } \ @@ -657,17 +701,10 @@ static int flonum_is_forwarded_p(ptr p, seginfo *si) { # define is_counting_root(si, p) (si->counting_mask && (si->counting_mask[segment_bitmap_byte(p)] & segment_bitmap_bit(p))) #endif -#ifdef ENABLE_PARALLEL -static void do_relocate_indirect(thread_gc *tgc, ptr p, ptr start, uptr len) { - relocate_pure(&p, start, len); -} -# define relocate_indirect(p, start, len) do_relocate_indirect(tgc, p, start, len) -#else -static void do_relocate_indirect(thread_gc *tgc, ptr p) { - relocate_pure(&p, NULL, 0); -} -# define relocate_indirect(p, start, len) do_relocate_indirect(tgc, p) -#endif +# define relocate_indirect(p) do { \ + ptr _P = p; \ + relocate_pure(&_P); \ + } while (0) FORCEINLINE void check_triggers(thread_gc *tgc, seginfo *si) { /* Registering ephemerons and guardians to recheck at the @@ -689,12 +726,12 @@ FORCEINLINE void check_triggers(thread_gc *tgc, seginfo *si) { } } -#if defined(ENABLE_PARALLEL) +#if defined(ENABLE_OBJECT_COUNTS) +# include "gc-oce.inc" +#elif defined(ENABLE_PARALLEL) # include "gc-par.inc" -#elif !defined(ENABLE_OBJECT_COUNTS) -# include "gc-ocd.inc" #else -# include "gc-oce.inc" +# include "gc-ocd.inc" #endif /* sweep_in_old() is like sweep(), but the goal is to sweep the @@ -709,7 +746,7 @@ static void sweep_in_old(thread_gc *tgc, ptr p) { /* Detect all the cases when we need to give up on in-place sweeping: */ if (object_directly_refers_to_self(p)) { - relocate_pure(&p, NULL, 0); + relocate_pure_now(&p); return; } @@ -833,6 +870,8 @@ ptr GCENTRY(ptr tc, ptr count_roots_ls) { GET_REAL_TIME(astart); + S_thread_start_code_write(); + /* flush instruction cache: effectively clear_code_mod but safer */ for (ls = S_threads; ls != Snil; ls = Scdr(ls)) { ptr t_tc = (ptr)THREADTC(Scar(ls)); @@ -846,9 +885,7 @@ ptr GCENTRY(ptr tc, ptr count_roots_ls) { #endif /* !NO_DIRTY_NEWSPACE_POINTERS */ S_G.must_mark_gen0 = 0; - tgc->next = NULL; /* So resweep_weak_pairs sees one in non-parallel mode */ - - map_threads_to_sweepers(tgc); + setup_sweepers(tgc); /* maps threads to sweepers */ for (ls = S_threads; ls != Snil; ls = Scdr(ls)) { ptr t_tc = (ptr)THREADTC(Scar(ls)); @@ -885,6 +922,8 @@ ptr GCENTRY(ptr tc, ptr count_roots_ls) { /* set up context for sweeping --- effectively remembering the current allocation state so anything new is recognized as needing sweeping */ t_tgc->sweep_stack_start = t_tgc->sweep_stack = t_tgc->sweep_stack_limit = (ptr)0; + t_tgc->send_remote_sweep_stack_start = t_tgc->send_remote_sweep_stack = t_tgc->send_remote_sweep_stack_limit = (ptr)0; + t_tgc->receive_remote_sweep_stack_start = t_tgc->receive_remote_sweep_stack = t_tgc->receive_remote_sweep_stack_limit = (ptr)0; t_tgc->bitmask_overhead[0] = 0; for (g = MIN_TG; g <= MAX_TG; g++) t_tgc->bitmask_overhead[g] = 0; @@ -946,7 +985,7 @@ ptr GCENTRY(ptr tc, ptr count_roots_ls) { si->next = oldspacesegments; oldspacesegments = si; si->old_space = 1; - /* update generation now, both to compute the target generation, + /* update generation now, both to compute the target generation,< and so that any updated dirty references will record the correct new generation; also used for a check in S_dirty_set */ si->generation = compute_target_generation(si->generation); @@ -1003,7 +1042,7 @@ ptr GCENTRY(ptr tc, ptr count_roots_ls) { S_G.gcbackreference[g] = Snil; } - SET_BACKREFERENCE(Sfalse) /* #f => root */ + SET_BACKREFERENCE(Sfalse); /* #f => root */ /* Set mark bit for any locked object in `space_new`. Don't sweep until after handling counting roots. Note that the segment won't have @@ -1077,15 +1116,17 @@ ptr GCENTRY(ptr tc, ptr count_roots_ls) { if (!si->old_space || FORWARDEDP(p, si) || marked(si, p) || !count_roots[i].weak) { /* reached or older; sweep transitively */ - relocate_pure(&p, NULL, 0); - sweep(tgc, p, TARGET_GENERATION(si)); - ADD_BACKREFERENCE(p, si->generation); - sweep_generation(tgc); -# ifdef ENABLE_MEASURE - while (flush_measure_stack(tgc)) { - sweep_generation(tgc); +#ifdef ENABLE_PARALLEL + if (si->creator->tc == 0) si->creator = tgc; +#endif + { + BLOCK_SET_THREAD(si->creator); + relocate_pure_now(&p); + push_sweep(p); } -# endif + ADD_BACKREFERENCE(p, si->generation); + + parallel_sweep_generation(tgc); /* now count this object's size, if we have deferred it before */ si = SegInfo(ptr_get_segment(p)); @@ -1168,13 +1209,13 @@ ptr GCENTRY(ptr tc, ptr count_roots_ls) { #ifdef ENABLE_PARALLEL { ptr t_tc = (ptr)THREADTC(thread); + BLOCK_SET_THREAD(THREAD_GC(t_tc)); /* switches mark/sweep to thread */ if (!OLDSPACE(thread)) { /* remember to sweep in sweeper thread */ - THREAD_GC(t_tc)->thread = thread; + push_sweep(thread); } else { /* relocate now, then sweeping will happen in sweeper thread */ - thread_gc *tgc = THREAD_GC(t_tc); /* shadows enclosing `tgc` binding */ - relocate_pure(&thread, NULL, 0); + relocate_pure_now(&thread); } } #else @@ -1183,7 +1224,7 @@ ptr GCENTRY(ptr tc, ptr count_roots_ls) { #endif } - relocate_pure(&S_threads, NULL, 0); + relocate_pure_now(&S_threads); GET_REAL_TIME(start); @@ -1213,9 +1254,7 @@ ptr GCENTRY(ptr tc, ptr count_roots_ls) { /* coordinate with alloc.c */ (SYMVAL(sym) != sunbound || SYMPLIST(sym) != Snil || SYMSPLIST(sym) != Snil)) { seginfo *sym_si = SegInfo(ptr_get_segment(sym)); -#ifdef ENABLE_PARALLEL - thread_gc *tgc = sym_si->creator; /* shadows enclosing `tgc` binding */ -#endif + BLOCK_SET_THREAD(sym_si->creator); /* use symbol's creator thread context */ if (!new_marked(sym_si, sym)) mark_or_copy_pure(&sym, sym, sym_si); } @@ -1226,7 +1265,7 @@ ptr GCENTRY(ptr tc, ptr count_roots_ls) { /* relocate the protected C pointers */ {uptr i; for (i = 0; i < S_G.protect_next; i++) - relocate_pure(S_G.protected[i], NULL, 0); + relocate_pure_now(S_G.protected[i]); } /* sweep older locked and unlocked objects that are on `space_new` segments, @@ -1243,6 +1282,8 @@ ptr GCENTRY(ptr tc, ptr count_roots_ls) { parallel_sweep_dirty_and_generation(tgc); + teardown_sweepers(); + pre_finalization_size = target_generation_space_so_far(tgc); /* handle guardians */ @@ -1341,7 +1382,7 @@ ptr GCENTRY(ptr tc, ptr count_roots_ls) { /* if tconc was old it's been forwarded */ tconc = GUARDIANTCONC(ls); - WITH_TOP_BACKREFERENCE(tconc, relocate_pure(&rep, NULL, 0)); + WITH_TOP_BACKREFERENCE(tconc, relocate_pure_now(&rep)); old_end = Scdr(tconc); new_end = S_cons_in(tc, space_impure, 0, FIX(0), FIX(0)); @@ -1389,7 +1430,7 @@ ptr GCENTRY(ptr tc, ptr count_roots_ls) { } rep = GUARDIANREP(ls); - WITH_TOP_BACKREFERENCE(tconc, relocate_pure(&rep, NULL, 0)); + WITH_TOP_BACKREFERENCE(tconc, relocate_pure_now(&rep)); relocate_rep = 1; #ifdef ENABLE_OBJECT_COUNTS @@ -1486,7 +1527,7 @@ ptr GCENTRY(ptr tc, ptr count_roots_ls) { /* handle weak pairs */ resweep_dirty_weak_pairs(tgc); - resweep_weak_pairs(tgc, oldweakspacesegments); + resweep_weak_pairs(oldweakspacesegments); /* still-pending ephemerons all go to bwp */ finish_pending_ephemerons(tgc, oldspacesegments); @@ -1610,7 +1651,7 @@ ptr GCENTRY(ptr tc, ptr count_roots_ls) { si->forwarded_flonums = 0; #endif } else { - chunkinfo *chunk = si->chunk; + chunkinfo *chunk = si->chunk, **chunks = ((si->space == space_code) ? S_code_chunks : S_chunks); S_G.number_of_nonstatic_segments -= 1; S_G.number_of_empty_segments += 1; si->space = space_empty; @@ -1625,10 +1666,10 @@ ptr GCENTRY(ptr tc, ptr count_roots_ls) { * small stuff into them and thereby invite fragmentation */ S_free_chunk(chunk); } else { - S_move_to_chunk_list(chunk, &S_chunks[PARTIAL_CHUNK_POOLS]); + S_move_to_chunk_list(chunk, &chunks[PARTIAL_CHUNK_POOLS]); } } else { - S_move_to_chunk_list(chunk, &S_chunks[PARTIAL_CHUNK_POOLS-1]); + S_move_to_chunk_list(chunk, &chunks[PARTIAL_CHUNK_POOLS-1]); } } } @@ -1638,6 +1679,7 @@ ptr GCENTRY(ptr tc, ptr count_roots_ls) { if (MAX_CG >= S_G.min_free_gen) S_free_chunks(); S_flush_instruction_cache(tc); + S_thread_end_code_write(); #ifndef NO_DIRTY_NEWSPACE_POINTERS /* mark dirty those newspace cards to which we've added wrong-way pointers */ @@ -1675,7 +1717,7 @@ ptr GCENTRY(ptr tc, ptr count_roots_ls) { } INITTLCNEXT(tlc) = Sfalse; INITPTRFIELD(ht,eq_hashtable_size_disp) = FIX(UNFIX(PTRFIELD(ht,eq_hashtable_size_disp)) - 1); - } else if ((new_idx = ((uptr)key >> primary_type_bits) & (veclen - 1)) != old_idx) { + } else if ((new_idx = eq_hash(key) & (veclen - 1)) != old_idx) { /* remove tlc from old bucket */ b = Svector_ref(vec, old_idx); if (b == tlc) { @@ -1712,6 +1754,8 @@ ptr GCENTRY(ptr tc, ptr count_roots_ls) { for (g = MIN_TG; g <= MAX_TG; g++) S_G.bitmask_overhead[g] += tgc->bitmask_overhead[g]; + tgc->queued_fire = 0; + ACCUM_REAL_TIME(all_accum, astep, astart); REPORT_TIME(fprintf(stderr, "%d all +%ld ms %ld ms [real time]\n", MAX_CG, astep, all_accum)); @@ -1727,22 +1771,16 @@ ptr GCENTRY(ptr tc, ptr count_roots_ls) { #ifdef ENABLE_PARALLEL -static void flush_remote_range(thread_gc *tgc, ISPC s, IGEN g) { - remote_range *r; - - find_gc_room_voidp(tgc, space_data, 0, ptr_align(sizeof(remote_range)), r); - tgc->bitmask_overhead[0] += ptr_align(sizeof(remote_range)); - r->s = s; - r->g = g; - r->start = tgc->remote_range_start; - r->end = tgc->remote_range_end; - r->tgc = tgc->remote_range_tgc; - r->next = tgc->ranges_to_send; - tgc->ranges_to_send = r; - - tgc->remote_range_start = (ptr)(uptr)-1; - tgc->remote_range_end = (ptr)0; - +static void push_remote_sweep(thread_gc *tgc, ptr p, thread_gc *remote_tgc) { + if (tgc->send_remote_sweep_stack == tgc->send_remote_sweep_stack_limit) + enlarge_stack(tgc, + &tgc->send_remote_sweep_stack, + &tgc->send_remote_sweep_stack_start, + &tgc->send_remote_sweep_stack_limit, + 2 * ptr_bytes); + ((ptr *)TO_VOIDP(tgc->send_remote_sweep_stack))[0] = p; + ((ptr *)TO_VOIDP(tgc->send_remote_sweep_stack))[1] = TO_PTR(remote_tgc); + tgc->send_remote_sweep_stack = (ptr)((uptr)tgc->send_remote_sweep_stack + 2 * ptr_bytes); tgc->sweep_change = SWEEP_CHANGE_PROGRESS; } @@ -1757,10 +1795,10 @@ static void flush_remote_range(thread_gc *tgc, ISPC s, IGEN g) { while ((si = (seginfo *)TO_VOIDP(tgc->sweep_next[from_g][s])) != NULL) { \ tgc->sweep_next[from_g][s] = si->sweep_next; \ pp = TO_VOIDP(si->sweep_start); \ - while ((p = *pp) != forward_marker) \ - body \ + while ((p = *pp) != forward_marker) { \ + do body while (0); \ + } \ COUNT_SWEPT_BYTES(si->sweep_start, pp); \ - FLUSH_REMOTE_RANGE(tgc, s, from_g); \ save_resweep(s, si); \ } \ } while (0) @@ -1773,29 +1811,28 @@ static void flush_remote_range(thread_gc *tgc, ISPC s, IGEN g) { pp = sl; \ while (pp != nl) { \ p = *pp; \ - body \ + do body while (0); \ } \ COUNT_SWEPT_BYTES(sl, nl); \ - FLUSH_REMOTE_RANGE(tgc, s, from_g); \ } \ } while (0) #define save_resweep(s, si) do { \ if (s == space_weakpair) { \ - GC_TC_MUTEX_ACQUIRE(); \ + GC_MUTEX_ACQUIRE(); \ si->sweep_next = resweep_weak_segments; \ resweep_weak_segments = si; \ - GC_TC_MUTEX_RELEASE(); \ + GC_MUTEX_RELEASE(); \ } \ } while (0) -static void resweep_weak_pairs(thread_gc *tgc, seginfo *oldweakspacesegments) { +static void resweep_weak_pairs(seginfo *oldweakspacesegments) { IGEN from_g; - ptr *pp, p, *nl; + ptr *pp, p, *nl, ls; seginfo *si; - thread_gc *s_tgc; - for (s_tgc = tgc; s_tgc != NULL; s_tgc = s_tgc->next) { + for (ls = S_threads; ls != Snil; ls = Scdr(ls)) { + thread_gc *s_tgc = THREAD_GC(THREADTC(Scar(ls))); for (from_g = MIN_TG; from_g <= MAX_TG; from_g += 1) { /* By starting from `base_loc`, we may needlessly sweep pairs in `MAX_TG` that were allocated before the GC, but that's ok. Could consult @@ -1861,7 +1898,6 @@ static iptr sweep_generation_pass(thread_gc *tgc) { ptr *slp, *nlp; ptr *pp, *ppn, p, *nl, *sl; IGEN from_g; seginfo *si; iptr num_swept_bytes = 0; - remote_range *received_ranges; do { tgc->sweep_change = SWEEP_NO_CHANGE; @@ -1871,190 +1907,100 @@ static iptr sweep_generation_pass(thread_gc *tgc) { for (from_g = MIN_TG; from_g <= MAX_TG; from_g += 1) { sweep_space(space_impure, from_g, { - /* only pairs in theses spaces in backreference mode */ - SET_BACKREFERENCE(TYPE(TO_PTR(pp), type_pair)); - relocate_impure_help(pp, p, from_g, pp, 2 * ptr_bytes); - ppn = pp + 1; - p = *ppn; - relocate_impure_help(ppn, p, from_g, pp, 2 * ptr_bytes); - pp = ppn + 1; - }); - SET_BACKREFERENCE(Sfalse) + /* only pairs in theses spaces in backreference mode */ + FLUSH_REMOTE_BLOCK + SET_BACKREFERENCE(TYPE(TO_PTR(pp), type_pair)); + relocate_impure_help(pp, p, from_g); + ppn = pp + 1; + p = *ppn; + relocate_impure_help(ppn, p, from_g); + FLUSH_REMOTE(tgc, TYPE(TO_PTR(pp), type_pair)); + pp = ppn + 1; + }); + SET_BACKREFERENCE(Sfalse); sweep_space(space_symbol, from_g, { - p = TYPE(TO_PTR(pp), type_symbol); - sweep_symbol(tgc, p, from_g); - pp += size_symbol / sizeof(ptr); - }); - + p = TYPE(TO_PTR(pp), type_symbol); + sweep_symbol(tgc, p, from_g); + pp += size_symbol / sizeof(ptr); + }); + sweep_space(space_port, from_g, { - p = TYPE(TO_PTR(pp), type_typed_object); - sweep_port(tgc, p, from_g); - pp += size_port / sizeof(ptr); - }); + p = TYPE(TO_PTR(pp), type_typed_object); + sweep_port(tgc, p, from_g); + pp += size_port / sizeof(ptr); + }); sweep_space(space_weakpair, from_g, { - SET_BACKREFERENCE(TYPE(TO_PTR(pp), type_pair)) - ppn = pp + 1; - p = *ppn; - relocate_impure_help(ppn, p, from_g, pp, size_pair); - pp = ppn + 1; - }); - SET_BACKREFERENCE(Sfalse) + FLUSH_REMOTE_BLOCK + SET_BACKREFERENCE(TYPE(TO_PTR(pp), type_pair)); + ppn = pp + 1; + p = *ppn; + relocate_impure_help(ppn, p, from_g); + FLUSH_REMOTE(tgc, TYPE(TO_PTR(pp), type_pair)); + pp = ppn + 1; + }); + SET_BACKREFERENCE(Sfalse); sweep_space(space_ephemeron, from_g, { - p = TYPE(TO_PTR(pp), type_pair); - add_ephemeron_to_pending(tgc, p); - pp += size_ephemeron / sizeof(ptr); - }); - + p = TYPE(TO_PTR(pp), type_pair); + add_ephemeron_to_pending(tgc, p); + pp += size_ephemeron / sizeof(ptr); + }); + sweep_space(space_pure, from_g, { - SET_BACKREFERENCE(TYPE(TO_PTR(pp), type_pair)) /* only pairs put here in backreference mode */ - relocate_impure_help(pp, p, from_g, pp, 2 * ptr_bytes); - ppn = pp + 1; - p = *ppn; - relocate_impure_help(ppn, p, from_g, pp, 2 * ptr_bytes); - pp = ppn + 1; - }); - SET_BACKREFERENCE(Sfalse) + FLUSH_REMOTE_BLOCK + SET_BACKREFERENCE(TYPE(TO_PTR(pp), type_pair)); /* only pairs put here in backreference mode */ + relocate_impure_help(pp, p, from_g); + ppn = pp + 1; + p = *ppn; + relocate_impure_help(ppn, p, from_g); + FLUSH_REMOTE(tgc, TYPE(TO_PTR(pp), type_pair)); + pp = ppn + 1; + }); + SET_BACKREFERENCE(Sfalse); sweep_space(space_continuation, from_g, { - p = TYPE(TO_PTR(pp), type_closure); - sweep_continuation(tgc, p, from_g); - pp += size_continuation / sizeof(ptr); - }); + p = TYPE(TO_PTR(pp), type_closure); + sweep_continuation(tgc, p, from_g); + pp += size_continuation / sizeof(ptr); + }); sweep_space(space_pure_typed_object, from_g, { - p = TYPE(TO_PTR(pp), type_typed_object); - pp = TO_VOIDP(((uptr)TO_PTR(pp) + sweep_typed_object(tgc, p, from_g))); - }); + p = TYPE(TO_PTR(pp), type_typed_object); + pp = TO_VOIDP(((uptr)TO_PTR(pp) + sweep_typed_object(tgc, p, from_g))); + }); sweep_space(space_code, from_g, { - p = TYPE(TO_PTR(pp), type_typed_object); - sweep_code_object(tgc, p, from_g); - pp += size_code(CODELEN(p)) / sizeof(ptr); - }); + p = TYPE(TO_PTR(pp), type_typed_object); + sweep_code_object(tgc, p, from_g); + pp += size_code(CODELEN(p)) / sizeof(ptr); + }); sweep_space(space_impure_record, from_g, { - p = TYPE(TO_PTR(pp), type_typed_object); - sweep_record(tgc, p, from_g); - pp = TO_VOIDP((iptr)TO_PTR(pp) + - size_record_inst(UNFIX(RECORDDESCSIZE(RECORDINSTTYPE(p))))); - }); + p = TYPE(TO_PTR(pp), type_typed_object); + sweep_record(tgc, p, from_g); + pp = TO_VOIDP((iptr)TO_PTR(pp) + + size_record_inst(UNFIX(RECORDDESCSIZE(RECORDINSTTYPE(p))))); + }); /* space used only as needed for backreferences: */ sweep_space(space_impure_typed_object, from_g, { - p = TYPE(TO_PTR(pp), type_typed_object); - pp = TO_VOIDP((uptr)TO_PTR(pp) + sweep_typed_object(tgc, p, from_g)); - }); + p = TYPE(TO_PTR(pp), type_typed_object); + pp = TO_VOIDP((uptr)TO_PTR(pp) + sweep_typed_object(tgc, p, from_g)); + }); /* space used only as needed for backreferences: */ sweep_space(space_closure, from_g, { - p = TYPE(TO_PTR(pp), type_closure); - sweep(tgc, p, from_g); - pp = TO_VOIDP((uptr)TO_PTR(pp) + size_object(p)); - }); - } - - received_ranges = send_and_receive_remote_ranges(tgc); - - /* The ranges in `received_ranges` include old-generation objects from - other parallel sweepers, which means they correspond to dirty - sweeps in the originating sweeper. We handle them here like - regular sweeping using `relocate_impure`, which will register a - dirty-card update as needed. */ - while (received_ranges != NULL) { - ISPC s = received_ranges->s; - IGEN from_g = received_ranges->g; - - pp = TO_VOIDP(received_ranges->start); - nl = TO_VOIDP(received_ranges->end); - - if ((s == space_impure) - || (s == space_immobile_impure) - || (s == space_count_impure) - || (s == space_pure) - || (s == space_impure_typed_object)) { - while (pp < nl) { - p = *pp; - relocate_impure_help(pp, p, from_g, pp, 2 * ptr_bytes); - ppn = pp + 1; - p = *ppn; - relocate_impure_help(ppn, p, from_g, pp, 2 * ptr_bytes); - pp = ppn + 1; - } - } else if (s == space_new) { /* used by infer_space to mean "type ojbect" */ - while (pp < nl) { - p = TYPE(TO_PTR(pp), type_typed_object); - sweep(tgc, p, from_g); - pp = TO_VOIDP((uptr)TO_PTR(pp) + size_object(p)); - } - } else if (s == space_closure) { - while (pp < nl) { p = TYPE(TO_PTR(pp), type_closure); sweep(tgc, p, from_g); pp = TO_VOIDP((uptr)TO_PTR(pp) + size_object(p)); - } - } else if (s == space_continuation) { - while (pp < nl) { - p = TYPE(TO_PTR(pp), type_closure); - sweep_continuation(tgc, p, from_g); - pp += size_continuation / sizeof(ptr); - } - } else if (s == space_code) { - while (pp < nl) { - p = TYPE(TO_PTR(pp), type_typed_object); - sweep_code_object(tgc, p, from_g); - pp += size_code(CODELEN(p)) / sizeof(ptr); - } - } else if ((s == space_pure_typed_object) - || (s == space_count_pure)) { - /* old generation can happen in the special case of a thread object: */ - while (pp < nl) { - p = TYPE(TO_PTR(pp), type_typed_object); - pp = TO_VOIDP(((uptr)TO_PTR(pp) + sweep_typed_object(tgc, p, from_g))); - } - } else if (s == space_symbol) { - while (pp < nl) { - p = TYPE(TO_PTR(pp), type_symbol); - sweep_symbol(tgc, p, from_g); - pp += size_symbol / sizeof(ptr); - } - } else if (s == space_port) { - while (pp < nl) { - p = TYPE(TO_PTR(pp), type_typed_object); - sweep_port(tgc, p, from_g); - pp += size_port / sizeof(ptr); - } - } else if (s == space_weakpair) { - while (pp < nl) { - ppn = pp + 1; - p = *ppn; - relocate_impure_help(ppn, p, from_g, pp, size_pair); - pp = ppn + 1; - } - } else if (s == space_ephemeron) { - while (pp < nl) { - p = TYPE(TO_PTR(pp), type_pair); - add_ephemeron_to_pending(tgc, p); - pp += size_ephemeron / sizeof(ptr); - } - } else if (s == space_impure_record) { - while (pp < nl) { - p = TYPE(TO_PTR(pp), type_typed_object); - sweep_record(tgc, p, from_g); - pp = TO_VOIDP((iptr)TO_PTR(pp) + - size_record_inst(UNFIX(RECORDDESCSIZE(RECORDINSTTYPE(p))))); - } - } else { - printf(">> %d\n", s); - S_error_abort("dirty range sweep: unexpected space"); - } - FLUSH_REMOTE_RANGE(tgc, s, from_g); - COUNT_SWEPT_BYTES(received_ranges->start, received_ranges->end); - received_ranges = received_ranges->next; + }); } + /* May add to the sweep stack: */ + send_and_receive_remote_sweeps(tgc); + /* Waiting until sweeping doesn't trigger a change reduces the chance that an ephemeron must be reigistered as a segment-specific trigger or gets triggered for recheck, but @@ -2062,6 +2008,12 @@ static iptr sweep_generation_pass(thread_gc *tgc) { if (tgc->sweep_change == SWEEP_NO_CHANGE) check_pending_ephemerons(tgc); +# ifdef ENABLE_MEASURE + if ((tgc->sweep_change == SWEEP_NO_CHANGE) + && measure_all_enabled) { + flush_measure_stack(tgc); + } +# endif } while (tgc->sweep_change == SWEEP_CHANGE_PROGRESS); return num_swept_bytes; @@ -2071,46 +2023,20 @@ static void sweep_generation(thread_gc *tgc) { sweep_generation_pass(tgc); } -void enlarge_sweep_stack(thread_gc *tgc) { - uptr sz = ((uptr)tgc->sweep_stack_limit - (uptr)tgc->sweep_stack_start); - uptr new_sz = 2 * ((sz == 0) ? 256 : sz); - ptr new_sweep_stack; - find_gc_room(tgc, space_data, 0, typemod, ptr_align(new_sz), new_sweep_stack); +void enlarge_stack(thread_gc *tgc, ptr *stack, ptr *stack_start, ptr *stack_limit, uptr grow_at_least) { + uptr sz = ((uptr)*stack - (uptr)*stack_start); + uptr new_sz = 2 * ((sz == 0) ? (uptr)sweep_stack_min_size : sz); + ptr new_stack; + if (new_sz - sz < grow_at_least) new_sz += grow_at_least; + find_gc_room(tgc, space_data, 0, typemod, ptr_align(new_sz), new_stack); if (sz != 0) - memcpy(TO_VOIDP(new_sweep_stack), TO_VOIDP(tgc->sweep_stack_start), sz); + memcpy(TO_VOIDP(new_stack), TO_VOIDP(*stack_start), sz); tgc->bitmask_overhead[0] += ptr_align(new_sz); - tgc->sweep_stack_start = new_sweep_stack; - tgc->sweep_stack_limit = (ptr)((uptr)new_sweep_stack + new_sz); - tgc->sweep_stack = (ptr)((uptr)new_sweep_stack + sz); + *stack_start = new_stack; + *stack_limit = (ptr)((uptr)new_stack + new_sz); + *stack = (ptr)((uptr)new_stack + sz); } -#ifdef ENABLE_PARALLEL -static ISPC infer_space(ptr p, seginfo *si) { - /* Certain kinds of values get allocated to more specific spaces by - parallel mode compared to non-parallel mode, and locked objects - may stay in a less-specific space like `space_new`. Marking - objects from a previous collection can mean sweeping from the - less-specific space. We can synthesize an appropropriate space - here, since it will be used only by the handling of received - ranges. */ - - if (si->marked_mask) { - ITYPE t = TYPEBITS(p); - if (t == type_typed_object) - return space_new; /* means "typed object" to sweep_generation_pass */ - else if (t == type_pair) { - if (si->space == space_new) - return space_impure; - } else if (t == type_closure) - return space_closure; - else if (t == type_symbol) - return space_symbol; - } - - return si->space; -} -#endif - iptr sweep_from_stack(thread_gc *tgc) { iptr num_swept_bytes = 0; @@ -2121,12 +2047,10 @@ iptr sweep_from_stack(thread_gc *tgc) { tgc->sweep_stack = (ptr)((uptr)tgc->sweep_stack - ptr_bytes); p = *(ptr *)TO_VOIDP(tgc->sweep_stack); /* Room for improvement: `si->generation` is needed only for - objects that have impure fields, or in parallel mode for - remote ranges. */ + objects that have impure fields. */ si = SegInfo(ptr_get_segment(p)); sweep(tgc, p, si->generation); COUNT_SWEPT_BYTES(0, size_object(p)); - FLUSH_REMOTE_RANGE(tgc, infer_space(p, si), si->generation); } } @@ -2165,23 +2089,23 @@ static void record_dirty_segment(IGEN from_g, IGEN to_g, seginfo *si) { if (to_g < from_g) { seginfo *oldfirst; - GC_TC_MUTEX_ACQUIRE(); + GC_MUTEX_ACQUIRE(); oldfirst = DirtySegments(from_g, to_g); DirtySegments(from_g, to_g) = si; si->dirty_prev = &DirtySegments(from_g, to_g); si->dirty_next = oldfirst; if (oldfirst != NULL) oldfirst->dirty_prev = &si->dirty_next; si->min_dirty_byte = to_g; - GC_TC_MUTEX_RELEASE(); + GC_MUTEX_RELEASE(); } } static void add_weaksegments_to_resweep(weakseginfo *segs, weakseginfo *last_seg) { if (segs != NULL) { - GC_TC_MUTEX_ACQUIRE(); + GC_MUTEX_ACQUIRE(); last_seg->next = weaksegments_to_resweep; weaksegments_to_resweep = segs; - GC_TC_MUTEX_RELEASE(); + GC_MUTEX_RELEASE(); } } @@ -2312,25 +2236,26 @@ static uptr sweep_dirty_segments(thread_gc *tgc, seginfo **dirty_segments) { while (pp < ppend) { /* handle two pointers at a time */ if (marked(dirty_si, TO_PTR(pp))) { - relocate_dirty(pp, youngest, pp, 2 * ptr_bytes); + FLUSH_REMOTE_BLOCK + relocate_dirty(pp, youngest); ppn = pp + 1; - relocate_dirty(ppn, youngest, pp, 2 * ptr_bytes); + relocate_dirty(ppn, youngest); + FLUSH_REMOTE(tgc, TYPE(TO_PTR(pp), type_pair)); pp = ppn + 1; } else { - FLUSH_REMOTE_RANGE(tgc, s, from_g); pp += 2; } } - FLUSH_REMOTE_RANGE(tgc, s, from_g); } else { while (pp < ppend && *pp != forward_marker) { /* handle two pointers at a time */ - relocate_dirty(pp, youngest, pp, 2 * ptr_bytes); + FLUSH_REMOTE_BLOCK + relocate_dirty(pp, youngest); ppn = pp + 1; - relocate_dirty(ppn, youngest, pp, 2 * ptr_bytes); + relocate_dirty(ppn, youngest); + FLUSH_REMOTE(tgc, TYPE(TO_PTR(pp), type_pair)); pp = ppn + 1; } - FLUSH_REMOTE_RANGE(tgc, s, from_g); } } else if (s == space_symbol) { /* old symbols cannot overlap segment boundaries @@ -2349,13 +2274,9 @@ static uptr sweep_dirty_segments(thread_gc *tgc, seginfo **dirty_segments) { if (!dirty_si->marked_mask || marked(dirty_si, p)) youngest = sweep_dirty_symbol(tgc, p, youngest); - else - FLUSH_REMOTE_RANGE(tgc, s, from_g); pp += size_symbol / sizeof(ptr); } - - FLUSH_REMOTE_RANGE(tgc, s, from_g); } else if (s == space_port) { /* old ports cannot overlap segment boundaries since any object that spans multiple @@ -2373,13 +2294,9 @@ static uptr sweep_dirty_segments(thread_gc *tgc, seginfo **dirty_segments) { if (!dirty_si->marked_mask || marked(dirty_si, p)) youngest = sweep_dirty_port(tgc, p, youngest); - else - FLUSH_REMOTE_RANGE(tgc, s, from_g); pp += size_port / sizeof(ptr); } - - FLUSH_REMOTE_RANGE(tgc, s, from_g); } else if (s == space_impure_record) { /* abandon hope all ye who enter here */ ptr p; if (dirty_si->marked_mask) { @@ -2457,7 +2374,6 @@ static uptr sweep_dirty_segments(thread_gc *tgc, seginfo **dirty_segments) { seginfo *si = SegInfo(ptr_get_segment(p)); if (!marked(si, p)) { /* skip unmarked words */ - FLUSH_REMOTE_RANGE(tgc, s, from_g); p = (ptr)((uptr)p + byte_alignment); } else { youngest = sweep_dirty_record(tgc, p, youngest); @@ -2466,8 +2382,6 @@ static uptr sweep_dirty_segments(thread_gc *tgc, seginfo **dirty_segments) { RECORDINSTTYPE(p))))); } } - - FLUSH_REMOTE_RANGE(tgc, s, from_g); } else { uptr j; ptr pnext; seginfo *si; @@ -2513,34 +2427,27 @@ static uptr sweep_dirty_segments(thread_gc *tgc, seginfo **dirty_segments) { size_record_inst(UNFIX(RECORDDESCSIZE( RECORDINSTTYPE(p))))); } - - FLUSH_REMOTE_RANGE(tgc, s, from_g); } } else if (s == space_weakpair) { while (pp < ppend && (dirty_si->marked_mask || (*pp != forward_marker))) { /* skip car field and handle cdr field */ if (!dirty_si->marked_mask || marked(dirty_si, TO_PTR(pp))) { + FLUSH_REMOTE_BLOCK ptr *ppn = pp + 1; - relocate_dirty(ppn, youngest, pp, size_pair); + relocate_dirty(ppn, youngest); + FLUSH_REMOTE(tgc, TYPE(TO_PTR(pp), type_pair)); pp = ppn + 1; } else { - FLUSH_REMOTE_RANGE(tgc, s, from_g); pp += 2; } } - - FLUSH_REMOTE_RANGE(tgc, s, from_g); } else if (s == space_ephemeron) { while (pp < ppend && (dirty_si->marked_mask || (*pp != forward_marker))) { ptr p = TYPE(TO_PTR(pp), type_pair); if (!dirty_si->marked_mask || marked(dirty_si, p)) youngest = check_dirty_ephemeron(tgc, p, youngest); - else - FLUSH_REMOTE_RANGE(tgc, s, from_g); pp += size_ephemeron / sizeof(ptr); } - - FLUSH_REMOTE_RANGE(tgc, s, from_g); } else { S_error_abort("sweep_dirty(gc): unexpected space"); } @@ -2625,7 +2532,7 @@ static void resweep_dirty_weak_pairs(thread_gc *tgc) { youngest = TARGET_GENERATION(si); } else if (FORWARDEDP(p, si)) { IGEN newpg; - *pp = FWDADDRESS(p); + *pp = GET_FWDADDRESS(p); newpg = TARGET_GENERATION(si); if (newpg < youngest) youngest = newpg; } else { @@ -2667,7 +2574,7 @@ static void add_trigger_guardians_to_recheck(ptr ls) { ptr last = ls, next; - GC_TC_MUTEX_ACQUIRE(); + GC_MUTEX_ACQUIRE(); next = GUARDIANNEXT(ls); while (next != 0) { @@ -2677,7 +2584,7 @@ static void add_trigger_guardians_to_recheck(ptr ls) INITGUARDIANNEXT(last) = recheck_guardians_ls; recheck_guardians_ls = ls; - GC_TC_MUTEX_RELEASE(); + GC_MUTEX_RELEASE(); } static void ephemeron_remove(ptr pe) { @@ -2718,6 +2625,7 @@ static void add_trigger_ephemerons_to_pending(thread_gc *tgc, ptr pe) { } static void check_ephemeron(thread_gc *tgc, ptr pe) { + FLUSH_REMOTE_BLOCK ptr p; seginfo *si; IGEN from_g; @@ -2736,27 +2644,27 @@ static void check_ephemeron(thread_gc *tgc, ptr pe) { IGEN tg = TARGET_GENERATION(si); if (tg < from_g) S_record_new_dirty_card(tgc, &INITCAR(pe), tg); #endif - relocate_impure(&INITCDR(pe), from_g, pe, size_ephemeron); + relocate_impure(&INITCDR(pe), from_g); } else if (FORWARDEDP(p, si)) { #ifndef NO_DIRTY_NEWSPACE_POINTERS IGEN tg = TARGET_GENERATION(si); if (tg < from_g) S_record_new_dirty_card(tgc, &INITCAR(pe), tg); #endif - INITCAR(pe) = FWDADDRESS(p); - relocate_impure(&INITCDR(pe), from_g, pe, size_ephemeron); + INITCAR(pe) = GET_FWDADDRESS(p); + relocate_impure(&INITCDR(pe), from_g); } else { /* Not reached, so far; install as trigger */ ephemeron_add(&si->trigger_ephemerons, pe); si->has_triggers = 1; } } else { - RECORD_REMOTE_RANGE_TO(tgc, pe, size_ephemeron, si->creator); + RECORD_REMOTE(si); } } else { - relocate_impure(&INITCDR(pe), from_g, pe, size_ephemeron); + relocate_impure(&INITCDR(pe), from_g); } - FLUSH_REMOTE_RANGE(tgc, space_ephemeron, from_g); + FLUSH_REMOTE(tgc, pe); POP_BACKREFERENCE(); } @@ -2772,6 +2680,8 @@ static void check_pending_ephemerons(thread_gc *tgc) { check_ephemeron(tgc, pe); pe = next_pe; } + + } /* Like check_ephemeron(), but for a dirty, old-generation @@ -2779,6 +2689,7 @@ static void check_pending_ephemerons(thread_gc *tgc) { be less pessimistic than setting `youngest` to the target generation: */ static IGEN check_dirty_ephemeron(thread_gc *tgc, ptr pe, IGEN youngest) { + FLUSH_REMOTE_BLOCK ptr p; seginfo *si; IGEN pg; @@ -2789,10 +2700,10 @@ static IGEN check_dirty_ephemeron(thread_gc *tgc, ptr pe, IGEN youngest) { if (si->old_space) { if (SEGMENT_IS_LOCAL(si, p)) { if (new_marked(si, p)) { - relocate_dirty(&INITCDR(pe), youngest, pe, size_ephemeron); + relocate_dirty(&INITCDR(pe), youngest); } else if (FORWARDEDP(p, si)) { INITCAR(pe) = GET_FWDADDRESS(p); - relocate_dirty(&INITCDR(pe), youngest, pe, size_ephemeron); + relocate_dirty(&INITCDR(pe), youngest); } else { /* Not reached, so far; add to pending list */ add_ephemeron_to_pending(tgc, pe); @@ -2806,20 +2717,23 @@ static IGEN check_dirty_ephemeron(thread_gc *tgc, ptr pe, IGEN youngest) { youngest = pg; } } else { - RECORD_REMOTE_RANGE_TO(tgc, pe, size_ephemeron, si->creator); + RECORD_REMOTE(si); + FLUSH_REMOTE(tgc, pe); return youngest; } } else { if (youngest != MIN_TG && (pg = si->generation) < youngest) youngest = pg; - relocate_dirty(&INITCDR(pe), youngest, pe, size_ephemeron); + relocate_dirty(&INITCDR(pe), youngest); } } else { /* Non-collectable key means that the value determines `youngest`: */ - relocate_dirty(&INITCDR(pe), youngest, pe, size_ephemeron); + relocate_dirty(&INITCDR(pe), youngest); } + FLUSH_REMOTE(tgc, pe); + POP_BACKREFERENCE() return youngest; @@ -2975,15 +2889,21 @@ static void assign_sweeper(int n, thread_gc *t_tgc) { t_tgc->sweeper = n; } -static void map_threads_to_sweepers(thread_gc *tgc) { +#if defined(ENABLE_OBJECT_COUNTS) +# define MAX_SWEEPERS 0 +#else +# define MAX_SWEEPERS maximum_parallel_collect_threads +#endif + +static void setup_sweepers(thread_gc *tgc) { int i, n, next = 0; ptr ls; assign_sweeper(main_sweeper_index, tgc); /* assign a tc for each sweeper to run in parallel */ - for (n = 0, i = 0; (n < maximum_parallel_collect_threads) && (i < S_collect_waiting_threads); i++) { - if ((i < maximum_parallel_collect_threads) && (S_collect_waiting_tcs[i] != (ptr)0)) { + for (n = 0, i = 0; (n < MAX_SWEEPERS) && (i < S_collect_waiting_threads); i++) { + if ((i < MAX_SWEEPERS) && (S_collect_waiting_tcs[i] != (ptr)0)) { if (sweeper_started(n, 1)) { assign_sweeper(n, THREAD_GC(S_collect_waiting_tcs[i])); n++; @@ -2997,8 +2917,9 @@ static void map_threads_to_sweepers(thread_gc *tgc) { /* map remaining threads to existing sweepers */ for (ls = S_threads; ls != Snil; ls = Scdr(ls)) { thread_gc *t_tgc = THREAD_GC(THREADTC(Scar(ls))); + t_tgc->during_alloc += 1; if ((t_tgc != tgc) && (t_tgc->sweeper == main_sweeper_index)) { - if ((n < maximum_parallel_collect_threads) && sweeper_started(n, 0)) { + if ((n < MAX_SWEEPERS) && sweeper_started(n, 0)) { assign_sweeper(n, t_tgc); n++; next = n; @@ -3017,11 +2938,20 @@ static void map_threads_to_sweepers(thread_gc *tgc) { } num_sweepers = n; + + for (i = 0; i <= num_sweepers; i++) { + int idx = ((i == num_sweepers) ? main_sweeper_index : i); + sweepers[idx].num_swept_bytes = 0; + ADJUST_COUNTER(sweepers[idx].remotes_sent = 0); + ADJUST_COUNTER(sweepers[idx].remotes_received = 0); + } } static s_thread_rv_t start_sweeper(void *_sweeper) { gc_sweeper *sweeper = _sweeper; + S_thread_start_code_write(); /* never ended */ + (void)s_thread_mutex_lock(&sweep_mutex); while (1) { while (sweeper->status != SWEEPER_SWEEPING) { @@ -3069,21 +2999,16 @@ static IBOOL sweeper_started(int i, IBOOL start_new) { return 1; } -static void parallel_sweep_dirty_and_generation(thread_gc *tgc) { +static void run_sweepers(void) { int i; - thread_gc *all_tgcs = NULL; - - S_use_gc_tc_mutex = 1; + + in_parallel_sweepers = 1; /* start other sweepers */ (void)s_thread_mutex_lock(&sweep_mutex); for (i = 0; i < num_sweepers + 1; i++) { int idx = ((i == num_sweepers) ? main_sweeper_index : i); sweepers[idx].status = SWEEPER_SWEEPING; - ADJUST_COUNTER(sweepers[idx].remote_ranges_sent = 0); - ADJUST_COUNTER(sweepers[idx].remote_ranges_bytes_sent = 0); - ADJUST_COUNTER(sweepers[idx].remote_ranges_received = 0); - ADJUST_COUNTER(sweepers[idx].remote_ranges_bytes_received = 0); num_running_sweepers++; } s_thread_cond_broadcast(&sweep_cond); @@ -3091,52 +3016,47 @@ static void parallel_sweep_dirty_and_generation(thread_gc *tgc) { /* sweep in the main thread */ run_sweeper(&sweepers[main_sweeper_index]); - s_thread_setspecific(S_tc_key, TO_VOIDP(tgc->tc)); /* wait for other sweepers and clean up each tgc */ (void)s_thread_mutex_lock(&sweep_mutex); + for (i = 0; i < num_sweepers; i++) { + while (sweepers[i].status != SWEEPER_READY) + s_thread_cond_wait(&sweepers[i].done_cond, &sweep_mutex); + } + (void)s_thread_mutex_unlock(&sweep_mutex); + + in_parallel_sweepers = 0; +} + +static void teardown_sweepers(void) { + thread_gc *t_tgc; + int i; + REPORT_TIME(fprintf(stderr, "------\n")); for (i = 0; i <= num_sweepers; i++) { - thread_gc *t_tgc, *next; - int idx; - if (i == num_sweepers) { - idx = main_sweeper_index; - } else { - idx = i; - while (sweepers[idx].status != SWEEPER_READY) - s_thread_cond_wait(&sweepers[idx].done_cond, &sweep_mutex); - } + int idx = ((i == num_sweepers) ? main_sweeper_index : i); - for (t_tgc = sweepers[idx].first_tgc; t_tgc != NULL; t_tgc = next) { + for (t_tgc = sweepers[idx].first_tgc; t_tgc != NULL; t_tgc = t_tgc->next) { IGEN g; - next = t_tgc->next; S_G.bitmask_overhead[0] += t_tgc->bitmask_overhead[0]; t_tgc->bitmask_overhead[0] = 0; - for (g = MIN_TG; g <= MAX_TG; g++) + for (g = MIN_TG; g <= MAX_TG; g++) { S_G.bitmask_overhead[g] += t_tgc->bitmask_overhead[g]; + t_tgc->bitmask_overhead[g] = 0; /* needed to avoid double add for main_sweeper_index */ + } S_flush_instruction_cache(t_tgc->tc); t_tgc->sweeper = main_sweeper_index; - - if (t_tgc != tgc) { - t_tgc->next = all_tgcs; - all_tgcs = t_tgc; - } + t_tgc->queued_fire = 0; + t_tgc->during_alloc -= 1; } - REPORT_TIME(fprintf(stderr, "%d swpr +%ld ms %ld ms %ld bytes %d%%/%d sent %d%%/%d received\n", + REPORT_TIME(fprintf(stderr, "%d swpr +%ld ms %ld ms %ld bytes %d sent %d received\n", MAX_CG, sweepers[idx].step, sweepers[idx].sweep_accum, sweepers[idx].num_swept_bytes, - percentage(sweepers[idx].remote_ranges_bytes_sent, sweepers[idx].num_swept_bytes), - sweepers[idx].remote_ranges_sent, - percentage(sweepers[idx].remote_ranges_bytes_received, sweepers[idx].num_swept_bytes), - sweepers[idx].remote_ranges_received)); + sweepers[idx].remotes_sent, + sweepers[idx].remotes_received)); sweepers[idx].first_tgc = sweepers[idx].last_tgc = NULL; } - (void)s_thread_mutex_unlock(&sweep_mutex); - - tgc->next = all_tgcs; - - S_use_gc_tc_mutex = 0; } static void run_sweeper(gc_sweeper *sweeper) { @@ -3146,15 +3066,6 @@ static void run_sweeper(gc_sweeper *sweeper) { GET_CPU_TIME(start); for (tgc = sweeper->first_tgc; tgc != NULL; tgc = tgc->next) { - s_thread_setspecific(S_tc_key, TO_VOIDP(tgc->tc)); - - if (tgc->thread) { - seginfo *t_si = SegInfo(ptr_get_segment(tgc->thread)); - sweep_thread(tgc, tgc->thread); - FLUSH_REMOTE_RANGE(tgc, t_si->space, t_si->generation); - tgc->thread = (ptr)0; - } - num_swept_bytes += sweep_dirty_segments(tgc, tgc->dirty_segments); num_swept_bytes += sweep_generation_pass(tgc); } @@ -3164,12 +3075,12 @@ static void run_sweeper(gc_sweeper *sweeper) { while (1) { IBOOL any_ranges = 0; for (tgc = sweeper->first_tgc; tgc != NULL; tgc = tgc->next) { - if (tgc->ranges_received != NULL) { + if (tgc->receive_remote_sweep_stack != tgc->receive_remote_sweep_stack_start) { any_ranges = 1; break; } } - + if ((num_running_sweepers == 0) && !any_ranges) { /* everyone is done */ int i, they = main_sweeper_index; @@ -3193,7 +3104,6 @@ static void run_sweeper(gc_sweeper *sweeper) { (void)s_thread_mutex_unlock(&sweep_mutex); for (tgc = sweeper->first_tgc; tgc != NULL; tgc = tgc->next) { - s_thread_setspecific(S_tc_key, TO_VOIDP(tgc->tc)); num_swept_bytes += sweep_generation_pass(tgc); } @@ -3212,50 +3122,59 @@ static void run_sweeper(gc_sweeper *sweeper) { ACCUM_CPU_TIME(sweeper->sweep_accum, step, start); ADJUST_COUNTER(sweeper->step = step); - sweeper->num_swept_bytes = num_swept_bytes; + sweeper->num_swept_bytes += num_swept_bytes; } -static remote_range *send_and_receive_remote_ranges(thread_gc *tgc) { - thread_gc *r_tgc; - remote_range *r, *next; - +static void send_and_receive_remote_sweeps(thread_gc *tgc) { (void)s_thread_mutex_lock(&sweep_mutex); - r = tgc->ranges_to_send; - if (r != NULL) { - tgc->sweep_change = SWEEP_CHANGE_PROGRESS; - tgc->ranges_to_send = NULL; - for (; r != NULL; r = next) { - next = r->next; - ADJUST_COUNTER(sweepers[tgc->sweeper].remote_ranges_sent++); - ADJUST_COUNTER(sweepers[tgc->sweeper].remote_ranges_bytes_sent += ((uptr)r->end - (uptr)r->start)); - r_tgc = r->tgc; - r->next = r_tgc->ranges_received; - r_tgc->ranges_received = r; - if (sweepers[r_tgc->sweeper].status == SWEEPER_WAITING_FOR_WORK) { - num_running_sweepers++; - sweepers[r_tgc->sweeper].status = SWEEPER_SWEEPING; - s_thread_cond_signal(&sweepers[r_tgc->sweeper].work_cond); - } + /* Send objects to remote sweepers */ + while (tgc->send_remote_sweep_stack > tgc->send_remote_sweep_stack_start) { + thread_gc *r_tgc; + ptr p; + + tgc->send_remote_sweep_stack = (ptr)((uptr)tgc->send_remote_sweep_stack - (2 * ptr_bytes)); + p = ((ptr *)TO_VOIDP(tgc->send_remote_sweep_stack))[0]; + r_tgc = TO_VOIDP(((ptr *)TO_VOIDP(tgc->send_remote_sweep_stack))[1]); + + if (r_tgc->receive_remote_sweep_stack == r_tgc->receive_remote_sweep_stack_limit) + enlarge_stack(tgc, + &r_tgc->receive_remote_sweep_stack, + &r_tgc->receive_remote_sweep_stack_start, + &r_tgc->receive_remote_sweep_stack_limit, + ptr_bytes); + + *(ptr *)TO_VOIDP(r_tgc->receive_remote_sweep_stack) = p; + r_tgc->receive_remote_sweep_stack = (ptr)((uptr)r_tgc->receive_remote_sweep_stack + ptr_bytes); + + if (sweepers[r_tgc->sweeper].status == SWEEPER_WAITING_FOR_WORK) { + num_running_sweepers++; + sweepers[r_tgc->sweeper].status = SWEEPER_SWEEPING; + s_thread_cond_signal(&sweepers[r_tgc->sweeper].work_cond); } + + ADJUST_COUNTER(sweepers[tgc->sweeper].remotes_sent++); } - r = tgc->ranges_received; - tgc->ranges_received = NULL; + /* Received objects from remote sweepers, moving to sweep stack: */ + if (tgc->receive_remote_sweep_stack != tgc->receive_remote_sweep_stack_start) { + iptr len = (uptr)tgc->receive_remote_sweep_stack - (uptr)tgc->receive_remote_sweep_stack_start; + + tgc->sweep_change = SWEEP_CHANGE_PROGRESS; - (void)s_thread_mutex_unlock(&sweep_mutex); + if (((uptr)tgc->sweep_stack + len) > (uptr)tgc->sweep_stack_limit) + enlarge_stack(tgc, &tgc->sweep_stack, &tgc->sweep_stack_start, &tgc->sweep_stack_limit, len); - if (r != NULL) { - tgc->sweep_change = SWEEP_CHANGE_PROGRESS; -#ifdef ENABLE_TIMING - for (next = r; next != NULL; next = next->next) { - ADJUST_COUNTER(sweepers[tgc->sweeper].remote_ranges_received++); - ADJUST_COUNTER(sweepers[tgc->sweeper].remote_ranges_bytes_received += ((uptr)next->end - (uptr)next->start)); - } -#endif + memcpy(tgc->sweep_stack, tgc->receive_remote_sweep_stack_start, len); + tgc->sweep_stack = (ptr)((uptr)tgc->sweep_stack + len); + if ((uptr)tgc->sweep_stack > (uptr)tgc->sweep_stack_limit) + abort(); + tgc->receive_remote_sweep_stack = tgc->receive_remote_sweep_stack_start; + + ADJUST_COUNTER(sweepers[tgc->sweeper].remotes_received += (len / ptr_bytes)); } - return r; + (void)s_thread_mutex_unlock(&sweep_mutex); } #endif @@ -3325,7 +3244,10 @@ static void push_measure(thread_gc *tgc, ptr p) if (si->old_space) { /* We must be in a GC--measure fusion, so switch back to GC */ - relocate_pure_help_help(&p, p, si, NULL, 0); + FLUSH_REMOTE_BLOCK + BLOCK_SET_THREAD(si->creator); + relocate_pure_help_help(&p, p, si); + ASSERT_EMPTY_FLUSH_REMOTE(); return; } @@ -3443,14 +3365,16 @@ void gc_measure_one(thread_gc *tgc, ptr p) { measure(tgc, p); - (void)flush_measure_stack(tgc); + flush_measure_stack(tgc); } -IBOOL flush_measure_stack(thread_gc *tgc) { +void flush_measure_stack(thread_gc *tgc) { if ((measure_stack <= measure_stack_start) && !pending_measure_ephemerons) - return 0; - + return; + + tgc->sweep_change = SWEEP_CHANGE_PROGRESS; + while (1) { while (measure_stack > measure_stack_start) measure(tgc, *(--measure_stack)); @@ -3459,8 +3383,6 @@ IBOOL flush_measure_stack(thread_gc *tgc) { break; check_pending_measure_ephemerons(tgc); } - - return 1; } ptr S_count_size_increments(ptr ls, IGEN generation) { diff --git a/src/ChezScheme/c/gcwrapper.c b/src/ChezScheme/c/gcwrapper.c index 2558f27325..857cf5d7c5 100644 --- a/src/ChezScheme/c/gcwrapper.c +++ b/src/ChezScheme/c/gcwrapper.c @@ -122,6 +122,8 @@ void S_gc_init() { S_G.countof_size[countof_string] = 0; INITVECTIT(S_G.countof_names, countof_fxvector) = S_intern((const unsigned char *)"fxvector"); S_G.countof_size[countof_fxvector] = 0; + INITVECTIT(S_G.countof_names, countof_flvector) = S_intern((const unsigned char *)"flvector"); + S_G.countof_size[countof_flvector] = 0; INITVECTIT(S_G.countof_names, countof_bytevector) = S_intern((const unsigned char *)"bytevector"); S_G.countof_size[countof_bytevector] = 0; INITVECTIT(S_G.countof_names, countof_locked) = S_intern((const unsigned char *)"locked"); @@ -300,7 +302,7 @@ void Slock_object(x) ptr x; { if (!IMMEDIATE(x) && (si = MaybeSegInfo(ptr_get_segment(x))) != NULL && (g = si->generation) != static_generation) { ptr tc = get_thread_context(); tc_mutex_acquire(); - S_pants_down += 1; + THREAD_GC(tc)->during_alloc += 1; /* immobilize */ if (si->must_mark < MUST_MARK_INFINITY) { si->must_mark++; @@ -313,7 +315,7 @@ void Slock_object(x) ptr x; { if (g != 0) S_G.countof[g][countof_pair] += 1; } (void)remove_first_nomorep(x, &S_G.unlocked_objects[g], 0); - S_pants_down -= 1; + THREAD_GC(tc)->during_alloc -= 1; tc_mutex_release(); } } @@ -324,7 +326,7 @@ void Sunlock_object(x) ptr x; { if (!IMMEDIATE(x) && (si = MaybeSegInfo(ptr_get_segment(x))) != NULL && (g = si->generation) != static_generation) { ptr tc = get_thread_context(); tc_mutex_acquire(); - S_pants_down += 1; + THREAD_GC(tc)->during_alloc += 1; /* mobilize, if we haven't lost track */ if (si->must_mark < MUST_MARK_INFINITY) --si->must_mark; @@ -336,7 +338,7 @@ void Sunlock_object(x) ptr x; { if (g != 0) S_G.countof[g][countof_pair] += 1; } } - S_pants_down -= 1; + THREAD_GC(tc)->during_alloc -= 1; tc_mutex_release(); } } @@ -480,11 +482,11 @@ seginfo *S_ptr_seginfo(ptr p) { void Scompact_heap() { ptr tc = get_thread_context(); IBOOL eoc = S_G.enable_object_counts; - S_pants_down += 1; + THREAD_GC(tc)->during_alloc += 1; S_G.enable_object_counts = 1; S_gc_oce(tc, S_G.max_nonstatic_generation, static_generation, static_generation, Sfalse); S_G.enable_object_counts = eoc; - S_pants_down -= 1; + THREAD_GC(tc)->during_alloc -= 1; } /* S_check_heap checks for various kinds of heap consistency @@ -646,7 +648,7 @@ static void check_heap_dirty_msg(msg, x) char *msg; ptr *x; { void S_check_heap(aftergc, mcg) IBOOL aftergc; IGEN mcg; { uptr seg; INT d; ISPC s; IGEN g; IDIRTYBYTE dirty; IBOOL found_eos; IGEN pg; ptr p, *pp1, *pp2, *nl; - iptr i; + iptr i, for_code; uptr empty_segments = 0; uptr used_segments = 0; uptr static_segments = 0; @@ -666,39 +668,36 @@ void S_check_heap(aftergc, mcg) IBOOL aftergc; IGEN mcg; { printf("!!! inconsistent thread NEXT %p and BASE %p\n", TO_VOIDP(tgc->next_loc[g][s]), TO_VOIDP(tgc->base_loc[g][s])); } - if ((tgc->remote_range_end != (ptr)0) - || (tgc->remote_range_start != (ptr)(uptr)-1)) { - S_checkheap_errors += 1; - printf("!!! nonempty thread REMOTERANGE %p-%p\n", - TO_VOIDP(tgc->remote_range_start), - TO_VOIDP(tgc->remote_range_end)); - } } } } } - for (i = PARTIAL_CHUNK_POOLS; i >= -1; i -= 1) { - chunkinfo *chunk = i == -1 ? S_chunks_full : S_chunks[i]; - while (chunk != NULL) { - seginfo *si = chunk->unused_segs; - iptr count = 0; - while(si) { - count += 1; - if (si->space != space_empty) { + for (for_code = 0; for_code < 2; for_code++) { + for (i = PARTIAL_CHUNK_POOLS; i >= -1; i -= 1) { + chunkinfo *chunk = (i == -1 + ? (for_code ? S_code_chunks_full : S_chunks_full) + : (for_code ? S_code_chunks[i] : S_chunks[i])); + while (chunk != NULL) { + seginfo *si = chunk->unused_segs; + iptr count = 0; + while(si) { + count += 1; + if (si->space != space_empty) { + S_checkheap_errors += 1; + printf("!!! unused segment has unexpected space\n"); + } + si = si->next; + } + if ((chunk->segs - count) != chunk->nused_segs) { S_checkheap_errors += 1; - printf("!!! unused segment has unexpected space\n"); + printf("!!! unexpected used segs count "Ptd" with "Ptd" total segs and "Ptd" segs on the unused list\n", + (ptrdiff_t)chunk->nused_segs, (ptrdiff_t)chunk->segs, (ptrdiff_t)count); } - si = si->next; - } - if ((chunk->segs - count) != chunk->nused_segs) { - S_checkheap_errors += 1; - printf("!!! unexpected used segs count "Ptd" with "Ptd" total segs and "Ptd" segs on the unused list\n", - (ptrdiff_t)chunk->nused_segs, (ptrdiff_t)chunk->segs, (ptrdiff_t)count); + used_segments += chunk->nused_segs; + empty_segments += count; + chunk = chunk->next; } - used_segments += chunk->nused_segs; - empty_segments += count; - chunk = chunk->next; } } @@ -739,274 +738,278 @@ void S_check_heap(aftergc, mcg) IBOOL aftergc; IGEN mcg; { (ptrdiff_t)empty_segments); } - for (i = PARTIAL_CHUNK_POOLS; i >= -1; i -= 1) { - chunkinfo *chunk = i == -1 ? S_chunks_full : S_chunks[i]; - while (chunk != NULL) { - uptr nsegs; seginfo *si; - for (si = &chunk->sis[0], nsegs = chunk->segs; nsegs != 0; nsegs -= 1, si += 1) { - seginfo *recorded_si; uptr recorded_seg; - if ((seg = si->number) != (recorded_seg = (chunk->base + chunk->segs - nsegs))) { - S_checkheap_errors += 1; - printf("!!! recorded segment number "PHtx" differs from actual segment number "PHtx"", (ptrdiff_t)seg, (ptrdiff_t)recorded_seg); - } - if ((recorded_si = SegInfo(seg)) != si) { - S_checkheap_errors += 1; - printf("!!! recorded segment "PHtx" seginfo "PHtx" differs from actual seginfo "PHtx"", (ptrdiff_t)seg, (ptrdiff_t)recorded_si, (ptrdiff_t)si); - } - s = si->space; - g = si->generation; - - if (si->use_marks) - printf("!!! use_marks set on generation %d segment "PHtx"\n", g, (ptrdiff_t)seg); - - if (s == space_new) { - if (g != 0 && !si->marked_mask) { + for (for_code = 0; for_code < 2; for_code++) { + for (i = PARTIAL_CHUNK_POOLS; i >= -1; i -= 1) { + chunkinfo *chunk = (i == -1 + ? (for_code ? S_code_chunks_full : S_chunks_full) + : (for_code ? S_code_chunks[i] : S_chunks[i])); + while (chunk != NULL) { + uptr nsegs; seginfo *si; + for (si = &chunk->sis[0], nsegs = chunk->segs; nsegs != 0; nsegs -= 1, si += 1) { + seginfo *recorded_si; uptr recorded_seg; + if ((seg = si->number) != (recorded_seg = (chunk->base + chunk->segs - nsegs))) { S_checkheap_errors += 1; - printf("!!! unexpected generation %d segment "PHtx" in space_new\n", g, (ptrdiff_t)seg); + printf("!!! recorded segment number "PHtx" differs from actual segment number "PHtx"", (ptrdiff_t)seg, (ptrdiff_t)recorded_seg); } - } else if (s == space_impure || s == space_symbol || s == space_pure || s == space_weakpair || s == space_ephemeron - || s == space_immobile_impure || s == space_count_pure || s == space_count_impure || s == space_closure - || s == space_pure_typed_object || s == space_continuation || s == space_port || s == space_code - || s == space_impure_record || s == space_impure_typed_object) { - ptr start; - - /* check for dangling references */ - pp1 = TO_VOIDP(build_ptr(seg, 0)); - pp2 = TO_VOIDP(build_ptr(seg + 1, 0)); - - nl = FIND_NL(pp1, pp2, s, g); - if (pp1 <= nl && nl < pp2) pp2 = nl; - - if (s == space_pure_typed_object || s == space_port || s == space_code - || s == space_impure_record || s == space_impure_typed_object) { - /* only check this segment for objects that start on it */ - uptr before_seg = seg; - - /* Back up over segments for the same space and generation: */ - while (1) { - seginfo *before_si = MaybeSegInfo(before_seg-1); - if (!before_si - || (before_si->space != si->space) - || (before_si->generation != si->generation) - || ((before_si->marked_mask == NULL) != (si->marked_mask == NULL))) - break; - before_seg--; + if ((recorded_si = SegInfo(seg)) != si) { + S_checkheap_errors += 1; + printf("!!! recorded segment "PHtx" seginfo "PHtx" differs from actual seginfo "PHtx"", (ptrdiff_t)seg, (ptrdiff_t)recorded_si, (ptrdiff_t)si); + } + s = si->space; + g = si->generation; + + if (si->use_marks) + printf("!!! use_marks set on generation %d segment "PHtx"\n", g, (ptrdiff_t)seg); + + if (s == space_new) { + if (g != 0 && !si->marked_mask) { + S_checkheap_errors += 1; + printf("!!! unexpected generation %d segment "PHtx" in space_new\n", g, (ptrdiff_t)seg); } + } else if (s == space_impure || s == space_symbol || s == space_pure || s == space_weakpair || s == space_ephemeron + || s == space_immobile_impure || s == space_count_pure || s == space_count_impure || s == space_closure + || s == space_pure_typed_object || s == space_continuation || s == space_port || s == space_code + || s == space_impure_record || s == space_impure_typed_object) { + ptr start; + + /* check for dangling references */ + pp1 = TO_VOIDP(build_ptr(seg, 0)); + pp2 = TO_VOIDP(build_ptr(seg + 1, 0)); + + nl = FIND_NL(pp1, pp2, s, g); + if (pp1 <= nl && nl < pp2) pp2 = nl; + + if (s == space_pure_typed_object || s == space_port || s == space_code + || s == space_impure_record || s == space_impure_typed_object) { + /* only check this segment for objects that start on it */ + uptr before_seg = seg; + + /* Back up over segments for the same space and generation: */ + while (1) { + seginfo *before_si = MaybeSegInfo(before_seg-1); + if (!before_si + || (before_si->space != si->space) + || (before_si->generation != si->generation) + || ((before_si->marked_mask == NULL) != (si->marked_mask == NULL))) + break; + before_seg--; + } + + /* Move forward to reach `seg` again: */ + start = build_ptr(before_seg, 0); + while (before_seg != seg) { + ptr *before_pp2, *before_nl; - /* Move forward to reach `seg` again: */ - start = build_ptr(before_seg, 0); - while (before_seg != seg) { - ptr *before_pp2, *before_nl; - - before_pp2 = TO_VOIDP(build_ptr(before_seg + 1, 0)); - if ((ptr *)TO_VOIDP(start) > before_pp2) { - /* skipped to a further segment */ - before_seg++; - } else { - before_nl = FIND_NL(TO_VOIDP(start), before_pp2, s, g); - if (((ptr*)TO_VOIDP(start)) <= before_nl && before_nl < before_pp2) { - /* this segment ends, so move to next segment */ + before_pp2 = TO_VOIDP(build_ptr(before_seg + 1, 0)); + if ((ptr *)TO_VOIDP(start) > before_pp2) { + /* skipped to a further segment */ before_seg++; - if (s == space_code) { - /* in the case of code, it's possible for a whole segment to - go unused if a large code object didn't fit; give up, just in case */ - start = build_ptr(seg+1, 0); - } else { - start = build_ptr(before_seg, 0); - } } else { - seginfo *before_si = MaybeSegInfo(before_seg); - while (((ptr *)TO_VOIDP(start)) < before_pp2) { - if (before_si->marked_mask) { - if (before_si->marked_mask[segment_bitmap_byte(start)] & segment_bitmap_bit(start)) { - start = (ptr)((uptr)start + size_object(TYPE(start, type_typed_object))); - } else { - /* skip past unmarked */ - start = (ptr)((uptr)start + byte_alignment); - } + before_nl = FIND_NL(TO_VOIDP(start), before_pp2, s, g); + if (((ptr*)TO_VOIDP(start)) <= before_nl && before_nl < before_pp2) { + /* this segment ends, so move to next segment */ + before_seg++; + if (s == space_code) { + /* in the case of code, it's possible for a whole segment to + go unused if a large code object didn't fit; give up, just in case */ + start = build_ptr(seg+1, 0); } else { - if (*(ptr *)TO_VOIDP(start) == forward_marker) { - /* this segment ends, so move to next segment */ - if (s == space_code) { - start = build_ptr(seg+1, 0); + start = build_ptr(before_seg, 0); + } + } else { + seginfo *before_si = MaybeSegInfo(before_seg); + while (((ptr *)TO_VOIDP(start)) < before_pp2) { + if (before_si->marked_mask) { + if (before_si->marked_mask[segment_bitmap_byte(start)] & segment_bitmap_bit(start)) { + start = (ptr)((uptr)start + size_object(TYPE(start, type_typed_object))); } else { - start = build_ptr(before_seg+1, 0); + /* skip past unmarked */ + start = (ptr)((uptr)start + byte_alignment); } } else { - start = (ptr)((uptr)start + size_object(TYPE(start, type_typed_object))); + if (*(ptr *)TO_VOIDP(start) == forward_marker) { + /* this segment ends, so move to next segment */ + if (s == space_code) { + start = build_ptr(seg+1, 0); + } else { + start = build_ptr(before_seg+1, 0); + } + } else { + start = (ptr)((uptr)start + size_object(TYPE(start, type_typed_object))); + } } } + before_seg++; } - before_seg++; } } - } - if (((ptr *)TO_VOIDP(start)) >= pp2) { - /* previous object extended past the segment */ - } else { - pp1 = TO_VOIDP(start); - while (pp1 < pp2) { - if (si->marked_mask) { - if (si->marked_mask[segment_bitmap_byte(TO_PTR(pp1))] & segment_bitmap_bit(TO_PTR(pp1))) { - p = TYPE(TO_PTR(pp1), type_typed_object); - check_object(p, seg, s, aftergc); - pp1 = TO_VOIDP((ptr)((uptr)TO_PTR(pp1) + size_object(p))); + if (((ptr *)TO_VOIDP(start)) >= pp2) { + /* previous object extended past the segment */ + } else { + pp1 = TO_VOIDP(start); + while (pp1 < pp2) { + if (si->marked_mask) { + if (si->marked_mask[segment_bitmap_byte(TO_PTR(pp1))] & segment_bitmap_bit(TO_PTR(pp1))) { + p = TYPE(TO_PTR(pp1), type_typed_object); + check_object(p, seg, s, aftergc); + pp1 = TO_VOIDP((ptr)((uptr)TO_PTR(pp1) + size_object(p))); + } else { + /* skip past unmarked */ + pp1 = TO_VOIDP((ptr)((uptr)TO_PTR(pp1) + byte_alignment)); + } } else { - /* skip past unmarked */ - pp1 = TO_VOIDP((ptr)((uptr)TO_PTR(pp1) + byte_alignment)); - } - } else { - if (*pp1 == forward_marker) - break; - else { - p = TYPE(TO_PTR(pp1), type_typed_object); - check_object(p, seg, s, aftergc); - pp1 = TO_VOIDP((ptr)((uptr)TO_PTR(pp1) + size_object(p))); + if (*pp1 == forward_marker) + break; + else { + p = TYPE(TO_PTR(pp1), type_typed_object); + check_object(p, seg, s, aftergc); + pp1 = TO_VOIDP((ptr)((uptr)TO_PTR(pp1) + size_object(p))); + } } } } - } - } else if (s == space_continuation) { - while (pp1 < pp2) { - if (*pp1 == forward_marker) - break; - if (!si->marked_mask || (si->marked_mask[segment_bitmap_byte(TO_PTR(pp1))] & segment_bitmap_bit(TO_PTR(pp1)))) { - p = TYPE(TO_PTR(pp1), type_closure); - check_object(p, seg, s, aftergc); + } else if (s == space_continuation) { + while (pp1 < pp2) { + if (*pp1 == forward_marker) + break; + if (!si->marked_mask || (si->marked_mask[segment_bitmap_byte(TO_PTR(pp1))] & segment_bitmap_bit(TO_PTR(pp1)))) { + p = TYPE(TO_PTR(pp1), type_closure); + check_object(p, seg, s, aftergc); + } + pp1 = TO_VOIDP((ptr)((uptr)TO_PTR(pp1) + size_continuation)); } - pp1 = TO_VOIDP((ptr)((uptr)TO_PTR(pp1) + size_continuation)); - } - } else { - while (pp1 < pp2) { - if (!si->marked_mask || (si->marked_mask[segment_bitmap_byte(TO_PTR(pp1))] & segment_bitmap_bit(TO_PTR(pp1)))) { - int a; - for (a = 0; (a < ptr_alignment) && (pp1 < pp2); a++) { + } else { + while (pp1 < pp2) { + if (!si->marked_mask || (si->marked_mask[segment_bitmap_byte(TO_PTR(pp1))] & segment_bitmap_bit(TO_PTR(pp1)))) { + int a; + for (a = 0; (a < ptr_alignment) && (pp1 < pp2); a++) { #define in_ephemeron_pair_part(pp1, seg) ((((uptr)TO_PTR(pp1) - (uptr)build_ptr(seg, 0)) % size_ephemeron) < size_pair) - if ((s == space_ephemeron) && !in_ephemeron_pair_part(pp1, seg)) { - /* skip non-pair part of ephemeron */ - } else { - p = *pp1; - if (!si->marked_mask && (p == forward_marker)) { - pp1 = pp2; /* break out of outer loop */ - break; + if ((s == space_ephemeron) && !in_ephemeron_pair_part(pp1, seg)) { + /* skip non-pair part of ephemeron */ } else { - check_pointer(pp1, 1, (ptr)0, seg, s, aftergc); + p = *pp1; + if (!si->marked_mask && (p == forward_marker)) { + pp1 = pp2; /* break out of outer loop */ + break; + } else { + check_pointer(pp1, 1, (ptr)0, seg, s, aftergc); + } } + pp1 += 1; } - pp1 += 1; - } - } else - pp1 += ptr_alignment; + } else + pp1 += ptr_alignment; + } } - } - /* further verify that dirty bits are set appropriately; only handles some spaces - to make sure that the dirty byte is not unnecessarily approximate, but we have also - checked dirty bytes alerady via `check_pointer` */ - if (s == space_impure || s == space_symbol || s == space_weakpair || s == space_ephemeron - || s == space_immobile_impure || s == space_closure) { - found_eos = 0; - pp2 = pp1 = TO_VOIDP(build_ptr(seg, 0)); - for (d = 0; d < cards_per_segment; d += 1) { - if (found_eos) { - if (si->dirty_bytes[d] != 0xff) { - S_checkheap_errors += 1; - printf("!!! Dirty byte set past end-of-segment for segment "PHtx", card %d\n", (ptrdiff_t)seg, d); - segment_tell(seg); + /* further verify that dirty bits are set appropriately; only handles some spaces + to make sure that the dirty byte is not unnecessarily approximate, but we have also + checked dirty bytes alerady via `check_pointer` */ + if (s == space_impure || s == space_symbol || s == space_weakpair || s == space_ephemeron + || s == space_immobile_impure || s == space_closure) { + found_eos = 0; + pp2 = pp1 = TO_VOIDP(build_ptr(seg, 0)); + for (d = 0; d < cards_per_segment; d += 1) { + if (found_eos) { + if (si->dirty_bytes[d] != 0xff) { + S_checkheap_errors += 1; + printf("!!! Dirty byte set past end-of-segment for segment "PHtx", card %d\n", (ptrdiff_t)seg, d); + segment_tell(seg); + } + continue; } - continue; - } - pp2 += bytes_per_card / sizeof(ptr); - if (pp1 <= nl && nl < pp2) { - found_eos = 1; - pp2 = nl; - } + pp2 += bytes_per_card / sizeof(ptr); + if (pp1 <= nl && nl < pp2) { + found_eos = 1; + pp2 = nl; + } #ifdef DEBUG - printf("pp1 = "PHtx", pp2 = "PHtx", nl = "PHtx"\n", (ptrdiff_t)pp1, (ptrdiff_t)pp2, (ptrdiff_t)nl); - fflush(stdout); + printf("pp1 = "PHtx", pp2 = "PHtx", nl = "PHtx"\n", (ptrdiff_t)pp1, (ptrdiff_t)pp2, (ptrdiff_t)nl); + fflush(stdout); #endif - dirty = 0xff; - while (pp1 < pp2) { - if (!si->marked_mask || (si->marked_mask[segment_bitmap_byte(TO_PTR(pp1))] & segment_bitmap_bit(TO_PTR(pp1)))) { - int a; - for (a = 0; (a < ptr_alignment) && (pp1 < pp2); a++) { - if ((s == space_ephemeron) && !in_ephemeron_pair_part(pp1, seg)) { - /* skip non-pair part of ephemeron */ - } else { - p = *pp1; + dirty = 0xff; + while (pp1 < pp2) { + if (!si->marked_mask || (si->marked_mask[segment_bitmap_byte(TO_PTR(pp1))] & segment_bitmap_bit(TO_PTR(pp1)))) { + int a; + for (a = 0; (a < ptr_alignment) && (pp1 < pp2); a++) { + if ((s == space_ephemeron) && !in_ephemeron_pair_part(pp1, seg)) { + /* skip non-pair part of ephemeron */ + } else { + p = *pp1; - if (p == forward_marker) { - found_eos = 1; - pp1 = pp2; - break; - } else if (!IMMEDIATE(p)) { - seginfo *psi = MaybeSegInfo(ptr_get_segment(p)); - if ((psi != NULL) && ((pg = psi->generation) < g)) { - if (pg < dirty) dirty = pg; - if (si->dirty_bytes[d] > pg) { - S_checkheap_errors += 1; - check_heap_dirty_msg("!!! INVALID", pp1); - } else if (checkheap_noisy) - check_heap_dirty_msg("... ", pp1); + if (p == forward_marker) { + found_eos = 1; + pp1 = pp2; + break; + } else if (!IMMEDIATE(p)) { + seginfo *psi = MaybeSegInfo(ptr_get_segment(p)); + if ((psi != NULL) && ((pg = psi->generation) < g)) { + if (pg < dirty) dirty = pg; + if (si->dirty_bytes[d] > pg) { + S_checkheap_errors += 1; + check_heap_dirty_msg("!!! INVALID", pp1); + } else if (checkheap_noisy) + check_heap_dirty_msg("... ", pp1); + } } } + pp1 += 1; } - pp1 += 1; + } else { + pp1 += ptr_alignment; } - } else { - pp1 += ptr_alignment; } - } - if (checkheap_noisy && si->dirty_bytes[d] < dirty) { - /* sweep_dirty won't sweep, and update dirty byte, for - cards with dirty pointers to segments older than the - maximum copyied generation, so we can get legitimate - conservative dirty bytes even after gc */ - printf("... Conservative dirty byte %x (%x) %sfor segment "PHtx" card %d ", - si->dirty_bytes[d], dirty, - (aftergc ? "after gc " : ""), - (ptrdiff_t)seg, d); - segment_tell(seg); - } - } - } else { - /* at least check that no dirty bytes are set beyond the end of the segment */ - if (pp2 < (ptr *)TO_VOIDP(build_ptr(seg + 1, 0))) { - uptr card = (uptr)TO_PTR(pp2) >> card_offset_bits; - int d = (int)(card & ((1 << segment_card_offset_bits) - 1)); - - for (d++; d < cards_per_segment; d++) { - if (si->dirty_bytes[d] != 0xff) { - S_checkheap_errors += 1; - printf("!!! Dirty byte set past end-of-segment for segment "PHtx", card %d\n", (ptrdiff_t)seg, d); + if (checkheap_noisy && si->dirty_bytes[d] < dirty) { + /* sweep_dirty won't sweep, and update dirty byte, for + cards with dirty pointers to segments older than the + maximum copyied generation, so we can get legitimate + conservative dirty bytes even after gc */ + printf("... Conservative dirty byte %x (%x) %sfor segment "PHtx" card %d ", + si->dirty_bytes[d], dirty, + (aftergc ? "after gc " : ""), + (ptrdiff_t)seg, d); segment_tell(seg); } } + } else { + /* at least check that no dirty bytes are set beyond the end of the segment */ + if (pp2 < (ptr *)TO_VOIDP(build_ptr(seg + 1, 0))) { + uptr card = (uptr)TO_PTR(pp2) >> card_offset_bits; + int d = (int)(card & ((1 << segment_card_offset_bits) - 1)); + + for (d++; d < cards_per_segment; d++) { + if (si->dirty_bytes[d] != 0xff) { + S_checkheap_errors += 1; + printf("!!! Dirty byte set past end-of-segment for segment "PHtx", card %d\n", (ptrdiff_t)seg, d); + segment_tell(seg); + } + } + } } } - } - if (aftergc - && (s != space_empty) - && (g == 0 - || (s != space_new && s != space_impure && s != space_symbol && s != space_port && s != space_weakpair && s != space_ephemeron - && s != space_impure_record && s != space_impure_typed_object - && s != space_immobile_impure && s != space_count_impure && s != space_closure))) { - for (d = 0; d < cards_per_segment; d += 1) { - if (si->dirty_bytes[d] != 0xff) { - S_checkheap_errors += 1; - printf("!!! Unnecessary dirty byte %x (%x) after gc for segment "PHtx" card %d ", - si->dirty_bytes[d], 0xff, (ptrdiff_t)(si->number), d); - segment_tell(seg); + if (aftergc + && (s != space_empty) + && (g == 0 + || (s != space_new && s != space_impure && s != space_symbol && s != space_port && s != space_weakpair && s != space_ephemeron + && s != space_impure_record && s != space_impure_typed_object + && s != space_immobile_impure && s != space_count_impure && s != space_closure))) { + for (d = 0; d < cards_per_segment; d += 1) { + if (si->dirty_bytes[d] != 0xff) { + S_checkheap_errors += 1; + printf("!!! Unnecessary dirty byte %x (%x) after gc for segment "PHtx" card %d ", + si->dirty_bytes[d], 0xff, (ptrdiff_t)(si->number), d); + segment_tell(seg); + } } } } + chunk = chunk->next; } - chunk = chunk->next; } } @@ -1022,7 +1025,7 @@ void S_check_heap(aftergc, mcg) IBOOL aftergc; IGEN mcg; { if (S_checkheap_errors) { printf("heap check failed%s\n", (aftergc ? " after gc" : "")); - exit(1); + abort(); } } @@ -1162,7 +1165,7 @@ ptr S_do_gc(IGEN max_cg, IGEN min_tg, IGEN max_tg, ptr count_roots) { Slock_object(code); /* Scheme side grabs mutex before calling S_do_gc */ - S_pants_down += 1; + THREAD_GC(tc)->during_alloc += 1; if (S_G.new_max_nonstatic_generation > S_G.max_nonstatic_generation) { S_G.min_free_gen = S_G.new_min_free_gen; @@ -1279,7 +1282,7 @@ ptr S_do_gc(IGEN max_cg, IGEN min_tg, IGEN max_tg, ptr count_roots) { to get_more_room if and when they awake and try to allocate */ S_reset_allocation_pointer(tc); - S_pants_down -= 1; + THREAD_GC(tc)->during_alloc -= 1; Sunlock_object(code); @@ -1293,7 +1296,10 @@ ptr S_gc(ptr tc, IGEN max_cg, IGEN min_tg, IGEN max_tg, ptr count_roots) { if (S_G.enable_object_backreferences) min_tg = max_tg; return S_gc_oce(tc, max_cg, min_tg, max_tg, count_roots); #if defined(PTHREADS) - } else if (S_collect_waiting_threads != 0) { + } else if ((S_collect_waiting_threads != 0) + || (Spairp(S_threads) + && Spairp(Scdr(S_threads)) + && (S_num_preserve_ownership_threads > 0))) { return S_gc_par(tc, max_cg, min_tg, max_tg, Sfalse); #endif } else if (max_cg == 0 && min_tg == 1 && max_tg == 1 diff --git a/src/ChezScheme/c/globals.h b/src/ChezScheme/c/globals.h index 6c3ec92ecc..b3a837d00d 100644 --- a/src/ChezScheme/c/globals.h +++ b/src/ChezScheme/c/globals.h @@ -39,17 +39,18 @@ EXTERN s_thread_key_t S_tc_key; EXTERN scheme_mutex_t S_tc_mutex; EXTERN s_thread_cond_t S_collect_cond; EXTERN s_thread_cond_t S_collect_thread0_cond; -EXTERN INT S_tc_mutex_depth; -EXTERN scheme_mutex_t S_gc_tc_mutex; -EXTERN IBOOL S_use_gc_tc_mutex; +EXTERN scheme_mutex_t S_alloc_mutex; /* ordered after S_tc_mutex */ +EXTERN s_thread_cond_t S_terminated_cond; EXTERN int S_collect_waiting_threads; EXTERN ptr S_collect_waiting_tcs[maximum_parallel_collect_threads]; +EXTERN int S_num_preserve_ownership_threads; # ifdef IMPLICIT_ATOMIC_AS_EXPLICIT EXTERN s_thread_mutex_t S_implicit_mutex; # endif #endif /* segment.c */ +/* update of the segment table is protected by alloc mutex */ #ifdef segment_t2_bits #ifdef segment_t3_bits EXTERN t2table *S_segment_info[1<<segment_t3_bits]; @@ -62,9 +63,10 @@ EXTERN seginfo *S_segment_info[1<<segment_t1_bits]; EXTERN chunkinfo *S_chunks_full; EXTERN chunkinfo *S_chunks[PARTIAL_CHUNK_POOLS+1]; +EXTERN chunkinfo *S_code_chunks_full; +EXTERN chunkinfo *S_code_chunks[PARTIAL_CHUNK_POOLS+1]; /* schsig.c */ -EXTERN IBOOL S_pants_down; /* foreign.c */ #ifdef LOAD_SHARED_OBJECT @@ -104,8 +106,8 @@ EXTERN struct S_G_struct { /* alloc.c */ ptr *protected[max_protected]; uptr protect_next; - uptr bytes_of_space[static_generation+1][max_real_space+1]; - uptr bytes_of_generation[static_generation+1]; + uptr bytes_of_space[static_generation+1][max_real_space+1]; /* protected by alloc mutex */ + uptr bytes_of_generation[static_generation+1]; /* protected by alloc mutex */ uptr bitmask_overhead[static_generation+1]; uptr g0_bytes_after_last_gc; uptr collect_trip_bytes; @@ -113,10 +115,10 @@ EXTERN struct S_G_struct { ptr null_string; ptr null_vector; ptr null_fxvector; + ptr null_flvector; ptr null_bytevector; ptr null_immutable_string; ptr null_immutable_vector; - ptr null_immutable_fxvector; ptr null_immutable_bytevector; ptr zero_length_bignum; seginfo *dirty_segments[DIRTY_SEGMENT_LISTS]; diff --git a/src/ChezScheme/c/intern.c b/src/ChezScheme/c/intern.c index 49ffde7134..cb12aa2872 100644 --- a/src/ChezScheme/c/intern.c +++ b/src/ChezScheme/c/intern.c @@ -33,7 +33,7 @@ void S_intern_init() { S_G.oblist_length = MIN_OBLIST_LENGTH; S_G.oblist_count = 0; - S_G.oblist = S_getmem(S_G.oblist_length * sizeof(bucket *), 1); + S_G.oblist = S_getmem(S_G.oblist_length * sizeof(bucket *), 1, 0); for (g = 0; g < static_generation; g += 1) S_G.buckets_of_generation[g] = NULL; } @@ -76,7 +76,7 @@ void S_resize_oblist(void) { if (new_oblist_length == S_G.oblist_length) return; - new_oblist = S_getmem(new_oblist_length * sizeof(bucket *), 1); + new_oblist = S_getmem(new_oblist_length * sizeof(bucket *), 1, 0); for (i = 0; i < S_G.oblist_length; i += 1) { for (b = S_G.oblist[i]; b != NULL; b = bnext) { @@ -106,34 +106,37 @@ void S_resize_oblist(void) { #define MIX_HASH(hc) (hc += (hc << 10), hc ^= (hc >> 6)) +#define SYM_HASH_LOOP(uptr, iptr, extract, mask) { \ + uptr h = (uptr)n + 401887359; \ + while (n--) { h += extract(*s++); MIX_HASH(h); } \ + return (iptr)h & mask; \ + } + +#define identity_extract(x) x + static iptr hash(const unsigned char *s, iptr n) { - uptr h = (uptr)n + 401887359; - while (n--) { h += *s++; MIX_HASH(h); } - return (iptr)h & most_positive_fixnum; + SYM_HASH_LOOP(uptr, iptr, identity_extract, most_positive_fixnum); } static iptr hash_sc(const string_char *s, iptr n) { - uptr h = (uptr)n + 401887359; - while (n--) { h += Schar_value(*s++); MIX_HASH(h); } - return (iptr)h & most_positive_fixnum; + SYM_HASH_LOOP(uptr, iptr, Schar_value, most_positive_fixnum); } static iptr hash_uname(const string_char *s, iptr n) { - /* attempting to get dissimilar hash codes for gensyms created in the same session */ - iptr i = n, h = 0; iptr pos = 1; int d, c; + return hash_sc(s, n); +} - while (i-- > 0) { - if ((c = Schar_value(s[i])) == '-') { - if (pos <= 10) break; - return (h + 523658599) & most_positive_fixnum; - } - d = c - '0'; - if (d < 0 || d > 9) break; - h += d * pos; - pos *= 10; - } +/* on any platform, computes the value that is computed on a 32-bit platform, + but needs to be `bitwise-and`ed with most_positive_fixnum */ +I32 S_symbol_hash32(ptr str) { + const string_char *s = &STRIT(str, 0); iptr n = Sstring_length(str); + SYM_HASH_LOOP(U32, I32, Schar_value, (I32)-1); +} - return hash_sc(s, n); +/* like S_symbol_hash32 for the value that is computed on a 64-bit platform */ +I64 S_symbol_hash64(ptr str) { + const string_char *s = &STRIT(str, 0); iptr n = Sstring_length(str); + SYM_HASH_LOOP(U64, I64, Schar_value, (U64)-1); } static ptr mkstring(const string_char *s, iptr n) { diff --git a/src/ChezScheme/c/pb.c b/src/ChezScheme/c/pb.c index a865f5ab62..b522b80ffa 100644 --- a/src/ChezScheme/c/pb.c +++ b/src/ChezScheme/c/pb.c @@ -17,6 +17,9 @@ typedef uint32_t instruction_t; #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) @@ -398,6 +401,20 @@ void S_pb_interp(ptr tc, void *bytecode) { 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; @@ -673,7 +690,7 @@ void S_pb_interp(ptr tc, void *bytecode) { case pb_return: return; /* <--- not break */ case pb_adr: - regs[INSTR_di_dest(instr)] = (uptr)TO_PTR(next_ip) + INSTR_di_imm(instr); + regs[INSTR_adr_dest(instr)] = (uptr)TO_PTR(next_ip) + INSTR_adr_imm(instr); break; case pb_interp: { diff --git a/src/ChezScheme/c/ppc32.c b/src/ChezScheme/c/ppc32.c index 6607771e84..1932d3051f 100644 --- a/src/ChezScheme/c/ppc32.c +++ b/src/ChezScheme/c/ppc32.c @@ -54,11 +54,16 @@ void S_doflush(uptr start, uptr end) { } void S_machine_init() { +#if defined(__linux__) if ((l1_dcache_line_size = sysconf(_SC_LEVEL1_DCACHE_LINESIZE)) <= 0) { l1_dcache_line_size = DEFAULT_L1_MAX_CACHE_LINE_SIZE; } if ((l1_icache_line_size = sysconf(_SC_LEVEL1_ICACHE_LINESIZE)) <= 0) { l1_icache_line_size = DEFAULT_L1_MAX_CACHE_LINE_SIZE; } +#else + l1_dcache_line_size = DEFAULT_L1_MAX_CACHE_LINE_SIZE; + l1_icache_line_size = DEFAULT_L1_MAX_CACHE_LINE_SIZE; +#endif l1_max_cache_line_size = l1_dcache_line_size > l1_icache_line_size ? l1_dcache_line_size : l1_icache_line_size; } diff --git a/src/ChezScheme/c/prim.c b/src/ChezScheme/c/prim.c index e6ffca80d6..c2194edc97 100644 --- a/src/ChezScheme/c/prim.c +++ b/src/ChezScheme/c/prim.c @@ -132,6 +132,7 @@ static void create_c_entry_vector() { S_install_c_entry(CENTRY_raw_collect_cond, TO_PTR(&S_collect_cond)); S_install_c_entry(CENTRY_raw_collect_thread0_cond, TO_PTR(&S_collect_thread0_cond)); S_install_c_entry(CENTRY_raw_tc_mutex, TO_PTR(&S_tc_mutex)); + S_install_c_entry(CENTRY_raw_terminated_cond, TO_PTR(&S_terminated_cond)); S_install_c_entry(CENTRY_activate_thread, proc2ptr(S_activate_thread)); S_install_c_entry(CENTRY_deactivate_thread, proc2ptr(Sdeactivate_thread)); S_install_c_entry(CENTRY_unactivate_thread, proc2ptr(S_unactivate_thread)); @@ -150,6 +151,9 @@ static void create_c_entry_vector() { S_install_c_entry(CENTRY_Scall_any_results, proc2ptr(S_call_any_results)); S_install_c_entry(CENTRY_segment_info, proc2ptr(S_segment_info)); S_install_c_entry(CENTRY_bignum_mask_test, proc2ptr(S_bignum_mask_test)); + S_install_c_entry(CENTRY_null_immutable_vector, TO_PTR(S_G.null_immutable_vector)); + S_install_c_entry(CENTRY_null_immutable_bytevector, TO_PTR(S_G.null_immutable_bytevector)); + S_install_c_entry(CENTRY_null_immutable_string, TO_PTR(S_G.null_immutable_string)); } void S_check_c_entry_vector() { @@ -158,7 +162,7 @@ void S_check_c_entry_vector() { for (i = 0; i < c_entry_vector_size; i++) { #ifndef PTHREADS if (i == CENTRY_raw_collect_cond || i == CENTRY_raw_collect_thread0_cond - || i == CENTRY_raw_tc_mutex + || i == CENTRY_raw_tc_mutex || i == CENTRY_raw_terminated_cond || i == CENTRY_activate_thread || i == CENTRY_deactivate_thread || i == CENTRY_unactivate_thread) continue; @@ -224,6 +228,8 @@ static void s_instantiate_code_object() { cookie = S_get_scheme_arg(tc, 2); proc = S_get_scheme_arg(tc, 3); + S_thread_start_code_write(); + new = S_code(tc, CODETYPE(old), CODELEN(old)); S_immobilize_object(new); @@ -274,12 +280,15 @@ static void s_instantiate_code_object() { } S_flush_instruction_cache(tc); + S_thread_end_code_write(); + AC0(tc) = new; } static void s_link_code_object(co, objs) ptr co, objs; { ptr t; uptr a, m, n; + S_thread_start_code_write(); t = CODERELOC(co); m = RELOCSIZE(t); a = 0; @@ -298,6 +307,7 @@ static void s_link_code_object(co, objs) ptr co, objs; { S_set_code_obj("gc", RELOC_TYPE(entry), co, a, Scar(objs), item_off); objs = Scdr(objs); } + S_thread_end_code_write(); } static INT s_check_heap_enabledp(void) { diff --git a/src/ChezScheme/c/prim5.c b/src/ChezScheme/c/prim5.c index 06d0599426..5d1566aef0 100644 --- a/src/ChezScheme/c/prim5.c +++ b/src/ChezScheme/c/prim5.c @@ -53,7 +53,9 @@ static void s_showalloc PROTO((IBOOL show_dump, const char *outfn)); static ptr s_system PROTO((const char *s)); static ptr s_process PROTO((char *s, IBOOL stderrp)); static I32 s_chdir PROTO((const char *inpath)); +#ifdef GETWD static char *s_getwd PROTO((void)); +#endif static ptr s_set_code_byte PROTO((ptr p, ptr n, ptr x)); static ptr s_set_code_word PROTO((ptr p, ptr n, ptr x)); static ptr s_set_code_long PROTO((ptr p, ptr n, ptr x)); @@ -97,6 +99,7 @@ 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_thread_preserve_ownership PROTO((ptr tc)); #endif static void s_byte_copy(ptr src, iptr srcoff, ptr dst, iptr dstoff, iptr cnt); static void s_ptr_copy(ptr src, iptr srcoff, ptr dst, iptr dstoff, iptr cnt); @@ -208,7 +211,7 @@ static ptr s_box_immobile(p) ptr p; { } static ptr s_make_immobile_bytevector(uptr len) { - ptr b = S_bytevector2(len, 1); + ptr b = S_bytevector2(get_thread_context(), len, 1); S_immobilize_object(b); return b; } @@ -272,6 +275,10 @@ static ptr sorted_chunk_list(void) { ls = Scons(TO_PTR(chunk), ls); n += 1; } + for (chunk = (i == -1) ? S_code_chunks_full : S_code_chunks[i]; chunk != NULL; chunk = chunk->next) { + ls = Scons(TO_PTR(chunk), ls); + n += 1; + } } return sort_chunks(ls, n); @@ -403,6 +410,7 @@ static void s_showalloc(IBOOL show_dump, const char *outfn) { ptr tc = get_thread_context(); tc_mutex_acquire(); + alloc_mutex_acquire(); if (outfn == NULL) { out = stderr; @@ -627,6 +635,7 @@ static void s_showalloc(IBOOL show_dump, const char *outfn) { fclose(out); } + alloc_mutex_release(); tc_mutex_release(); } @@ -869,47 +878,64 @@ static char *s_getwd() { static ptr s_set_code_byte(p, n, x) ptr p, n, x; { I8 *a; + S_thread_start_code_write(); a = (I8 *)TO_VOIDP((uptr)p + UNFIX(n)); *a = (I8)UNFIX(x); + S_thread_end_code_write(); + return Svoid; } static ptr s_set_code_word(p, n, x) ptr p, n, x; { I16 *a; + S_thread_start_code_write(); a = (I16 *)TO_VOIDP((uptr)p + UNFIX(n)); *a = (I16)UNFIX(x); + S_thread_end_code_write(); + return Svoid; } static ptr s_set_code_long(p, n, x) ptr p, n, x; { I32 *a; + S_thread_start_code_write(); a = (I32 *)TO_VOIDP((uptr)p + UNFIX(n)); *a = (I32)(Sfixnump(x) ? UNFIX(x) : Sinteger_value(x)); + S_thread_end_code_write(); + return Svoid; } static void s_set_code_long2(p, n, h, l) ptr p, n, h, l; { I32 *a; + S_thread_start_code_write(); a = (I32 *)TO_VOIDP((uptr)p + UNFIX(n)); *a = (I32)((UNFIX(h) << 16) + UNFIX(l)); + S_thread_end_code_write(); } static ptr s_set_code_quad(p, n, x) ptr p, n, x; { I64 *a; + S_thread_start_code_write(); a = (I64 *)TO_VOIDP((uptr)p + UNFIX(n)); *a = Sfixnump(x) ? UNFIX(x) : S_int64_value("\\#set-code-quad!", x); + S_thread_end_code_write(); + return Svoid; } static ptr s_set_reloc(p, n, e) ptr p, n, e; { iptr *a; + S_thread_start_code_write(); a = (iptr *)(&RELOCIT(CODERELOC(p), UNFIX(n))); *a = Sfixnump(e) ? UNFIX(e) : Sinteger_value(e); + S_thread_end_code_write(); + return e; } @@ -922,6 +948,8 @@ static ptr s_make_code(flags, free, name, arity_mark, n, info, pinfos) iptr flags, free, n; ptr name, arity_mark, info, pinfos; { ptr co; + S_thread_start_code_write(); + co = S_code(get_thread_context(), type_code | (flags << code_flags_offset), n); CODEFREE(co) = free; CODENAME(co) = name; @@ -931,12 +959,17 @@ static ptr s_make_code(flags, free, name, arity_mark, n, info, pinfos) if (pinfos != Snil) { S_G.profile_counters = Scons(S_weak_cons(co, pinfos), S_G.profile_counters); } + + S_thread_end_code_write(); + return co; } static ptr s_make_reloc_table(codeobj, n) ptr codeobj, n; { + S_thread_start_code_write(); CODERELOC(codeobj) = S_relocation_table(UNFIX(n)); RELOCCODE(CODERELOC(codeobj)) = codeobj; + S_thread_end_code_write(); return Svoid; } @@ -1315,6 +1348,9 @@ extern double log1p(); #endif /* LOG1P */ #endif /* defined(__STDC__) || defined(USE_ANSI_PROTOTYPES) */ +static double s_mod PROTO((double x, double y)); +static double s_mod(x, y) double x, y; { return fmod(x, y); } + static double s_exp PROTO((double x)); static double s_exp(x) double x; { return exp(x); } @@ -1481,7 +1517,11 @@ static iptr s_backdoor_thread(p) ptr p; { } static ptr s_threads() { - return S_threads; + ptr ts; + tc_mutex_acquire(); + ts = S_threads; + tc_mutex_release(); + return ts; } static void s_mutex_acquire(m) scheme_mutex_t *m; { @@ -1514,6 +1554,15 @@ static void s_condition_broadcast(s_thread_cond_t *c) { static void s_condition_signal(s_thread_cond_t *c) { s_thread_cond_signal(c); } + +/* called with tc mutex held */ +static void s_thread_preserve_ownership(ptr tc) { + if (!THREAD_GC(tc)->preserve_ownership) { + THREAD_GC(tc)->preserve_ownership = 1; + S_num_preserve_ownership_threads++; + } +} + #endif static ptr s_profile_counters(void) { @@ -1593,6 +1642,7 @@ void S_prim5_init() { 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)thread_preserve_ownership", (void *)s_thread_preserve_ownership); #endif Sforeign_symbol("(cs)s_addr_in_heap", (void *)s_addr_in_heap); Sforeign_symbol("(cs)s_ptr_in_heap", (void *)s_ptr_in_heap); @@ -1628,6 +1678,8 @@ void S_prim5_init() { Sforeign_symbol("(cs)s_strings_to_gensym", (void *)s_strings_to_gensym); Sforeign_symbol("(cs)s_intern_gensym", (void *)S_intern_gensym); Sforeign_symbol("(cs)s_uninterned", (void *)S_uninterned); + Sforeign_symbol("(cs)symbol_hash32", (void *)S_symbol_hash32); + Sforeign_symbol("(cs)symbol_hash64", (void *)S_symbol_hash64); Sforeign_symbol("(cs)cputime", (void *)S_cputime); Sforeign_symbol("(cs)realtime", (void *)S_realtime); Sforeign_symbol("(cs)clock_gettime", (void *)S_clock_gettime); @@ -1656,9 +1708,7 @@ void S_prim5_init() { Sforeign_symbol("(cs)getpid", (void *)s_getpid); Sforeign_symbol("(cs)fasl_read", (void *)S_fasl_read); Sforeign_symbol("(cs)bv_fasl_read", (void *)S_bv_fasl_read); - Sforeign_symbol("(cs)to_vfasl", (void *)S_to_vfasl); Sforeign_symbol("(cs)vfasl_to", (void *)S_vfasl_to); - Sforeign_symbol("(cs)vfasl_can_combinep", (void *)S_vfasl_can_combinep); Sforeign_symbol("(cs)s_decode_float", (void *)s_decode_float); Sforeign_symbol("(cs)new_open_input_fd", (void *)S_new_open_input_fd); @@ -1737,6 +1787,7 @@ void S_prim5_init() { Sforeign_symbol("(cs)dequeue_scheme_signals", (void *)S_dequeue_scheme_signals); Sforeign_symbol("(cs)register_scheme_signal", (void *)S_register_scheme_signal); + Sforeign_symbol("(cs)mod", (void *)s_mod); Sforeign_symbol("(cs)exp", (void *)s_exp); Sforeign_symbol("(cs)log", (void *)s_log); Sforeign_symbol("(cs)pow", (void *)s_pow); diff --git a/src/ChezScheme/c/print.c b/src/ChezScheme/c/print.c index 5054582389..a711ee684c 100644 --- a/src/ChezScheme/c/print.c +++ b/src/ChezScheme/c/print.c @@ -32,6 +32,7 @@ static void pstr PROTO((ptr x)); static void psym PROTO((ptr x)); static void pvec PROTO((ptr x)); static void pfxvector PROTO((ptr x)); +static void pflvector PROTO((ptr x)); static void pbytevector PROTO((ptr x)); static void pflonum PROTO((ptr x)); static void pflodat PROTO((double x)); @@ -54,6 +55,7 @@ void S_prin1(x) ptr x; { else if (Sexactnump(x)) pexactnum(x); else if (Svectorp(x)) pvec(x); else if (Sfxvectorp(x)) pfxvector(x); + else if (Sflvectorp(x)) pflvector(x); else if (Sbytevectorp(x)) pbytevector(x); else if (Sboxp(x)) pbox(x); else if (Sprocedurep(x)) pclo(x); @@ -159,12 +161,16 @@ static void pstr(x) ptr x; { } static void display_string(x) ptr x; { - iptr i, n = Sstring_length(x); - - for (i = 0; i < n; i += 1) { - int k = Sstring_ref(x, i); - if (k >= 256) k = '?'; - putchar(k); + if (!Sstringp(x)) { + printf("#<garbage-string>"); + } else { + iptr i, n = Sstring_length(x); + + for (i = 0; i < n; i += 1) { + int k = Sstring_ref(x, i); + if (k >= 256) k = '?'; + putchar(k); + } } } @@ -227,6 +233,25 @@ static void pfxvector(x) ptr x; { putchar(')'); } +static void pflvector(x) ptr x; { + iptr n; + + putchar('#'); + n = Sflvector_length(x); + wrint(FIX(n)); + printf("vfl("); + if (n != 0) { + iptr i = 0; + + while (1) { + pflodat(Sflvector_ref(x, i)); + if (++i == n) break; + putchar(' '); + } + } + putchar(')'); +} + static void pbytevector(x) ptr x; { iptr n; diff --git a/src/ChezScheme/c/scheme.c b/src/ChezScheme/c/scheme.c index aa0f7d826b..196916cdfc 100644 --- a/src/ChezScheme/c/scheme.c +++ b/src/ChezScheme/c/scheme.c @@ -104,16 +104,12 @@ static void main_init() { i & 0x10 ? 4 : i & 0x20 ? 5 : i & 0x40 ? 6 : i & 0x80 ? 7 : 0); } - NULLIMMUTABLEVECTOR(tc) = S_G.null_immutable_vector; - NULLIMMUTABLEFXVECTOR(tc) = S_G.null_immutable_fxvector; - NULLIMMUTABLEBYTEVECTOR(tc) = S_G.null_immutable_bytevector; - NULLIMMUTABLESTRING(tc) = S_G.null_immutable_string; - PARAMETERS(tc) = S_G.null_vector; for (i = 0 ; i < virtual_register_count ; i += 1) { VIRTREG(tc, i) = FIX(0); } + S_thread_start_code_write(); p = S_code(tc, type_code, size_rp_header); CODERELOC(p) = S_relocation_table(0); CODENAME(p) = Sfalse; @@ -127,6 +123,7 @@ static void main_init() { (uptr)TO_PTR(&RPHEADERTOPLINK(TO_PTR(&CODEIT(p, 0)))) - (uptr)p; S_protect(&S_G.dummy_code_object); S_G.dummy_code_object = p; + S_thread_end_code_write(); S_protect(&S_G.error_invoke_code_object); S_G.error_invoke_code_object = Snil; @@ -417,7 +414,7 @@ void S_generic_invoke(tc, code) ptr tc; ptr code; { __except(GetExceptionCode() == EXCEPTION_ACCESS_VIOLATION ? EXCEPTION_EXECUTE_HANDLER : EXCEPTION_CONTINUE_SEARCH) { - if (S_pants_down) + if (THREAD_GC(tc)->during_alloc) S_error_abort("nonrecoverable invalid memory reference"); else S_error_reset("invalid memory reference"); @@ -577,6 +574,9 @@ static IBOOL next_path(path, name, ext, sp, dsp) char *path; const char *name, * typedef struct { INT fd; + iptr len; /* 0 => unknown */ + iptr offset; + IBOOL need_check, close_after; char path[PATH_MAX]; } boot_desc; @@ -587,11 +587,83 @@ static boot_desc bd[MAX_BOOT_FILES]; static octet get_u8 PROTO((INT fd)); static uptr get_uptr PROTO((INT fd, uptr *pn)); static INT get_string PROTO((INT fd, char *s, iptr max, INT *c)); -static IBOOL find_boot PROTO((const char *name, const char *ext, IBOOL direct_pathp, int fd, IBOOL errorp)); static void load PROTO((ptr tc, iptr n, IBOOL base)); static void check_boot_file_state PROTO((const char *who)); -static IBOOL find_boot(name, ext, direct_pathp, fd, errorp) const char *name, *ext; int fd; IBOOL direct_pathp, errorp; { +static IBOOL check_boot(int fd, IBOOL verbose, const char *path) { + uptr n = 0; + + /* check for magic number */ + if (get_u8(fd) != fasl_type_header || + get_u8(fd) != 0 || + get_u8(fd) != 0 || + get_u8(fd) != 0 || + get_u8(fd) != 'c' || + get_u8(fd) != 'h' || + get_u8(fd) != 'e' || + get_u8(fd) != 'z') { + if (verbose) fprintf(stderr, "malformed fasl-object header in %s\n", path); + CLOSE(fd); + return 0; + } + + /* check version */ + if (get_uptr(fd, &n) != 0) { + if (verbose) fprintf(stderr, "unexpected end of file on %s\n", path); + CLOSE(fd); + return 0; + } + + if (n != scheme_version) { + if (verbose) { + fprintf(stderr, "%s is for Version %s; ", path, S_format_scheme_version(n)); + /* use separate fprintf since S_format_scheme_version returns static string */ + fprintf(stderr, "need Version %s\n", S_format_scheme_version(scheme_version)); + } + CLOSE(fd); + return 0; + } + + /* check machine type */ + if (get_uptr(fd, &n) != 0) { + if (verbose) fprintf(stderr, "unexpected end of file on %s\n", path); + CLOSE(fd); + return 0; + } + + if (n != machine_type) { + if (verbose) + fprintf(stderr, "%s is for machine-type %s; need machine-type %s\n", path, + S_lookup_machine_type(n), S_lookup_machine_type(machine_type)); + CLOSE(fd); + return 0; + } + + return 1; +} + +static void check_dependencies_header(int fd, const char *path) { + if (get_u8(fd) != '(') { /* ) */ + fprintf(stderr, "malformed boot file %s\n", path); + CLOSE(fd); + S_abnormal_exit(); + } +} + +static void finish_dependencies_header(int fd, const char *path, int c) { + while (c != ')') { + if (c < 0) { + fprintf(stderr, "malformed boot file %s\n", path); + CLOSE(fd); + S_abnormal_exit(); + } + c = get_u8(fd); + } +} + +static IBOOL find_boot(const char *name, const char *ext, IBOOL direct_pathp, + int fd, + IBOOL errorp) { char pathbuf[PATH_MAX], buf[PATH_MAX]; uptr n = 0; INT c; @@ -623,53 +695,14 @@ static IBOOL find_boot(name, ext, direct_pathp, fd, errorp) const char *name, *e } if (verbose) fprintf(stderr, "trying %s...opened\n", path); - /* check for magic number */ - if (get_u8(fd) != fasl_type_header || - get_u8(fd) != 0 || - get_u8(fd) != 0 || - get_u8(fd) != 0 || - get_u8(fd) != 'c' || - get_u8(fd) != 'h' || - get_u8(fd) != 'e' || - get_u8(fd) != 'z') { - fprintf(stderr, "malformed fasl-object header in %s\n", path); - S_abnormal_exit(); - } - - /* check version */ - if (get_uptr(fd, &n) != 0) { - fprintf(stderr, "unexpected end of file on %s\n", path); - CLOSE(fd); - S_abnormal_exit(); - } - - if (n != scheme_version) { - fprintf(stderr, "%s is for Version %s; ", path, S_format_scheme_version(n)); - /* use separate fprintf since S_format_scheme_version returns static string */ - fprintf(stderr, "need Version %s\n", S_format_scheme_version(scheme_version)); - CLOSE(fd); - S_abnormal_exit(); - } - - /* check machine type */ - if (get_uptr(fd, &n) != 0) { - fprintf(stderr, "unexpected end of file on %s\n", path); - CLOSE(fd); + if (!check_boot(fd, 1, path)) S_abnormal_exit(); - } - - if (n != machine_type) { - fprintf(stderr, "%s is for machine-type %s; need machine-type %s\n", path, - S_lookup_machine_type(n), S_lookup_machine_type(machine_type)); - CLOSE(fd); - S_abnormal_exit(); - } } else { const char *sp = Sschemeheapdirs; const char *dsp = Sdefaultheapdirs; path = pathbuf; - for (;;) { + while (1) { if (!next_path(pathbuf, name, ext, &sp, &dsp)) { if (errorp) { fprintf(stderr, "cannot find compatible boot file %s%s in search path:\n \"%s%s\"\n", @@ -692,63 +725,14 @@ static IBOOL find_boot(name, ext, direct_pathp, fd, errorp) const char *name, *e if (verbose) fprintf(stderr, "trying %s...opened\n", path); - /* check for magic number */ - if (get_u8(fd) != fasl_type_header || - get_u8(fd) != 0 || - get_u8(fd) != 0 || - get_u8(fd) != 0 || - get_u8(fd) != 'c' || - get_u8(fd) != 'h' || - get_u8(fd) != 'e' || - get_u8(fd) != 'z') { - if (verbose) fprintf(stderr, "malformed fasl-object header in %s\n", path); - CLOSE(fd); - continue; - } - - /* check version */ - if (get_uptr(fd, &n) != 0) { - if (verbose) fprintf(stderr, "unexpected end of file on %s\n", path); - CLOSE(fd); - continue; - } - - if (n != scheme_version) { - if (verbose) { - fprintf(stderr, "%s is for Version %s; ", path, S_format_scheme_version(n)); - /* use separate fprintf since S_format_scheme_version returns static string */ - fprintf(stderr, "need Version %s\n", S_format_scheme_version(scheme_version)); - } - CLOSE(fd); - continue; - } - - /* check machine type */ - if (get_uptr(fd, &n) != 0) { - if (verbose) fprintf(stderr, "unexpected end of file on %s\n", path); - CLOSE(fd); - continue; - } - - if (n != machine_type) { - if (verbose) - fprintf(stderr, "%s is for machine-type %s; need machine-type %s\n", path, - S_lookup_machine_type(n), S_lookup_machine_type(machine_type)); - CLOSE(fd); - continue; - } - - break; + if (check_boot(fd, verbose, path)) + break; } } if (verbose) fprintf(stderr, "version and machine type check\n"); - if (get_u8(fd) != '(') { /* ) */ - fprintf(stderr, "malformed boot file %s\n", path); - CLOSE(fd); - S_abnormal_exit(); - } + check_dependencies_header(fd, path); /* ( */ if ((c = get_u8(fd)) == ')') { @@ -792,14 +776,7 @@ static IBOOL find_boot(name, ext, direct_pathp, fd, errorp) const char *name, *e } /* skip to end of header */ - while (c != ')') { - if (c < 0) { - fprintf(stderr, "malformed boot file %s\n", path); - CLOSE(fd); - S_abnormal_exit(); - } - c = get_u8(fd); - } + finish_dependencies_header(fd, path, c); } if (boot_count >= MAX_BOOT_FILES) { @@ -808,6 +785,10 @@ static IBOOL find_boot(name, ext, direct_pathp, fd, errorp) const char *name, *e } bd[boot_count].fd = fd; + bd[boot_count].offset = 0; + bd[boot_count].len = 0; + bd[boot_count].need_check = 0; + bd[boot_count].close_after = 1; strcpy(bd[boot_count].path, path); boot_count += 1; @@ -883,6 +864,16 @@ static void boot_element(ptr tc, ptr x, iptr n) { static void load(tc, n, base) ptr tc; iptr n; IBOOL base; { ptr x; iptr i; + if (bd[n].need_check) { + if (LSEEK(bd[n].fd, bd[n].offset, SEEK_SET) != bd[n].offset) { + fprintf(stderr, "seek in boot file %s failed\n", bd[n].path); + S_abnormal_exit(); + } + check_boot(bd[n].fd, 1, bd[n].path); + check_dependencies_header(bd[n].fd, bd[n].path); + finish_dependencies_header(bd[n].fd, bd[n].path, 0); + } + if (base) { S_G.error_invoke_code_object = S_boot_read(bd[n].fd, bd[n].path); if (!Scodep(S_G.error_invoke_code_object)) { @@ -919,7 +910,8 @@ static void load(tc, n, base) ptr tc; iptr n; IBOOL base; { } S_G.load_binary = Sfalse; - CLOSE(bd[n].fd); + if (bd[n].close_after) + CLOSE(bd[n].fd); } /***************************************************************************/ @@ -968,7 +960,7 @@ extern void Sretain_static_relocation(void) { #endif static void default_abnormal_exit(void) { - exit(1); + abort(); } extern void Sscheme_init(abnormal_exit) void (*abnormal_exit) PROTO((void)); { @@ -1060,6 +1052,27 @@ extern void Sregister_boot_file_fd(name, fd) const char *name; int fd; { find_boot(name, "", 1, fd, 1); } +extern void Sregister_boot_file_fd_region(const char *name, + int fd, + iptr offset, + iptr len, + int close_after) { + check_boot_file_state("Sregister_boot_file_fd"); + + if (strlen(name) >= PATH_MAX) { + fprintf(stderr, "boot-file path is too long %s\n", name); + S_abnormal_exit(); + } + + bd[boot_count].fd = fd; + bd[boot_count].offset = offset; + bd[boot_count].len = len; + bd[boot_count].need_check = 1; + bd[boot_count].close_after = close_after; + strcpy(bd[boot_count].path, name); + boot_count += 1; +} + extern void Sregister_heap_file(UNUSED const char *path) { fprintf(stderr, "Sregister_heap_file: saved heap files are not presently supported\n"); S_abnormal_exit(); diff --git a/src/ChezScheme/c/schsig.c b/src/ChezScheme/c/schsig.c index d2e9ce76c2..5715f3ada0 100644 --- a/src/ChezScheme/c/schsig.c +++ b/src/ChezScheme/c/schsig.c @@ -127,11 +127,8 @@ void S_split_and_resize() { * and clength + size(values) < stack-size; also, size may include * argument register values */ n = CONTCLENGTH(k) + (value_count * sizeof(ptr)) + stack_slop; - if (n >= SCHEMESTACKSIZE(tc)) { - tc_mutex_acquire(); + if (n >= SCHEMESTACKSIZE(tc)) S_reset_scheme_stack(tc, n); - tc_mutex_release(); - } } iptr S_continuation_depth(k) ptr k; { @@ -272,7 +269,6 @@ void S_overflow(tc, frame_request) ptr tc; iptr frame_request; { } /* create a continuation */ - tc_mutex_acquire(); STACKLINK(tc) = S_mkcontinuation(space_new, 0, CODEENTRYPOINT(nuate), @@ -283,7 +279,6 @@ void S_overflow(tc, frame_request) ptr tc; iptr frame_request; { *split_point, Snil, Sfalse); - tc_mutex_release(); /* overwrite old return address with dounderflow */ *split_point = TO_PTR(DOUNDERFLOW); @@ -296,9 +291,7 @@ void S_overflow(tc, frame_request) ptr tc; iptr frame_request; { /* allocate a new stack, retaining same relative sfp */ sfp_offset = (uptr)TO_PTR(sfp) - (uptr)TO_PTR(split_point); - tc_mutex_acquire(); S_reset_scheme_stack(tc, above_split_size + frame_request); - tc_mutex_release(); SFP(tc) = (ptr)((uptr)SCHEMESTACK(tc) + sfp_offset); /* copy up everything above the split point. we don't know where the @@ -318,20 +311,21 @@ void S_error_abort(s) const char *s; { void S_abnormal_exit() { S_abnormal_exit_proc(); fprintf(stderr, "abnormal_exit procedure did not exit\n"); - exit(1); + abort(); } static void reset_scheme() { ptr tc = get_thread_context(); - tc_mutex_acquire(); + alloc_mutex_acquire(); /* eap should always be up-to-date now that we write-through to the tc when making any changes to eap when eap is a real register */ S_scan_dirty(TO_VOIDP(EAP(tc)), TO_VOIDP(REAL_EAP(tc))); S_reset_allocation_pointer(tc); S_reset_scheme_stack(tc, stack_slop); + alloc_mutex_release(); FRAME(tc,0) = TO_PTR(DOUNDERFLOW); - tc_mutex_release(); + S_maybe_fire_collector(THREAD_GC(tc)); } /* error_resets occur with the system in an unknown state, @@ -391,11 +385,14 @@ static void do_error(type, who, s, args) iptr type; const char *who, *s; ptr arg Scons(Sstring_utf8(s, -1), args))); #ifdef PTHREADS - while (S_tc_mutex_depth > 0) { + while (S_mutex_is_owner(&S_alloc_mutex)) + S_mutex_release(&S_alloc_mutex); + while (S_mutex_is_owner(&S_tc_mutex)) S_mutex_release(&S_tc_mutex); - S_tc_mutex_depth -= 1; - } #endif /* PTHREADS */ + + /* in case error is during fasl read: */ + S_thread_end_code_write(); TRAP(tc) = (ptr)1; AC0(tc) = (ptr)1; @@ -511,7 +508,7 @@ void S_fire_collector() { /* printf("firing collector!\n"); fflush(stdout); */ - if (!Sboolean_value(S_symbol_value(crp_id))) { + if (!Sboolean_value(S_symbol_racy_value(crp_id))) { ptr ls; /* printf("really firing collector!\n"); fflush(stdout); */ @@ -565,7 +562,7 @@ static BOOL WINAPI handle_signal(DWORD dwCtrlType) { #else ptr tc = get_thread_context(); #endif - if (!S_pants_down && Sboolean_value(KEYBOARDINTERRUPTPENDING(tc))) + if (!THREAD_GC(tc)->during_alloc && Sboolean_value(KEYBOARDINTERRUPTPENDING(tc))) return(FALSE); keyboard_interrupt(tc); return(TRUE); @@ -689,7 +686,7 @@ static void handle_signal(INT sig, UNUSED siginfo_t *si, UNUSED void *data) { /* disable keyboard interrupts in subordinate threads until we think of something more clever to do with them */ if (tc == TO_PTR(&S_G.thread_context)) { - if (!S_pants_down && Sboolean_value(KEYBOARDINTERRUPTPENDING(tc))) { + if (!THREAD_GC(tc)->during_alloc && Sboolean_value(KEYBOARDINTERRUPTPENDING(tc))) { /* this is a no-no, but the only other options are to ignore the signal or to kill the process */ RESET_SIGNAL @@ -715,11 +712,14 @@ static void handle_signal(INT sig, UNUSED siginfo_t *si, UNUSED void *data) { case SIGBUS: #endif /* SIGBUS */ case SIGSEGV: + { + ptr tc = get_thread_context(); RESET_SIGNAL - if (S_pants_down) + if (THREAD_GC(tc)->during_alloc) S_error_abort("nonrecoverable invalid memory reference"); else S_error_reset("invalid memory reference"); + } default: RESET_SIGNAL S_error_reset("unexpected signal"); @@ -786,6 +786,7 @@ void S_schsig_init() { S_protect(&S_G.collect_request_pending_id); S_G.collect_request_pending_id = S_intern((const unsigned char *)"$collect-request-pending"); + S_thread_start_code_write(); p = S_code(get_thread_context(), type_code | (code_flag_continuation << code_flags_offset), 0); CODERELOC(p) = S_relocation_table(0); CODENAME(p) = Sfalse; @@ -793,6 +794,7 @@ void S_schsig_init() { CODEFREE(p) = 0; CODEINFO(p) = Sfalse; CODEPINFOS(p) = Snil; + S_thread_end_code_write(); S_set_symbol_value(S_G.null_continuation_id, S_mkcontinuation(space_new, @@ -820,7 +822,6 @@ void S_schsig_init() { } - S_pants_down = 0; S_set_symbol_value(S_G.collect_request_pending_id, Sfalse); init_signal_handlers(); diff --git a/src/ChezScheme/c/segment.c b/src/ChezScheme/c/segment.c index b3a6d29378..fbec515adc 100644 --- a/src/ChezScheme/c/segment.c +++ b/src/ChezScheme/c/segment.c @@ -38,7 +38,7 @@ Low-level Memory management strategy: static void out_of_memory PROTO((void)); static void initialize_seginfo PROTO((seginfo *si, thread_gc *creator, ISPC s, IGEN g)); -static seginfo *allocate_segments PROTO((uptr nreq)); +static seginfo *allocate_segments PROTO((uptr nreq, IBOOL for_code)); static void expand_segment_table PROTO((uptr base, uptr end, seginfo *si)); static void contract_segment_table PROTO((uptr base, uptr end)); static void add_to_chunk_list PROTO((chunkinfo *chunk, chunkinfo **pchunk_list)); @@ -51,7 +51,11 @@ void S_segment_init() { if (!S_boot_time) return; S_chunks_full = NULL; - for (i = PARTIAL_CHUNK_POOLS; i >= 0; i -= 1) S_chunks[i] = NULL; + S_code_chunks_full = NULL; + for (i = PARTIAL_CHUNK_POOLS; i >= 0; i -= 1) { + S_chunks[i] = NULL; + S_code_chunks[i] = NULL; + } for (g = 0; g <= static_generation; g++) { for (s = 0; s <= max_real_space; s++) { S_G.occupied_segments[g][s] = NULL; @@ -79,7 +83,7 @@ static void out_of_memory(void) { } #if defined(USE_MALLOC) -void *S_getmem(iptr bytes, IBOOL zerofill) { +void *S_getmem(iptr bytes, IBOOL zerofill, UNUSED IBOOL for_code) { void *addr; if ((addr = malloc(bytes)) == (void *)0) out_of_memory(); @@ -99,7 +103,7 @@ void S_freemem(void *addr, iptr bytes) { #if defined(USE_VIRTUAL_ALLOC) #include <WinBase.h> -void *S_getmem(iptr bytes, IBOOL zerofill) { +void *S_getmem(iptr bytes, IBOOL zerofill, IBOOL for_code) { void *addr; if ((uptr)bytes < S_pagesize) { @@ -109,7 +113,8 @@ void *S_getmem(iptr bytes, IBOOL zerofill) { if (zerofill) memset(addr, 0, bytes); } else { uptr n = S_pagesize - 1; iptr p_bytes = (iptr)(((uptr)bytes + n) & ~n); - if ((addr = VirtualAlloc((void *)0, (SIZE_T)p_bytes, MEM_COMMIT, PAGE_EXECUTE_READWRITE)) == (void *)0) out_of_memory(); + int perm = (for_code ? PAGE_EXECUTE_READWRITE : PAGE_READWRITE); + if ((addr = VirtualAlloc((void *)0, (SIZE_T)p_bytes, MEM_COMMIT, perm)) == (void *)0) out_of_memory(); if ((membytes += p_bytes) > maxmembytes) maxmembytes = membytes; debug(printf("getmem VirtualAlloc(%p => %p) -> %p\n", bytes, p_bytes, addr)) } @@ -136,7 +141,7 @@ void S_freemem(void *addr, iptr bytes) { #ifndef MAP_ANONYMOUS #define MAP_ANONYMOUS MAP_ANON #endif -void *S_getmem(iptr bytes, IBOOL zerofill) { +void *S_getmem(iptr bytes, IBOOL zerofill, IBOOL for_code) { void *addr; if ((uptr)bytes < S_pagesize) { @@ -146,12 +151,14 @@ void *S_getmem(iptr bytes, IBOOL zerofill) { if (zerofill) memset(addr, 0, bytes); } else { uptr n = S_pagesize - 1; iptr p_bytes = (iptr)(((uptr)bytes + n) & ~n); + int perm = (for_code ? S_PROT_CODE : (PROT_WRITE | PROT_READ)); + int flags = (MAP_PRIVATE | MAP_ANONYMOUS) | (for_code ? S_MAP_CODE : 0); #ifdef MAP_32BIT /* try for first 2GB of the memory space first of x86_64 so that we have a better chance of having short jump instructions */ - if ((addr = mmap(NULL, p_bytes, PROT_EXEC|PROT_WRITE|PROT_READ, MAP_PRIVATE|MAP_ANONYMOUS|MAP_32BIT, -1, 0)) == (void *)-1) { + if ((addr = mmap(NULL, p_bytes, perm, flags|MAP_32BIT, -1, 0)) == (void *)-1) { #endif - if ((addr = mmap(NULL, p_bytes, PROT_EXEC|PROT_WRITE|PROT_READ, MAP_PRIVATE|MAP_ANONYMOUS, -1, 0)) == (void *)-1) { + if ((addr = mmap(NULL, p_bytes, perm, flags, -1, 0)) == (void *)-1) { out_of_memory(); debug(printf("getmem mmap(%p) -> %p\n", bytes, addr)) } @@ -256,27 +263,31 @@ static void initialize_seginfo(seginfo *si, NO_THREADS_UNUSED thread_gc *creator si->sweep_next = NULL; } +/* allocation mutex must be held */ iptr S_find_segments(creator, s, g, n) thread_gc *creator; ISPC s; IGEN g; iptr n; { - chunkinfo *chunk, *nextchunk; + chunkinfo *chunk, *nextchunk, **chunks; seginfo *si, *nextsi, **prevsi; iptr nunused_segs, j; INT i, loser_index; + IBOOL for_code = ((s == space_code)); if (g != static_generation) S_G.number_of_nonstatic_segments += n; debug(printf("attempting to find %d segments for space %d, generation %d\n", n, s, g)) + chunks = (for_code ? S_code_chunks : S_chunks); + if (n == 1) { for (i = 0; i <= PARTIAL_CHUNK_POOLS; i++) { - chunk = S_chunks[i]; + chunk = chunks[i]; if (chunk != NULL) { si = chunk->unused_segs; chunk->unused_segs = si->next; if (chunk->unused_segs == NULL) { - S_move_to_chunk_list(chunk, &S_chunks_full); + S_move_to_chunk_list(chunk, (for_code ? &S_code_chunks_full : &S_chunks_full)); } else if (i == PARTIAL_CHUNK_POOLS) { - S_move_to_chunk_list(chunk, &S_chunks[PARTIAL_CHUNK_POOLS-1]); + S_move_to_chunk_list(chunk, &chunks[PARTIAL_CHUNK_POOLS-1]); } chunk->nused_segs += 1; @@ -290,7 +301,7 @@ iptr S_find_segments(creator, s, g, n) thread_gc *creator; ISPC s; IGEN g; iptr } else { loser_index = (n == 2) ? 0 : find_index(n-1); for (i = find_index(n); i <= PARTIAL_CHUNK_POOLS; i += 1) { - chunk = S_chunks[i]; + chunk = chunks[i]; while (chunk != NULL) { if (n < (nunused_segs = (chunk->segs - chunk->nused_segs))) { sort_chunk_unused_segments(chunk); @@ -310,9 +321,9 @@ iptr S_find_segments(creator, s, g, n) thread_gc *creator; ISPC s; IGEN g; iptr if (--j == 0) { *prevsi = nextsi->next; if (chunk->unused_segs == NULL) { - S_move_to_chunk_list(chunk, &S_chunks_full); + S_move_to_chunk_list(chunk, (for_code ? &S_code_chunks_full : &S_chunks_full)); } else if (i == PARTIAL_CHUNK_POOLS) { - S_move_to_chunk_list(chunk, &S_chunks[PARTIAL_CHUNK_POOLS-1]); + S_move_to_chunk_list(chunk, &chunks[PARTIAL_CHUNK_POOLS-1]); } chunk->nused_segs += n; nextsi->next = S_G.occupied_segments[g][s]; @@ -328,7 +339,7 @@ iptr S_find_segments(creator, s, g, n) thread_gc *creator; ISPC s; IGEN g; iptr } nextchunk = chunk->next; if (i != loser_index && i != PARTIAL_CHUNK_POOLS) { - S_move_to_chunk_list(chunk, &S_chunks[loser_index]); + S_move_to_chunk_list(chunk, &chunks[loser_index]); } chunk = nextchunk; } @@ -336,13 +347,19 @@ iptr S_find_segments(creator, s, g, n) thread_gc *creator; ISPC s; IGEN g; iptr } /* we couldn't find space, so ask for more */ - si = allocate_segments(n); - for (nextsi = si; n > 0; n -= 1, nextsi += 1) { + si = allocate_segments(n, for_code); + for (nextsi = si, i = 0; i < n; i += 1, nextsi += 1) { initialize_seginfo(nextsi, creator, s, g); /* add segment to appropriate list of occupied segments */ nextsi->next = S_G.occupied_segments[g][s]; S_G.occupied_segments[g][s] = nextsi; } + + /* preemptively mark a huge allocation as immobile, since + we don't want the GC to ever copy it */ + if (n > 128) + si->must_mark = MUST_MARK_INFINITY; + return si->number; } @@ -350,7 +367,7 @@ iptr S_find_segments(creator, s, g, n) thread_gc *creator; ISPC s; IGEN g; iptr * allocates a group of n contiguous fresh segments, returning the * segment number of the first segment of the group. */ -static seginfo *allocate_segments(nreq) uptr nreq; { +static seginfo *allocate_segments(uptr nreq, UNUSED IBOOL for_code) { uptr nact, bytes, base; void *addr; iptr i; chunkinfo *chunk; seginfo *si; @@ -358,7 +375,7 @@ static seginfo *allocate_segments(nreq) uptr nreq; { nact = nreq < minimum_segment_request ? minimum_segment_request : nreq; bytes = (nact + 1) * bytes_per_segment; - addr = S_getmem(bytes, 0); + addr = S_getmem(bytes, 0, for_code); debug(printf("allocate_segments addr = %p\n", addr)) base = addr_get_segment((uptr)TO_PTR(addr) + bytes_per_segment - 1); @@ -368,7 +385,7 @@ static seginfo *allocate_segments(nreq) uptr nreq; { if (build_ptr(base, 0) == TO_PTR(addr) && base + nact != ((uptr)1 << (ptr_bits - segment_offset_bits)) - 1) nact += 1; - chunk = S_getmem(sizeof(chunkinfo) + sizeof(seginfo) * nact, 0); + chunk = S_getmem(sizeof(chunkinfo) + sizeof(seginfo) * nact, 0, 0); debug(printf("allocate_segments chunk = %p\n", chunk)) chunk->addr = addr; chunk->base = base; @@ -399,9 +416,9 @@ static seginfo *allocate_segments(nreq) uptr nreq; { /* account for trailing empty segments */ if (nact > nreq) { S_G.number_of_empty_segments += nact - nreq; - add_to_chunk_list(chunk, &S_chunks[PARTIAL_CHUNK_POOLS-1]); + add_to_chunk_list(chunk, &((for_code ? S_code_chunks : S_chunks)[PARTIAL_CHUNK_POOLS-1])); } else { - add_to_chunk_list(chunk, &S_chunks_full); + add_to_chunk_list(chunk, (for_code ? &S_code_chunks_full : &S_chunks_full)); } return &chunk->sis[0]; @@ -421,15 +438,24 @@ void S_free_chunk(chunkinfo *chunk) { * nonempty nonstatic segment. */ void S_free_chunks(void) { iptr ntofree; - chunkinfo *chunk, *nextchunk; + chunkinfo *chunk, *code_chunk, *nextchunk= NULL, *code_nextchunk = NULL; ntofree = S_G.number_of_empty_segments - (iptr)(Sflonum_value(SYMVAL(S_G.heap_reserve_ratio_id)) * S_G.number_of_nonstatic_segments); - for (chunk = S_chunks[PARTIAL_CHUNK_POOLS]; ntofree > 0 && chunk != NULL; chunk = nextchunk) { - nextchunk = chunk->next; - ntofree -= chunk->segs; - S_free_chunk(chunk); + for (chunk = S_chunks[PARTIAL_CHUNK_POOLS], code_chunk = S_code_chunks[PARTIAL_CHUNK_POOLS]; + ntofree > 0 && ((chunk != NULL) || (code_chunk != NULL)); + chunk = nextchunk, code_chunk = code_nextchunk) { + if (chunk) { + nextchunk = chunk->next; + ntofree -= chunk->segs; + S_free_chunk(chunk); + } + if (code_chunk) { + code_nextchunk = code_chunk->next; + ntofree -= code_chunk->segs; + S_free_chunk(code_chunk); + } } } @@ -462,14 +488,14 @@ static void expand_segment_table(uptr base, uptr end, seginfo *si) { while (base != end) { #ifdef segment_t3_bits if ((t2i = S_segment_info[SEGMENT_T3_IDX(base)]) == NULL) { - S_segment_info[SEGMENT_T3_IDX(base)] = t2i = (t2table *)S_getmem(sizeof(t2table), 1); + S_segment_info[SEGMENT_T3_IDX(base)] = t2i = (t2table *)S_getmem(sizeof(t2table), 1, 0); } t2 = t2i->t2; #else t2 = S_segment_info; #endif if ((t1i = t2[SEGMENT_T2_IDX(base)]) == NULL) { - t2[SEGMENT_T2_IDX(base)] = t1i = (t1table *)S_getmem(sizeof(t1table), 1); + t2[SEGMENT_T2_IDX(base)] = t1i = (t1table *)S_getmem(sizeof(t1table), 1, 0); #ifdef segment_t3_bits t2i->refcount += 1; #endif @@ -533,3 +559,27 @@ static void contract_segment_table(uptr base, uptr end) { while (t1 < t1end) *t1++ = NULL; #endif } + +/* Bracket all writes to `space_code` memory with calls to + `S_thread_start_code_write` and `S_thread_start_code_write'. + + On a platform where a page cannot be both writable and executable + at the same time (a.k.a. W^X), AND assuming that the disposition is + thread-specific, the bracketing functions disable execution of the + code's memory while enabling writing. + + Note that these function will not work for a W^X implementation + where each page's disposition is process-wide. Indeed, a + process-wide W^X disposition seems incompatible with the Chez + Scheme rule that a foreign thread is allowed to invoke a callback + (as long as the callback is immobile/locked) at any time --- even, + say, while Scheme is collecting garbage and needs to write to + executable pages. */ + +void S_thread_start_code_write(void) { + S_ENABLE_CODE_WRITE(1); +} + +void S_thread_end_code_write(void) { + S_ENABLE_CODE_WRITE(0); +} diff --git a/src/ChezScheme/c/segment.h b/src/ChezScheme/c/segment.h index bc7d142614..b32b8f7bdc 100644 --- a/src/ChezScheme/c/segment.h +++ b/src/ChezScheme/c/segment.h @@ -84,3 +84,16 @@ FORCEINLINE seginfo *MaybeSegInfo(uptr i) { #define SegmentSpace(i) (SegInfo(i)->space) #define SegmentGeneration(i) (SegInfo(i)->generation) #define SegmentOldSpace(i) (SegInfo(i)->old_space) + +/* Must be consistent with `eq-hash` in "../s/library.ss" */ +FORCEINLINE uptr eq_hash(ptr key) { + iptr x = (iptr)key >> primary_type_bits; +#if (ptr_bits == 64) + iptr x1 = x ^ ((x >> 32) & (iptr)0xFFFFFFFF); +#else + iptr x1 = x; +#endif + iptr x2 = x1 ^ ((x1 >> 16) & (iptr)0xFFFF); + iptr x3 = x2 ^ ((x2 >> 8) & (iptr)0xFF); + return (uptr)x3; +} diff --git a/src/ChezScheme/c/stats.c b/src/ChezScheme/c/stats.c index e47b49af1b..9413c3bfb8 100644 --- a/src/ChezScheme/c/stats.c +++ b/src/ChezScheme/c/stats.c @@ -20,7 +20,9 @@ #define _REENTRANT #endif /* make two-argument ctime_r and two-argument asctime_r visible */ -#define _POSIX_PTHREAD_SEMANTICS +# ifndef _POSIX_PTHREAD_SEMANTICS +# define _POSIX_PTHREAD_SEMANTICS +# endif #endif /* defined(SOLARIS) */ #include "system.h" @@ -421,11 +423,16 @@ ptr S_gmtime(ptr tzoff, ptr tspair) { return dtvec; } + +#ifndef GET_TIME +# define GET_TIME time +#endif + ptr S_asctime(ptr dtvec) { char buf[26]; if (dtvec == Sfalse) { - time_t tx = time(NULL); + time_t tx = GET_TIME(NULL); if (ctime_r(&tx, buf) == NULL) return Sfalse; } else { struct tm tmx; @@ -510,7 +517,11 @@ static long adjust_time_zone(ptr dtvec, struct tm *tmxp, ptr given_tzoff) { } } #else +# if defined(SOLARIS) + tzoff = timezone; +# else tzoff = tmxp->tm_gmtoff; +# endif if (given_tzoff == Sfalse) { # if defined(__linux__) || defined(SOLARIS) /* Linux and Solaris set `tzname`: */ diff --git a/src/ChezScheme/c/symbol.c b/src/ChezScheme/c/symbol.c index d2e42613a8..1ac569f09f 100644 --- a/src/ChezScheme/c/symbol.c +++ b/src/ChezScheme/c/symbol.c @@ -22,6 +22,10 @@ ptr S_symbol_value(sym) ptr sym; { return SYMVAL(sym); } +ptr S_symbol_racy_value(ptr sym) NO_THREAD_SANITIZE { + return SYMVAL(sym); +} + void S_set_symbol_value(sym, val) ptr sym, val; { SETSYMVAL(sym, val); SETSYMCODE(sym, Sprocedurep(val) ? CLOSCODE(val) : S_G.nonprocedure_code); diff --git a/src/ChezScheme/c/thread.c b/src/ChezScheme/c/thread.c index d4a42d2c81..eafad66dfd 100644 --- a/src/ChezScheme/c/thread.c +++ b/src/ChezScheme/c/thread.c @@ -36,11 +36,10 @@ void S_thread_init() { S_tc_mutex.count = 0; s_thread_cond_init(&S_collect_cond); s_thread_cond_init(&S_collect_thread0_cond); - S_tc_mutex_depth = 0; - s_thread_mutex_init(&S_gc_tc_mutex.pmutex); - S_tc_mutex.owner = 0; - S_tc_mutex.count = 0; - S_use_gc_tc_mutex = 0; + s_thread_mutex_init(&S_alloc_mutex.pmutex); + s_thread_cond_init(&S_terminated_cond); + S_alloc_mutex.owner = 0; + S_alloc_mutex.count = 0; # ifdef IMPLICIT_ATOMIC_AS_EXPLICIT s_thread_mutex_init(&S_implicit_mutex); @@ -65,6 +64,8 @@ ptr S_create_thread_object(who, p_tc) const char *who; ptr p_tc; { if (S_threads == Snil) { tc = TO_PTR(S_G.thread_context); tgc = &S_G.main_thread_gc; + GCDATA(tc) = TO_PTR(tgc); + tgc->tc = tc; } else { /* clone parent */ ptr p_v = PARAMETERS(p_tc); iptr i, n = Svector_length(p_v); @@ -81,6 +82,9 @@ ptr S_create_thread_object(who, p_tc) const char *who; ptr p_tc; { S_error(who, "unable to malloc thread data structure"); memcpy(TO_VOIDP(tc), TO_VOIDP(p_tc), size_tc); + GCDATA(tc) = TO_PTR(tgc); + tgc->tc = tc; + { IGEN g; ISPC s; for (g = 0; g <= static_generation; g++) { @@ -93,7 +97,14 @@ ptr S_create_thread_object(who, p_tc) const char *who; ptr p_tc; { tgc->bitmask_overhead[g] = 0; } } - + + tgc->during_alloc = 0; + tgc->pending_ephemerons = (ptr)0; + for (i = 0; i < (int)DIRTY_SEGMENT_LISTS; i++) + tgc->dirty_segments[i] = NULL; + tgc->queued_fire = 0; + tgc->preserve_ownership = 0; + v = S_vector_in(tc, space_new, 0, n); for (i = 0; i < n; i += 1) @@ -103,10 +114,9 @@ ptr S_create_thread_object(who, p_tc) const char *who; ptr p_tc; { CODERANGESTOFLUSH(tc) = Snil; } - GCDATA(tc) = TO_PTR(tgc); - tgc->tc = tc; + tgc->sweeper = main_sweeper_index; - /* override nonclonable tc fields */ + /* override nonclonable tc fields */ THREADNO(tc) = S_G.threadno; S_G.threadno = S_add(S_G.threadno, FIX(1)); @@ -123,7 +133,11 @@ ptr S_create_thread_object(who, p_tc) const char *who; ptr p_tc; { FRAME(tc,0) = TO_PTR(&CODEIT(S_G.dummy_code_object,size_rp_header)); /* S_reset_allocation_pointer initializes ap and eap */ + alloc_mutex_acquire(); S_reset_allocation_pointer(tc); + alloc_mutex_release(); + S_maybe_fire_collector(tgc); + RANDOMSEED(tc) = most_positive_fixnum < 0xffffffff ? most_positive_fixnum : 0xffffffff; X(tc) = Y(tc) = U(tc) = V(tc) = W(tc) = FIX(0); @@ -159,16 +173,8 @@ ptr S_create_thread_object(who, p_tc) const char *who; ptr p_tc; { LZ4OUTBUFFER(tc) = 0; - tgc->sweeper = main_sweeper_index; - tgc->remote_range_start = (ptr)(uptr)-1; - tgc->remote_range_end = (ptr)0; - tgc->pending_ephemerons = (ptr)0; - tgc->ranges_to_send = NULL; - tgc->ranges_received = NULL; - for (i = 0; i < (int)DIRTY_SEGMENT_LISTS; i++) - tgc->dirty_segments[i] = NULL; - tgc->thread = (ptr)0; - + CP(tc) = 0; + tc_mutex_release(); return thread; @@ -181,7 +187,7 @@ IBOOL Sactivate_thread() { /* create or reactivate current thread */ if (tc == (ptr)0) { /* thread created by someone else */ ptr thread; - /* borrow base thread for now */ + /* borrow base thread to clone */ thread = S_create_thread_object("Sactivate_thread", TO_PTR(S_G.thread_context)); s_thread_setspecific(S_tc_key, TO_VOIDP(THREADTC(thread))); return 1; @@ -244,10 +250,13 @@ static IBOOL destroy_thread(tc) ptr tc; { *ls = Scdr(*ls); S_nthreads -= 1; + alloc_mutex_acquire(); + /* process remembered set before dropping allocation area */ S_scan_dirty((ptr *)EAP(tc), (ptr *)REAL_EAP(tc)); /* close off thread-local allocation */ + S_thread_start_code_write(); { ISPC s; IGEN g; thread_gc *tgc = THREAD_GC(tc); @@ -256,6 +265,9 @@ static IBOOL destroy_thread(tc) ptr tc; { if (tgc->next_loc[g][s]) S_close_off_thread_local_segment(tc, s, g); } + S_thread_end_code_write(); + + alloc_mutex_release(); /* process guardian entries */ { @@ -286,6 +298,9 @@ static IBOOL destroy_thread(tc) ptr tc; { if (LZ4OUTBUFFER(tc) != (ptr)0) free(TO_VOIDP(LZ4OUTBUFFER(tc))); if (SIGNALINTERRUPTQUEUE(tc) != (ptr)0) free(TO_VOIDP(SIGNALINTERRUPTQUEUE(tc))); + if (THREAD_GC(tc)->preserve_ownership) + --S_num_preserve_ownership_threads; + /* Never free a thread_gc, since it may be recorded in a segment as the segment's creator. Recycle manually, instead. */ THREAD_GC(tc)->sweeper = main_sweeper_index; @@ -297,6 +312,8 @@ static IBOOL destroy_thread(tc) ptr tc; { THREADTC(thread) = 0; /* mark it dead */ status = 1; + + s_thread_cond_broadcast(&S_terminated_cond); break; } ls = &Scdr(*ls); @@ -361,7 +378,7 @@ void S_mutex_free(m) scheme_mutex_t *m; { free(m); } -void S_mutex_acquire(m) scheme_mutex_t *m; { +void S_mutex_acquire(scheme_mutex_t *m) NO_THREAD_SANITIZE { s_thread_t self = s_thread_self(); iptr count; INT status; @@ -379,7 +396,7 @@ void S_mutex_acquire(m) scheme_mutex_t *m; { m->count = 1; } -INT S_mutex_tryacquire(m) scheme_mutex_t *m; { +INT S_mutex_tryacquire(scheme_mutex_t *m) NO_THREAD_SANITIZE { s_thread_t self = s_thread_self(); iptr count; INT status; @@ -401,7 +418,12 @@ INT S_mutex_tryacquire(m) scheme_mutex_t *m; { return status; } -void S_mutex_release(m) scheme_mutex_t *m; { +IBOOL S_mutex_is_owner(scheme_mutex_t *m) NO_THREAD_SANITIZE { + s_thread_t self = s_thread_self(); + return ((m->count > 0) && s_thread_equal(m->owner, self)); +} + +void S_mutex_release(scheme_mutex_t *m) NO_THREAD_SANITIZE { s_thread_t self = s_thread_self(); iptr count; INT status; diff --git a/src/ChezScheme/c/types.h b/src/ChezScheme/c/types.h index 73d7842992..fdb19f88d3 100644 --- a/src/ChezScheme/c/types.h +++ b/src/ChezScheme/c/types.h @@ -170,6 +170,9 @@ typedef struct _seginfo { octet *counting_mask; /* bitmap of counting roots during a GC */ octet *measured_mask; /* bitmap of objects that have been measured */ #ifdef PORTABLE_BYTECODE +# ifndef PTHREADS + void *encorage_alignment; /* hack for 32-bit systems that align 64-bit values on 4 bytes */ +# endif union { ptr force_alignment; #endif octet dirty_bytes[cards_per_segment]; /* one dirty byte per card */ @@ -268,6 +271,7 @@ typedef struct _bucket_pointer_list { #define size_closure(n) ptr_align(header_size_closure + (n)*ptr_bytes) #define size_string(n) ptr_align(header_size_string + (n)*string_char_bytes) #define size_fxvector(n) ptr_align(header_size_fxvector + (n)*ptr_bytes) +#define size_flvector(n) ptr_align(header_size_flvector + (n)*sizeof(double)) #define size_bytevector(n) ptr_align(header_size_bytevector + (n)) #define size_bignum(n) ptr_align(header_size_bignum + (n)*bigit_bytes) #define size_code(n) ptr_align(header_size_code + (n)) @@ -275,6 +279,8 @@ typedef struct _bucket_pointer_list { #define size_record_inst(n) ptr_align(n) #define unaligned_size_record_inst(n) (n) +#define rtd_parent(x) INITVECTIT(RECORDDESCANCESTRY(x), 0) + /* type tagging macros */ #define TYPE(x,type) ((ptr)((iptr)(x) - typemod + (type))) @@ -391,21 +397,37 @@ typedef struct { tc_mutex_release()\ }\ } -/* S_tc_mutex_depth records the number of nested mutex acquires in - C code on tc_mutex. it is used by do_error to release tc_mutex - the appropriate number of times. -*/ + #define tc_mutex_acquire() do { \ + assert_no_alloc_mutex(); \ S_mutex_acquire(&S_tc_mutex); \ - S_tc_mutex_depth += 1; \ } while (0); #define tc_mutex_release() do { \ - S_tc_mutex_depth -= 1; \ S_mutex_release(&S_tc_mutex); \ } while (0); -#define gc_tc_mutex_acquire() S_mutex_acquire(&S_gc_tc_mutex) -#define gc_tc_mutex_release() S_mutex_release(&S_gc_tc_mutex) +/* Allocation mutex is ordered after tc mutex */ +#define alloc_mutex_acquire() do { \ + S_mutex_acquire(&S_alloc_mutex); \ + } while (0); +#define alloc_mutex_release() do { \ + S_mutex_release(&S_alloc_mutex); \ + } while (0); + +/* To enable checking lock order: */ +#if 0 +# define assert_no_alloc_mutex() do { \ + if (S_mutex_is_owner(&S_alloc_mutex)) \ + S_error_abort("cannot take tc mutex after allocation mutex"); \ + } while (0) +#else +# define assert_no_alloc_mutex() do { } while (0) +#endif + +#define IS_TC_MUTEX_OWNER() S_mutex_is_owner(&S_tc_mutex) +#define IS_ALLOC_MUTEX_OWNER() S_mutex_is_owner(&S_alloc_mutex) + +/* Enable in "version.h": */ #ifdef IMPLICIT_ATOMIC_AS_EXPLICIT # define AS_IMPLICIT_ATOMIC(T, X) ({ \ T RESLT; \ @@ -434,8 +456,10 @@ typedef struct { #define reactivate_thread(tc) {} #define tc_mutex_acquire() do {} while (0) #define tc_mutex_release() do {} while (0) -#define gc_tc_mutex_acquire() do {} while (0) -#define gc_tc_mutex_release() do {} while (0) +#define alloc_mutex_acquire() do {} while (0) +#define alloc_mutex_release() do {} while (0) +#define IS_TC_MUTEX_OWNER() 1 +#define IS_ALLOC_MUTEX_OWNER() 1 #define S_cas_load_acquire_voidp(a, old, new) (*(a) = new, 1) #define S_cas_store_release_voidp(a, old, new) (*(a) = new, 1) #define S_cas_load_acquire_ptr(a, old, new) (*(a) = new, 1) @@ -446,17 +470,12 @@ typedef struct { #define AS_IMPLICIT_ATOMIC(T, X) X #endif -typedef struct remote_range { - ISPC s; - IGEN g; - ptr start, end; - struct thread_gc *tgc; - struct remote_range *next; -} remote_range; - typedef struct thread_gc { ptr tc; - ptr thread; /* set only when collecting */ + + int during_alloc; + IBOOL queued_fire; + IBOOL preserve_ownership; struct thread_gc *next; @@ -476,12 +495,16 @@ typedef struct thread_gc { int sweep_change; int sweeper; /* parallel GC: sweeper thread identity */ - - struct thread_gc *remote_range_tgc; - ptr remote_range_start; - ptr remote_range_end; - remote_range *ranges_to_send; /* modified only by owning sweeper */ - remote_range *ranges_received; /* modified with sweeper mutex held */ + + /* modified only by owning sweeper; contains ptr and thread_gc* */ + ptr send_remote_sweep_stack; + ptr send_remote_sweep_stack_start; + ptr send_remote_sweep_stack_limit; + + /* modified with sweeper mutex held; contains just ptr */ + ptr receive_remote_sweep_stack; + ptr receive_remote_sweep_stack_start; + ptr receive_remote_sweep_stack_limit; seginfo *dirty_segments[DIRTY_SEGMENT_LISTS]; diff --git a/src/ChezScheme/c/version.h b/src/ChezScheme/c/version.h index d61fc81b3a..4783f468a4 100644 --- a/src/ChezScheme/c/version.h +++ b/src/ChezScheme/c/version.h @@ -78,8 +78,24 @@ # endif #endif +#if (machine_type == machine_type_arm64osx || machine_type == machine_type_tarm64osx) +# define OS_ANY_MACOSX +# if (machine_type == machine_type_tarm64osx) +# define PTHREADS +# endif +# define FLUSHCACHE +#endif + +#if (machine_type == machine_type_ppc32osx || machine_type == machine_type_tppc32osx) +# define OS_ANY_MACOSX +# if (machine_type == machine_type_tppc32osx) +# define PTHREADS +# endif +# define FLUSHCACHE +#endif + #if (machine_type == machine_type_pb) -# if defined(__powerpc__) && !defined(__powerpc64__) +# if (defined(__powerpc__) || defined(__POWERPC__)) && !defined(__powerpc64__) # define PORTABLE_BYTECODE_BIGENDIAN # endif # if defined(__linux__) @@ -97,9 +113,11 @@ # define LITTLE_ENDIAN_IEEE_DOUBLE # endif # elif defined(_MSC_VER) || defined(__MINGW32__) -# define OS_ANY_WINDOWS +# define OS_ANY_WINDOWS # elif __APPLE__ -# define OS_ANY_MACOSX +# define OS_ANY_MACOSX +# elif defined(sun) +# define OS_ANY_SOLARIS2 # endif #endif @@ -261,7 +279,7 @@ struct timespec; #endif #if defined(__MINGW32__) && (machine_type == machine_type_ti3nt || machine_type == machine_type_i3nt) #define time_t __time64_t -#define time _time64 +#define GET_TIME _time64 #endif #endif @@ -303,7 +321,18 @@ typedef int tputsputcchar; #define USE_MMAP #define MMAP_HEAP #define IEEE_DOUBLE -#define LITTLE_ENDIAN_IEEE_DOUBLE +#if !defined(__POWERPC__) +# define LITTLE_ENDIAN_IEEE_DOUBLE +#endif +#if defined(__arm64__) +# define S_MAP_CODE MAP_JIT +# define S_ENABLE_CODE_WRITE(on) pthread_jit_write_protect_np(!(on)) +# define CANNOT_READ_DIRECTLY_INTO_CODE +# include <pthread.h> +#elif defined(__x86_64__) +/* needed to run under Rosetta2 on ARM Mac OS: */ +# define CANNOT_READ_DIRECTLY_INTO_CODE +#endif #define LDEXP #define ARCHYPERBOLIC #define GETPAGESIZE() getpagesize() @@ -382,6 +411,7 @@ typedef int tputsputcchar; #define ARCHYPERBOLIC #define LOG1P #define DEFINE_MATHERR +#define NO_USELOCALE #define GETPAGESIZE() getpagesize() typedef char *memcpy_t; #define MAKE_NAN(x) { x = 0.0; x = x / x; } @@ -466,14 +496,31 @@ typedef char tputsputcchar; # define WRITE write #endif +#ifndef S_PROT_CODE +# define S_PROT_CODE (PROT_READ | PROT_WRITE | PROT_EXEC) +#endif +#ifndef S_MAP_CODE +# define S_MAP_CODE 0 +#endif +#ifndef S_ENABLE_CODE_WRITE +# define S_ENABLE_CODE_WRITE(on) do { } while (0) +#endif + #ifdef PTHREADS # define NO_THREADS_UNUSED /* empty */ #else # define NO_THREADS_UNUSED UNUSED #endif +#if defined(__has_feature) +# if __has_feature(thread_sanitizer) +# define NO_THREAD_SANITIZE __attribute__((no_sanitize("thread"))) +# define IMPLICIT_ATOMIC_AS_EXPLICIT +# endif +#endif +#ifndef NO_THREAD_SANITIZE +# define NO_THREAD_SANITIZE /* empty */ +#endif + /* Use "/dev/urandom" everywhere except Windows */ #define USE_DEV_URANDOM_UUID - -/* For debugging: */ -/* #define IMPLICIT_ATOMIC_AS_EXPLICIT */ diff --git a/src/ChezScheme/c/vfasl.c b/src/ChezScheme/c/vfasl.c index 4e6c29daa8..61de95cb9b 100644 --- a/src/ChezScheme/c/vfasl.c +++ b/src/ChezScheme/c/vfasl.c @@ -15,7 +15,6 @@ */ #include "system.h" -#include "popcount.h" /* @@ -55,25 +54,7 @@ e \_ [bitmap of pointers to relocate] typedef uptr vfoff; -/* Similar to allocation spaces, but not all allocation spaces are - represented, and these spaces are more fine-grained in some - cases: */ -enum { - vspace_symbol, - vspace_rtd, - vspace_closure, - vspace_impure, - vspace_pure_typed, - vspace_impure_record, - /* rest rest are at then end to make the pointer bitmap - end with zeros (that can be dropped): */ - vspace_code, - vspace_data, - vspace_reloc, /* can be dropped after direct to static generation */ - vspaces_count -}; - -/* Needs to match order above, maps vfasl spaces to allocation +/* Needs to match vspace enum order, maps vfasl spaces to allocation spaces: */ static ISPC vspace_spaces[] = { space_symbol, @@ -87,71 +68,10 @@ static ISPC vspace_spaces[] = { space_data /* reloc --- but not really, since relocs are never in static */ }; -typedef struct vfasl_header { - vfoff data_size; - vfoff table_size; - - vfoff result_offset; - - /* first starting offset is 0, so skip it in this array: */ - vfoff vspace_rel_offsets[vspaces_count-1]; - - vfoff symref_count; - vfoff rtdref_count; - vfoff singletonref_count; -} vfasl_header; - -/************************************************************/ -/* Encode-time data structures */ - -/* During encoding, we use many chunks per vspace on first pass, one - per vspace on second pass: */ -typedef struct vfasl_chunk { - ptr bytes; - uptr length; - uptr used; - uptr swept; - struct vfasl_chunk *next, *prev; -} vfasl_chunk; - -/* One per vspace: */ -struct vfasl_count_and_chunk { - uptr total_bytes; - vfasl_chunk *first; -}; - -typedef struct vfasl_info { - ptr base_addr; /* address to make relocations relative to */ - - uptr sym_count; - - vfoff symref_count; - vfoff *symrefs; - - ptr base_rtd; /* track replacement base_rtd to recognize other rtds */ - - vfoff rtdref_count; - vfoff *rtdrefs; - - vfoff singletonref_count; - vfoff *singletonrefs; - - struct vfasl_count_and_chunk spaces[vspaces_count]; - - octet *ptr_bitmap; - - struct vfasl_hash_table *graph; - - IBOOL installs_library_entry; /* to determine whether vfasls can be combined */ -} vfasl_info; - #define ptr_add(p, n) ((ptr)((uptr)(p) + (n))) #define ptr_subtract(p, n) ((ptr)((uptr)(p) - (n))) #define ptr_diff(p, q) ((uptr)(p) - (uptr)(q)) -#define byte_bits 8 -#define log2_byte_bits 3 - #define segment_align(size) (((size)+bytes_per_segment-1) & ~(bytes_per_segment-1)) static uptr symbol_pos_to_offset(uptr sym_pos) { @@ -161,46 +81,10 @@ static uptr symbol_pos_to_offset(uptr sym_pos) { return (segs * bytes_per_segment) + (syms * size_symbol); } -static ptr vfasl_copy_all(vfasl_info *vfi, ptr v); - -static ptr copy(vfasl_info *vfi, ptr pp, seginfo *si); -static uptr sweep(vfasl_info *vfi, ptr p); -static int is_rtd(ptr tf, vfasl_info *vfi); - -static IFASLCODE abs_reloc_variant(IFASLCODE type); -static ptr vfasl_encode_relocation(vfasl_info *vfi, ptr obj); static void relink_code(ptr co, ptr sym_base, ptr *vspaces, uptr *vspace_offsets, IBOOL to_static); static ptr find_pointer_from_offset(uptr p_off, ptr *vspaces, uptr *vspace_offsets); -static void vfasl_relocate(vfasl_info *vfi, ptr *ppp); -static ptr vfasl_relocate_help(vfasl_info *vfi, ptr pp); -static ptr vfasl_relocate_code(vfasl_info *vfi, ptr code); -static ptr vfasl_find_room(vfasl_info *vfi, int s, ITYPE t, iptr n); -static void vfasl_register_rtd_reference(vfasl_info *vfi, ptr pp); -static void vfasl_register_symbol_reference(vfasl_info *vfi, ptr *pp, ptr p); -static void vfasl_register_singleton_reference(vfasl_info *vfi, ptr *pp, int which); -static void vfasl_register_forward(vfasl_info *vfi, ptr pp, ptr p); -static ptr vfasl_lookup_forward(vfasl_info *vfi, ptr p); - -static iptr vfasl_symbol_to_index(vfasl_info *vfi, ptr pp); - -static void fasl_init_entry_tables(); -static void vfasl_check_install_library_entry(vfasl_info *vfi, ptr name); - -static int detect_singleton(ptr p); -static ptr lookup_singleton(int which); - -typedef struct vfasl_hash_table vfasl_hash_table; -static vfasl_hash_table *make_vfasl_hash_table(IBOOL permanent); -static void vfasl_hash_table_set(vfasl_hash_table *ht, ptr key, ptr value); -static ptr vfasl_hash_table_ref(vfasl_hash_table *ht, ptr key); - -static void *vfasl_malloc(uptr sz); -static void *vfasl_calloc(uptr sz, uptr n); - -static void sort_offsets(vfoff *p, vfoff len); - -#define vfasl_fail(vfi, what) S_error("vfasl", "cannot encode " what) +static ptr lookup_singleton(iptr which); /************************************************************/ /* Loading */ @@ -212,12 +96,14 @@ ptr S_vfasl(ptr bv, void *stream, iptr offset, iptr input_len) # define VSPACE_LENGTH(s) (vspace_offsets[(s)+1] - vspace_offsets[(s)]) # define VSPACE_END(s) ptr_add(vspaces[(s)], VSPACE_LENGTH(s)) ptr tc = get_thread_context(); - vfasl_header header; - ptr data, table; + octet header_space[size_vfasl_header]; + ptr header = TO_PTR(header_space); + ptr table; vfoff *symrefs, *rtdrefs, *singletonrefs; octet *bm, *bm_end; iptr used_len; int s; + void *bv_addr; IBOOL to_static = 0; used_len = sizeof(header); @@ -225,70 +111,75 @@ ptr S_vfasl(ptr bv, void *stream, iptr offset, iptr input_len) S_error("fasl-read", "input length mismatch"); if (bv) - memcpy(&header, &BVIT(bv, offset), sizeof(vfasl_header)); + memcpy(&header_space, &BVIT(bv, offset), size_vfasl_header); else { - if (S_fasl_stream_read(stream, (octet*)&header, sizeof(header)) < 0) + if (S_fasl_stream_read(stream, header_space, size_vfasl_header) < 0) S_error("fasl-read", "input truncated"); } - used_len += header.data_size + header.table_size; + used_len += VFASLHEADER_DATA_SIZE(header) + VFASLHEADER_TABLE_SIZE(header); if (used_len > input_len) S_error("fasl-read", "input length mismatch"); vspace_offsets[0] = 0; for (s = 1; s < vspaces_count; s++) { - vspace_offsets[s] = header.vspace_rel_offsets[s-1]; + vspace_offsets[s] = VFASLHEADER_VSPACE_REL_OFFSETS(header, s-1); } - vspace_offsets[vspaces_count] = header.data_size; - - if (bv) { - void *base_addr = &BVIT(bv, sizeof(vfasl_header) + offset); - newspace_find_room(tc, typemod, header.data_size, data); - memcpy(TO_VOIDP(data), base_addr, header.data_size); - table = ptr_add(TO_PTR(base_addr), header.data_size); - } else { - if (S_vfasl_boot_mode > 0) { - for (s = 0; s < vspaces_count; s++) { - uptr sz = vspace_offsets[s+1] - vspace_offsets[s]; - if (sz > 0) { - if ((s == vspace_reloc) && !S_G.retain_static_relocation) { - newspace_find_room(tc, typemod, sz, vspaces[s]); - } else { - find_room(tc, vspace_spaces[s], static_generation, typemod, sz, vspaces[s]); - } - if (S_fasl_stream_read(stream, TO_VOIDP(vspaces[s]), sz) < 0) - S_error("fasl-read", "input truncated"); - } else - vspaces[s] = (ptr)0; + vspace_offsets[vspaces_count] = VFASLHEADER_DATA_SIZE(header); + + bv_addr = (bv ? &BVIT(bv, size_vfasl_header + offset) : NULL); + + to_static = (S_vfasl_boot_mode > 0); + + for (s = 0; s < vspaces_count; s++) { + uptr sz = vspace_offsets[s+1] - vspace_offsets[s]; + if (sz > 0) { + if ((s == vspace_reloc) && to_static && !S_G.retain_static_relocation) { + newspace_find_room(tc, typemod, sz, vspaces[s]); + } else { + find_room(tc, vspace_spaces[s], (to_static ? static_generation : 0), typemod, sz, vspaces[s]); } - for (s = vspaces_count - 1; s--; ) { - if (!vspaces[s]) - vspaces[s] = vspaces[s+1]; + if (bv) { + memcpy(TO_VOIDP(vspaces[s]), bv_addr, sz); + bv_addr = TO_VOIDP(ptr_add(TO_PTR(bv_addr), sz)); + } else { + ptr dest; +#ifdef CANNOT_READ_DIRECTLY_INTO_CODE + if (s == vspace_code) + newspace_find_room(tc, typemod, sz, dest); + else + dest = vspaces[s]; +#else + dest = vspaces[s]; +#endif + if (S_fasl_stream_read(stream, TO_VOIDP(dest), sz) < 0) + S_error("fasl-read", "input truncated"); +#ifdef CANNOT_READ_DIRECTLY_INTO_CODE + if (dest != vspaces[s]) + memcpy(TO_VOIDP(vspaces[s]), TO_VOIDP(dest), sz); +#endif } - data = (ptr)0; /* => initialize below */ - to_static = 1; - } else { - newspace_find_room(tc, typemod, header.data_size, data); - if (S_fasl_stream_read(stream, TO_VOIDP(data), header.data_size) < 0) - S_error("fasl-read", "input truncated"); - } + } else + vspaces[s] = (ptr)0; + } + for (s = vspaces_count - 1; s--; ) { + if (!vspaces[s]) + vspaces[s] = vspaces[s+1]; + } - newspace_find_room(tc, typemod, ptr_align(header.table_size), table); - if (S_fasl_stream_read(stream, TO_VOIDP(table), header.table_size) < 0) + if (bv) + table = TO_PTR(bv_addr); + else { + newspace_find_room(tc, typemod, ptr_align(VFASLHEADER_TABLE_SIZE(header)), table); + if (S_fasl_stream_read(stream, TO_VOIDP(table), VFASLHEADER_TABLE_SIZE(header)) < 0) S_error("fasl-read", "input truncated"); } - if (data) { - for (s = 0; s < vspaces_count; s++) - vspaces[s] = ptr_add(data, vspace_offsets[s]); - } else - data = vspaces[0]; - symrefs = TO_VOIDP(table); - rtdrefs = TO_VOIDP(ptr_add(TO_PTR(symrefs), header.symref_count * sizeof(vfoff))); - singletonrefs = TO_VOIDP(ptr_add(TO_PTR(rtdrefs), header.rtdref_count * sizeof(vfoff))); - bm = TO_VOIDP(ptr_add(TO_PTR(singletonrefs), header.singletonref_count * sizeof(vfoff))); - bm_end = TO_VOIDP(ptr_add(TO_PTR(table), header.table_size)); + rtdrefs = TO_VOIDP(ptr_add(TO_PTR(symrefs), VFASLHEADER_SYMREF_COUNT(header) * sizeof(vfoff))); + singletonrefs = TO_VOIDP(ptr_add(TO_PTR(rtdrefs), VFASLHEADER_RTDREF_COUNT(header) * sizeof(vfoff))); + bm = TO_VOIDP(ptr_add(TO_PTR(singletonrefs), VFASLHEADER_SINGLETONREF_COUNT(header) * sizeof(vfoff))); + bm_end = TO_VOIDP(ptr_add(TO_PTR(table), VFASLHEADER_TABLE_SIZE(header))); #if 0 printf("\n" @@ -301,7 +192,7 @@ ptr S_vfasl(ptr bv, void *stream, iptr offset, iptr input_len) "data %ld\n" "othr %ld\n" "tabl %ld symref %ld rtdref %ld sglref %ld\n", - sizeof(vfasl_header), + (uptr)size_vfasl_header, VSPACE_LENGTH(vspace_symbol), VSPACE_LENGTH(vspace_rtd), VSPACE_LENGTH(vspace_closure), @@ -311,12 +202,12 @@ ptr S_vfasl(ptr bv, void *stream, iptr offset, iptr input_len) (VSPACE_LENGTH(vspace_impure) + VSPACE_LENGTH(vspace_pure_typed) + VSPACE_LENGTH(vspace_impure_record)), - header.table_size, - header.symref_count * sizeof(vfoff), - header.rtdref_count * sizeof(vfoff), - header.singletonref_count * sizeof(vfoff)); + VFASLHEADER_TABLE_SIZE(header), + VFASLHEADER_SYMREF_COUNT(header) * sizeof(vfoff), + VFASLHEADER_RTDREF_COUNT(header) * sizeof(vfoff), + VFASLHEADER_SINGLETONREF_COUNT(header) * sizeof(vfoff)); #endif - + /* We have to convert an offset relative to the start of data in the vfasl format to an offset relative to an individual space, at least for target generations other than 0. Rely on the fact that @@ -373,7 +264,7 @@ ptr S_vfasl(ptr bv, void *stream, iptr offset, iptr input_len) { SPACE_OFFSET_DECLS; vfoff i; - for (i = 0; i < header.singletonref_count; i++) { + for (i = 0; i < VFASLHEADER_SINGLETONREF_COUNT(header); i++) { uptr r_off; ptr *ref; r_off = singletonrefs[i]; @@ -411,6 +302,10 @@ ptr S_vfasl(ptr bv, void *stream, iptr offset, iptr input_len) INITSYMVAL(sym) = sunbound; INITSYMCODE(sym,S_G.nonprocedure_code); +#if 0 + S_prin1(sym); printf("\n"); +#endif + isym = S_intern4(sym); if (isym != sym) { /* The symbol was already interned, so point to the existing one */ @@ -423,9 +318,6 @@ ptr S_vfasl(ptr bv, void *stream, iptr offset, iptr input_len) printf("\n"); } } - } else { - if (INITSYMPLIST(sym) != Snil) printf("oops\n"); - if (INITSYMSPLIST(sym) != Snil) printf("oops\n"); } sym = ptr_add(sym, size_symbol); @@ -441,7 +333,7 @@ ptr S_vfasl(ptr bv, void *stream, iptr offset, iptr input_len) SPACE_OFFSET_DECLS; ptr syms = vspaces[vspace_symbol]; vfoff i; - for (i = 0; i < header.symref_count; i++) { + for (i = 0; i < VFASLHEADER_SYMREF_COUNT(header); i++) { uptr p2_off, sym_pos; ptr *p2, sym, val; p2_off = symrefs[i]; @@ -478,12 +370,13 @@ ptr S_vfasl(ptr bv, void *stream, iptr offset, iptr input_len) if (!Ssymbolp(RECORDDESCUID(meta_rtd))) RECORDINSTTYPE(rtd) = RECORDDESCUID(meta_rtd); - /* fixup parent before continuing, relying on parents being earlier in `rtd`s */ - parent_rtd = RECORDDESCPARENT(rtd); + /* fixup parent before continuing, relying on parents being earlier in `rtd`s; + we let the rest of the ancestor vector get fixed up later */ + parent_rtd = rtd_parent(rtd); if (parent_rtd != Sfalse) { ptr parent_uid = RECORDDESCUID(parent_rtd); if (!Ssymbolp(parent_uid)) - RECORDDESCPARENT(rtd) = parent_uid; + rtd_parent(rtd) = parent_uid; } new_rtd = rtd; @@ -504,7 +397,7 @@ ptr S_vfasl(ptr bv, void *stream, iptr offset, iptr input_len) { SPACE_OFFSET_DECLS; vfoff i; - for (i = 0; i < header.rtdref_count; i++) { + for (i = 0; i < VFASLHEADER_RTDREF_COUNT(header); i++) { uptr r_off; ptr *ref, rtd, uid; r_off = rtdrefs[i]; @@ -557,7 +450,7 @@ ptr S_vfasl(ptr bv, void *stream, iptr offset, iptr input_len) { ptr v; ITYPE t; - v = find_pointer_from_offset(header.result_offset, vspaces, vspace_offsets); + v = find_pointer_from_offset(VFASLHEADER_RESULT_OFFSET(header), vspaces, vspace_offsets); if (((t = TYPEBITS(v)) == type_typed_object) && TYPEP(TYPEFIELD(v), mask_box, type_box)) v = Sunbox(v); @@ -571,579 +464,17 @@ ptr S_vfasl_to(ptr bv) return S_vfasl(bv, NULL, 0, Sbytevector_length(bv)); } -/************************************************************/ -/* Saving */ - -static void vfasl_init(vfasl_info *vfi) { - int s; - - vfi->base_addr = (ptr)0; - vfi->sym_count = 0; - vfi->symref_count = 0; - vfi->symrefs = NULL; - vfi->base_rtd = S_G.base_rtd; - vfi->rtdref_count = 0; - vfi->rtdrefs = NULL; - vfi->singletonref_count = 0; - vfi->singletonrefs = NULL; - vfi->graph = make_vfasl_hash_table(0); - vfi->ptr_bitmap = NULL; - vfi->installs_library_entry = 0; - - for (s = 0; s < vspaces_count; s++) { - vfasl_chunk *c; - - c = vfasl_malloc(sizeof(vfasl_chunk)); - c->bytes = (ptr)0; - c->length = 0; - c->used = 0; - c->swept = 0; - c->next = NULL; - c->prev = NULL; - - vfi->spaces[s].first = c; - vfi->spaces[s].total_bytes = 0; - } -} - -ptr S_to_vfasl(ptr v) -{ - vfasl_info *vfi; - vfasl_header header; - ITYPE t; - int s; - uptr size, data_size, bitmap_size; - ptr bv, p; - - fasl_init_entry_tables(); - - /* Box certain kinds of values where the vfasl process needs a - pointer into data */ - if (IMMEDIATE(v) - || detect_singleton(v) - || ((t = TYPEBITS(v)) == type_symbol) - || ((t == type_typed_object) - && TYPEP(TYPEFIELD(v), mask_record, type_record) - && (TYPEFIELD(v) == v)) - || ((t == type_typed_object) - && TYPEP(TYPEFIELD(v), mask_box, type_box))) { - v = Sbox(v); - } - - vfi = vfasl_malloc(sizeof(vfasl_info)); - - vfasl_init(vfi); - - /* First pass: determine sizes */ - - (void)vfasl_copy_all(vfi, v); - - /* Setup for second pass: allocate to contiguous bytes */ - - size = sizeof(vfasl_header); - - data_size = vfi->spaces[0].total_bytes; - for (s = 1; s < vspaces_count; s++) { - header.vspace_rel_offsets[s-1] = data_size; - data_size += vfi->spaces[s].total_bytes; - } - header.data_size = data_size; - size += data_size; - - size += vfi->symref_count * sizeof(vfoff); - size += vfi->rtdref_count * sizeof(vfoff); - size += vfi->singletonref_count * sizeof(vfoff); - - header.symref_count = vfi->symref_count; - header.rtdref_count = vfi->rtdref_count; - header.singletonref_count = vfi->singletonref_count; - - header.table_size = size - data_size - sizeof(header); /* doesn't yet include the bitmap */ - - bitmap_size = (data_size + (byte_bits-1)) >> log2_byte_bits; - - size += bitmap_size; - - bv = S_bytevector(size); - memset(&BVIT(bv, 0), 0, size); - - p = TO_PTR(&BVIT(bv, 0)); - - /* Skip header for now */ - p = ptr_add(p, sizeof(vfasl_header)); - - vfi->base_addr = p; - - /* Set pointers to vspaces based on sizes from first pass */ - for (s = 0; s < vspaces_count; s++) { - vfasl_chunk *c; - - c = vfasl_malloc(sizeof(vfasl_chunk)); - c->bytes = p; - c->length = vfi->spaces[s].total_bytes; - c->used = 0; - c->swept = 0; - c->next = NULL; - c->prev = NULL; - vfi->spaces[s].first = c; - - p = ptr_add(p, vfi->spaces[s].total_bytes); - vfi->spaces[s].total_bytes = 0; - } - - vfi->symrefs = TO_VOIDP(p); - p = ptr_add(p, sizeof(vfoff) * vfi->symref_count); - - vfi->base_rtd = S_G.base_rtd; - vfi->rtdrefs = TO_VOIDP(p); - p = ptr_add(p, sizeof(vfoff) * vfi->rtdref_count); - - vfi->singletonrefs = TO_VOIDP(p); - p = ptr_add(p, sizeof(vfoff) * vfi->singletonref_count); - - vfi->sym_count = 0; - vfi->symref_count = 0; - vfi->rtdref_count = 0; - vfi->singletonref_count = 0; - - vfi->graph = make_vfasl_hash_table(0); - - vfi->ptr_bitmap = TO_VOIDP(p); - - /* Write data */ - - v = vfasl_copy_all(vfi, v); - - header.result_offset = ptr_diff(v, vfi->base_addr); - - /* Make all pointers relative to the start of the data area */ - { - ptr *p2 = TO_VOIDP(vfi->base_addr); - uptr base_addr = (uptr)vfi->base_addr; - octet *bm = vfi->ptr_bitmap; - octet *bm_end = bm + bitmap_size; - uptr zeros = 0; - for (; bm != bm_end; bm++, p2 += byte_bits) { - octet m = *bm; - if (m == 0) { - zeros++; - } else { -# define MAYBE_FIXUP(i) if (m & (1 << i)) ((uptr *)p2)[i] -= base_addr; - MAYBE_FIXUP(0); - MAYBE_FIXUP(1); - MAYBE_FIXUP(2); - MAYBE_FIXUP(3); - MAYBE_FIXUP(4); - MAYBE_FIXUP(5); - MAYBE_FIXUP(6); - MAYBE_FIXUP(7); -# undef MAYBE_FIXUP - zeros = 0; - } - } - - /* We can ignore trailing zeros */ - header.table_size += (bitmap_size - zeros); - } - - /* Truncate bytevector to match end of bitmaps */ - { - uptr sz = sizeof(vfasl_header) + header.data_size + header.table_size; - BYTEVECTOR_TYPE(bv) = (sz << bytevector_length_offset) | type_bytevector; - } - - memcpy(&BVIT(bv, 0), &header, sizeof(vfasl_header)); - - sort_offsets(vfi->symrefs, vfi->symref_count); - sort_offsets(vfi->rtdrefs, vfi->rtdref_count); - sort_offsets(vfi->singletonrefs, vfi->singletonref_count); - - return bv; -} - -/* If compiled code uses `$install-library-entry`, then it can't be - combined into a single vfasled object, because the installation - needs to be evaluated for laster vfasls. Recognize a non-combinable - value as anything that references the C entry or even mentions the - symbol `$install-library-entry` (as defined in "library.ss"). If - non-boot code mentions the symbol `$install-library-entry`, it just - isn't as optimal. - - This is an expensive test, since we perform half of a vfasl - encoding to look for `$install-library-entry`. */ -IBOOL S_vfasl_can_combinep(ptr v) -{ - IBOOL installs; - vfasl_info *vfi; - - if (IMMEDIATE(v)) - return 1; - - fasl_init_entry_tables(); - - /* Run a "first pass" */ - - vfi = vfasl_malloc(sizeof(vfasl_info)); - vfasl_init(vfi); - (void)vfasl_copy_all(vfi, v); - - installs = vfi->installs_library_entry; - - return !installs; -} - -/************************************************************/ -/* Traversals for saving */ - -static ptr vfasl_copy_all(vfasl_info *vfi, ptr v) { - seginfo *si; - int s; - int changed = 1; - - si = MaybeSegInfo(ptr_get_segment(v)); - - v = copy(vfi, v, si); - - while (changed) { - changed = 0; - for (s = 0; s < vspaces_count; s++) { - vfasl_chunk *c = vfi->spaces[s].first; - - /* consistent order of sweeping by older chunks first: */ - if (c) { - while ((c->swept < c->used) && c->next) - c = c->next; - if (c->swept >= c->used) - c = c->prev; - } - - while (c) { - ptr pp, pp_end; - - pp = ptr_add(c->bytes, c->swept); - pp_end = ptr_add(c->bytes, c->used); - c->swept = c->used; - - switch(s) { - case vspace_symbol: - while (pp < pp_end) { - pp = ptr_add(pp, sweep(vfi, TYPE((ptr)pp, type_symbol))); - } - break; - case vspace_closure: - while (pp < pp_end) { - pp = ptr_add(pp, sweep(vfi, TYPE((ptr)pp, type_closure))); - } - break; - case vspace_impure: - while (pp < pp_end) { - vfasl_relocate(vfi, TO_VOIDP(pp)); - pp = ptr_add(pp, sizeof(ptr)); - } - break; - case vspace_rtd: - case vspace_code: - case vspace_pure_typed: - case vspace_impure_record: - while (pp < pp_end) { - pp = ptr_add(pp, sweep(vfi, TYPE((ptr)pp, type_typed_object))); - } - break; - case vspace_data: - case vspace_reloc: - break; - default: - S_error_abort("vfasl: unrecognized space"); - break; - } - - if (c->swept >= c->used) - c = c->prev; - changed = 1; - } - } - } - - return v; -} - -static void vfasl_register_pointer(vfasl_info *vfi, ptr *pp) { - if (vfi->ptr_bitmap) { - uptr delta = ptr_diff(TO_PTR(pp), vfi->base_addr) >> log2_ptr_bytes; - uptr i = delta >> log2_byte_bits; - uptr bit = (((uptr)1) << (delta & (byte_bits - 1))); - vfi->ptr_bitmap[i] |= bit; - } -} - -static uptr ptr_base_diff(vfasl_info *vfi, ptr p) { - if ((uptr)vfi->base_addr > (uptr)UNTYPE(p, TYPEBITS(p))) - S_error_abort("vfasl: pointer not in region"); - - return ptr_diff(p, vfi->base_addr); -} - -static void vfasl_register_symbol_reference(vfasl_info *vfi, ptr *pp, ptr p) { - if (vfi->symrefs) - vfi->symrefs[vfi->symref_count] = ptr_base_diff(vfi, TO_PTR(pp)); - vfi->symref_count++; - *pp = SYMVAL(p); /* replace symbol reference with index of symbol */ -} - -static void vfasl_register_rtd_reference(vfasl_info *vfi, ptr pp) { - if (vfi->rtdrefs) - vfi->rtdrefs[vfi->rtdref_count] = ptr_base_diff(vfi, pp); - vfi->rtdref_count++; -} - -static void vfasl_register_singleton_reference(vfasl_info *vfi, ptr *pp, int which) { - if (vfi->singletonrefs) - vfi->singletonrefs[vfi->singletonref_count] = ptr_base_diff(vfi, TO_PTR(pp)); - vfi->singletonref_count++; - *pp = FIX(which); -} - -static void vfasl_register_forward(vfasl_info *vfi, ptr pp, ptr p) { - vfasl_hash_table_set(vfi->graph, pp, p); -} - -static ptr vfasl_lookup_forward(vfasl_info *vfi, ptr p) { - return vfasl_hash_table_ref(vfi->graph, p); -} - -static void vfasl_relocate_parents(vfasl_info *vfi, ptr p) { - ptr ancestors = Snil; - - while ((p != Sfalse) && !vfasl_lookup_forward(vfi, p)) { - ancestors = Scons(p, ancestors); - p = RECORDDESCPARENT(p); - } - - while (ancestors != Snil) { - (void)vfasl_relocate_help(vfi, Scar(ancestors)); - ancestors = Scdr(ancestors); - } -} - -static ptr vfasl_find_room(vfasl_info *vfi, int s, ITYPE t, iptr n) { - ptr p; - uptr sz = vfi->spaces[s].total_bytes; - - switch (s) { - case vspace_symbol: - case vspace_impure_record: - /* For these spaces, in case they will be loaded into the static - generation, objects must satisfy an extra constraint: an object - must not span segments unless it's at the start of a - segment. */ - if (sz & (bytes_per_segment-1)) { - /* Since we're not at the start of a segment, don't let an - object span a segment */ - if ((segment_align(sz) != segment_align(sz+n)) - && ((sz+n) != segment_align(sz+n))) { - /* Fill in to next segment, instead. */ - uptr delta = segment_align(sz) - sz; - vfasl_chunk *c, *new_c; - - vfi->spaces[s].total_bytes += delta; - - /* Mark the end of the old segment */ - c = vfi->spaces[s].first; - p = ptr_add(c->bytes, c->used); - FWDMARKER(p) = forward_marker; - - /* Create a new chunk so the old one tracks the current - swept-to-used region, and the new chunk starts a new - segment. If the old chunk doesn't have leftover bytes - (because we're in the first pass), then we'll need to - clean out this useless chunk below. */ - new_c = vfasl_malloc(sizeof(vfasl_chunk)); - new_c->bytes = ptr_add(c->bytes, c->used + delta); - new_c->length = c->length - (c->used + delta); - new_c->used = 0; - new_c->swept = 0; - - new_c->prev = NULL; - new_c->next = c; - c->prev = new_c; - - vfi->spaces[s].first = new_c; - } - } - break; - default: - break; - } - - vfi->spaces[s].total_bytes += n; - - if (vfi->spaces[s].first->used + n > vfi->spaces[s].first->length) { - vfasl_chunk *c, *old_c; - iptr newlen = segment_align(n); - - c = vfasl_malloc(sizeof(vfasl_chunk)); - c->bytes = TO_PTR(vfasl_malloc(newlen)); - c->length = newlen; - c->used = 0; - c->swept = 0; - - old_c = vfi->spaces[s].first; - if (old_c->next && !old_c->length) - old_c = old_c->next; /* drop useless chunk created above */ - - c->prev = NULL; - c->next = old_c; - old_c->prev = c; - - vfi->spaces[s].first = c; - } - - p = ptr_add(vfi->spaces[s].first->bytes, vfi->spaces[s].first->used); - vfi->spaces[s].first->used += n; - - return TYPE(p, t); -} - -#define FIND_ROOM(vfi, s, t, n, p) p = vfasl_find_room(vfi, s, t, n) - -#include "vfasl.inc" - -static ptr vfasl_relocate_help(vfasl_info *vfi, ptr pp) { - ptr fpp; - seginfo *si; - - si = MaybeSegInfo(ptr_get_segment(pp)); - if (!si) - vfasl_fail(vfi, "unknown"); - - fpp = vfasl_lookup_forward(vfi, pp); - if (fpp) - return fpp; - else - return copy(vfi, pp, si); -} - -/* Use vfasl_relocate only on addresses that are in the vfasl target area */ -static void vfasl_relocate(vfasl_info *vfi, ptr *ppp) { - ptr pp = *ppp, tf; - if (!IMMEDIATE(pp)) { - int which_singleton; - if ((which_singleton = detect_singleton(pp))) - vfasl_register_singleton_reference(vfi, ppp, which_singleton); - else { - pp = vfasl_relocate_help(vfi, pp); - *ppp = pp; - if (!IMMEDIATE(pp)) { - if (TYPEBITS(pp) == type_symbol) - vfasl_register_symbol_reference(vfi, ppp, pp); - else { - if ((TYPEBITS(pp) == type_typed_object) - && TYPEP((tf = TYPEFIELD(pp)), mask_record, type_record) - && is_rtd(tf, vfi)) - vfasl_register_rtd_reference(vfi, TO_PTR(ppp)); - vfasl_register_pointer(vfi, ppp); - } - } - } - } -} - -static ptr vfasl_relocate_code(vfasl_info *vfi, ptr code) { - /* We don't want to register `code` as a pointer, since it is - treated more directly */ - return vfasl_relocate_help(vfi, code); -} - -static int is_rtd(ptr tf, vfasl_info *vfi) -{ - while (1) { - if (tf == vfi->base_rtd) - return 1; - if (tf == S_G.base_rtd) - return 1; - - tf = RECORDDESCPARENT(tf); - if (tf == Sfalse) - return 0; - } -} - /*************************************************************/ /* Code and relocation handling for save and load */ -#define VFASL_RELOC_TAG_BITS 3 - -#define VFASL_RELOC_C_ENTRY_TAG 1 -#define VFASL_RELOC_LIBRARY_ENTRY_TAG 2 -#define VFASL_RELOC_LIBRARY_ENTRY_CODE_TAG 3 -#define VFASL_RELOC_SYMBOL_TAG 4 -#define VFASL_RELOC_SINGLETON_TAG 5 -/* FXIME: rtds? */ - -#define VFASL_RELOC_C_ENTRY(p) (((uptr)(p) << VFASL_RELOC_TAG_BITS) | VFASL_RELOC_C_ENTRY_TAG) -#define VFASL_RELOC_LIBRARY_ENTRY(p) (((uptr)(p) << VFASL_RELOC_TAG_BITS) | VFASL_RELOC_LIBRARY_ENTRY_TAG) -#define VFASL_RELOC_LIBRARY_ENTRY_CODE(p) (((uptr)(p) << VFASL_RELOC_TAG_BITS) | VFASL_RELOC_LIBRARY_ENTRY_CODE_TAG) -#define VFASL_RELOC_SYMBOL(p) (((uptr)(p) << VFASL_RELOC_TAG_BITS) | VFASL_RELOC_SYMBOL_TAG) -#define VFASL_RELOC_SINGLETON(p) (((uptr)(p) << VFASL_RELOC_TAG_BITS) | VFASL_RELOC_SINGLETON_TAG) - -#define VFASL_RELOC_TAG(p) (UNFIX(p) & ((1 << VFASL_RELOC_TAG_BITS) - 1)) -#define VFASL_RELOC_POS(p) (UNFIX(p) >> VFASL_RELOC_TAG_BITS) - -/* Picks a relocation variant that fits into the actual relocation's - shape, but holds an absolue value */ -static IFASLCODE abs_reloc_variant(IFASLCODE type) { - if (type == reloc_abs) - return reloc_abs; -#if defined(I386) || defined(X86_64) - return reloc_abs; -#elif defined(ARMV6) - return reloc_arm32_abs; -#elif defined(AARCH64) - return reloc_arm64_abs; -#elif defined(PPC32) - if (type == reloc_ppc32_abs) - return reloc_ppc32_abs; - else - return reloc_abs; -#elif defined(PORTABLE_BYTECODE) - return reloc_pb_abs; -#else - >> need to fill in for this platform << -#endif -} +#define VFASL_RELOC_C_ENTRY(p) (((uptr)(p) << vfasl_reloc_tag_bits) | vfasl_reloc_c_entry_tag) +#define VFASL_RELOC_LIBRARY_ENTRY(p) (((uptr)(p) << vfasl_reloc_tag_bits) | vfasl_reloc_library_entry_tag) +#define VFASL_RELOC_LIBRARY_ENTRY_CODE(p) (((uptr)(p) << vfasl_reloc_tag_bits) | vfasl_reloc_library_entry_code_tag) +#define VFASL_RELOC_SYMBOL(p) (((uptr)(p) << vfasl_reloc_tag_bits) | vfasl_reloc_symbol_tag) +#define VFASL_RELOC_SINGLETON(p) (((uptr)(p) << vfasl_reloc_tag_bits) | vfasl_reloc_singleton_tag) -static ptr vfasl_encode_relocation(vfasl_info *vfi, ptr obj) { - ptr pos; - int which_singleton; - - if ((which_singleton = detect_singleton(obj))) { - obj = FIX(VFASL_RELOC_SINGLETON(which_singleton)); - } else if ((pos = vfasl_hash_table_ref(S_G.c_entries, obj))) { - pos = (ptr)((uptr)pos - 1); - if ((uptr)pos == CENTRY_install_library_entry) - vfi->installs_library_entry = 1; - obj = FIX(VFASL_RELOC_C_ENTRY(pos)); - } else if ((pos = vfasl_hash_table_ref(S_G.library_entries, obj))) { - pos = (ptr)((uptr)pos - 1); - obj = FIX(VFASL_RELOC_LIBRARY_ENTRY(pos)); - } else if ((pos = vfasl_hash_table_ref(S_G.library_entry_codes, obj))) { - pos = (ptr)((uptr)pos - 1); - obj = FIX(VFASL_RELOC_LIBRARY_ENTRY_CODE(pos)); - } else if (Ssymbolp(obj)) { - obj = vfasl_relocate_help(vfi, obj); - obj = FIX(VFASL_RELOC_SYMBOL(UNFIX(SYMVAL(obj)))); - } else if (IMMEDIATE(obj)) { - /* as-is */ - if (Sfixnump(obj)) - if (obj != FIX(0)) /* allow 0 for fcallable cookie */ - S_error("vfasl", "unexpected fixnum in relocation"); - } else { - obj = vfasl_relocate_help(vfi, obj); - obj = (ptr)ptr_diff(obj, vfi->base_addr); - } - - return obj; -} +#define VFASL_RELOC_TAG(p) (UNFIX(p) & ((1 << vfasl_reloc_tag_bits) - 1)) +#define VFASL_RELOC_POS(p) (UNFIX(p) >> vfasl_reloc_tag_bits) static void relink_code(ptr co, ptr sym_base, ptr *vspaces, uptr *vspace_offsets, IBOOL to_static) { ptr t; iptr a, m, n; @@ -1184,22 +515,24 @@ static void relink_code(ptr co, ptr sym_base, ptr *vspaces, uptr *vspace_offsets code_off = RELOC_CODE_OFFSET(entry); } a += code_off; - obj = S_get_code_obj(abs_reloc_variant(RELOC_TYPE(entry)), co, a, item_off); + + /* offset is stored in place of constant-loading code: */ + memcpy(&obj, TO_VOIDP((ptr)((uptr)co + a)), sizeof(ptr)); if (IMMEDIATE(obj)) { if (Sfixnump(obj)) { int tag = VFASL_RELOC_TAG(obj); - int pos = VFASL_RELOC_POS(obj); - if (tag == VFASL_RELOC_SINGLETON_TAG) + iptr pos = VFASL_RELOC_POS(obj); + if (tag == vfasl_reloc_singleton_tag) obj = lookup_singleton(pos); - else if (tag == VFASL_RELOC_C_ENTRY_TAG) + else if (tag == vfasl_reloc_c_entry_tag) obj = S_lookup_c_entry(pos); - else if ((tag == VFASL_RELOC_LIBRARY_ENTRY_TAG) - || (tag == VFASL_RELOC_LIBRARY_ENTRY_CODE_TAG)) { + else if ((tag == vfasl_reloc_library_entry_tag) + || (tag == vfasl_reloc_library_entry_code_tag)) { obj = S_lookup_library_entry(pos, 1); - if (tag == VFASL_RELOC_LIBRARY_ENTRY_CODE_TAG) + if (tag == vfasl_reloc_library_entry_code_tag) obj = CLOSCODE(obj); - } else if (tag == VFASL_RELOC_SYMBOL_TAG) { + } else if (tag == vfasl_reloc_symbol_tag) { ptr val; obj = TYPE(ptr_add(sym_base, symbol_pos_to_offset(pos)), type_symbol); if ((val = SYMVAL(obj)) != sunbound) @@ -1229,7 +562,7 @@ static void relink_code(ptr co, ptr sym_base, ptr *vspaces, uptr *vspace_offsets } break; } - tf = RECORDDESCPARENT(tf); + tf = rtd_parent(tf); if (tf == Sfalse) break; } @@ -1254,235 +587,40 @@ static ptr find_pointer_from_offset(uptr p_off, ptr *vspaces, uptr *vspace_offse } /*************************************************************/ -/* Symbol names */ - -static iptr vfasl_symbol_to_index(vfasl_info *vfi, ptr pp) -{ - uptr pos = vfi->sym_count++; - ptr name = SYMNAME(pp); - if (Sstringp(name)) - vfasl_check_install_library_entry(vfi, name); - else if (!Spairp(name) || (Scar(name) == Sfalse)) - vfasl_fail(vfi, "gensym without unique name"); - return pos; -} - -/*************************************************************/ -/* C and library entries */ - -static void fasl_init_entry_tables() -{ - tc_mutex_acquire(); - - if (!S_G.c_entries) { - iptr i; - - S_G.c_entries = make_vfasl_hash_table(1); - S_G.library_entries = make_vfasl_hash_table(1); - S_G.library_entry_codes = make_vfasl_hash_table(1); - - for (i = Svector_length(S_G.c_entry_vector); i--; ) { - ptr entry = Svector_ref(S_G.c_entry_vector, i); - vfasl_hash_table_set(S_G.c_entries, entry, (ptr)(i+1)); - } - - for (i = Svector_length(S_G.library_entry_vector); i--; ) { - ptr entry = Svector_ref(S_G.library_entry_vector, i); - if (entry != Sfalse) { - vfasl_hash_table_set(S_G.library_entries, entry, (ptr)(i+1)); - if (Sprocedurep(entry)) - vfasl_hash_table_set(S_G.library_entry_codes, CLOSCODE(entry), (ptr)(i+1)); - } - } - } - - tc_mutex_release(); -} - -static void vfasl_check_install_library_entry(vfasl_info *vfi, ptr name) -{ - const char *ile = "$install-library-entry"; - iptr len = Sstring_length(name), i; - - for (i = 0; i < len; i++) { - if (Sstring_ref(name, i) != (unsigned)ile[i]) - return; - } - - if (!ile[i]) - vfi->installs_library_entry = 1; -} - -/*************************************************************/ /* Singletons, such as "" */ +/* This array needs to be in the same order as the enumeration in "cmacro.ss" */ static ptr *singleton_refs[] = { &S_G.null_string, &S_G.null_vector, &S_G.null_fxvector, + &S_G.null_flvector, &S_G.null_bytevector, &S_G.null_immutable_string, &S_G.null_immutable_vector, - &S_G.null_immutable_fxvector, &S_G.null_immutable_bytevector, &S_G.eqp, &S_G.eqvp, &S_G.equalp, - &S_G.symboleqp }; - -static int detect_singleton(ptr p) { - unsigned i; - for (i = 0; i < sizeof(singleton_refs) / sizeof(ptr*); i++) { - if (p == *(singleton_refs[i])) - return i+1; + &S_G.symboleqp, + &S_G.symbol_symbol, + &S_G.symbol_ht_rtd }; + +static ptr lookup_singleton(iptr which) { + ptr v; + + v = *(singleton_refs[which-1]); + + if (v == Sfalse) { + if (which == singleton_symbol_ht_rtd) { + S_G.symbol_ht_rtd = SYMVAL(S_intern((const unsigned char *)"$symbol-ht-rtd")); + if (!Srecordp(S_G.symbol_ht_rtd)) S_error_abort("$symbol-ht-rtd has not been set"); + } else if (which == singleton_eq) { + S_G.eqp = SYMVAL(S_intern((const unsigned char *)"eq?")); + if (!Sprocedurep(S_G.eqp)) S_error_abort("eq? has not been set"); + } else + S_error_abort("vfasl: singleton not ready"); + v = *(singleton_refs[which-1]); } - return 0; -} -static ptr lookup_singleton(int which) { - return *(singleton_refs[which-1]); + return v; } - -/*************************************************************/ -/* `eq?`-based hash table during saving as critical section */ - -typedef struct hash_entry { - ptr key, value; -} hash_entry; - -struct vfasl_hash_table { - IBOOL permanent; - uptr count; - uptr size; - hash_entry *entries; -}; - -#define HASH_CODE(p) ((uptr)(p) >> log2_ptr_bytes) -#define HASH_CODE2(p) (((uptr)(p) >> (log2_ptr_bytes + log2_ptr_bytes)) | 1) - -static vfasl_hash_table *make_vfasl_hash_table(IBOOL permanent) { - vfasl_hash_table *ht; - - if (permanent) - ht = malloc(sizeof(vfasl_hash_table)); - else - ht = vfasl_malloc(sizeof(vfasl_hash_table)); - - ht->permanent = permanent; - ht->count = 0; - ht->size = 16; - if (permanent) - ht->entries = calloc(sizeof(hash_entry), ht->size); - else - ht->entries = vfasl_calloc(sizeof(hash_entry), ht->size); - - return ht; -} - -static void vfasl_hash_table_set(vfasl_hash_table *ht, ptr key, ptr value) { - uptr hc = HASH_CODE(key); - uptr hc2 = HASH_CODE2(key); - uptr size = ht->size; - - if (ht->count > ht->size >> 1) { - /* rehash */ - uptr i; - hash_entry *old_entries = ht->entries; - - ht->count = 0; - ht->size *= 2; - if (ht->permanent) - ht->entries = calloc(sizeof(hash_entry), ht->size); - else - ht->entries = vfasl_calloc(sizeof(hash_entry), ht->size); - - for (i = 0; i < size; i++) { - if (old_entries[i].key) - vfasl_hash_table_set(ht, old_entries[i].key, old_entries[i].value); - } - - if (ht->permanent) - free(old_entries); - - size = ht->size; - } - - hc = hc & (size - 1); - while (ht->entries[hc].key) { - hc = (hc + hc2) & (size - 1); - } - - ht->entries[hc].key = key; - ht->entries[hc].value = value; - ht->count++; -} - -static ptr vfasl_hash_table_ref(vfasl_hash_table *ht, ptr key) { - uptr hc = HASH_CODE(key); - uptr hc2 = HASH_CODE2(key); - uptr size = ht->size; - ptr old_key; - - hc = hc & (size - 1); - while ((old_key = ht->entries[hc].key) != key) { - if (!old_key) - return (ptr)0; - hc = (hc + hc2) & (size - 1); - } - - return ht->entries[hc].value; -} - -/*************************************************************/ - -static void *vfasl_malloc(uptr sz) { - ptr tc = get_thread_context(); - void *p; - newspace_find_room_voidp(tc, ptr_align(sz), p); - return p; -} - -static void *vfasl_calloc(uptr sz, uptr n) { - void *p; - sz *= n; - p = vfasl_malloc(sz); - memset(p, 0, sz); - return p; -} - -/*************************************************************/ - -static void sort_offsets(vfoff *p, vfoff len) -{ - while (1) { - if (len > 1) { - vfoff i, pivot = 0; - - { - vfoff mid = len >> 2; - vfoff tmp = p[mid]; - p[mid] = p[0]; - p[0] = tmp; - } - - for (i = 1; i < len; i++) { - if (p[i] < p[pivot]) { - vfoff tmp = p[pivot]; - p[pivot] = p[i]; - pivot++; - p[i] = p[pivot]; - p[pivot] = tmp; - } - } - - if (pivot > (len >> 1)) { - sort_offsets(p+pivot+1, len-pivot-1); - len = pivot; - } else { - sort_offsets(p, pivot); - p = p+pivot+1; - len = len-pivot-1; - } - } else - return; - } -} diff --git a/src/ChezScheme/configure b/src/ChezScheme/configure index fe2d4f196e..81864a5008 100755 --- a/src/ChezScheme/configure +++ b/src/ChezScheme/configure @@ -26,14 +26,16 @@ for fn in "$srcdir"/boot/*/scheme.boot ; do sep0=$sep1; sep1=", "; sep2=$sep3; sep3=$sep4; sep4=", and " fi done -for fn in boot/*/scheme.boot ; do - next=`echo $fn | sed -e 's/boot\/\(.*\)\/scheme.boot/\1/'` - if [ "$next" != '*' ] ; then - machs=$machs$sep0$last - last=$next - sep0=$sep1; sep1=", "; sep2=$sep3; sep3=$sep4; sep4=", and " - fi -done +if [ "$srcdir" != "." ]; then + for fn in boot/*/scheme.boot ; do + next=`echo $fn | sed -e 's/boot\/\(.*\)\/scheme.boot/\1/'` + if [ "$next" != '*' ] ; then + machs=$machs$sep0$last + last=$next + sep0=$sep1; sep1=", "; sep2=$sep3; sep3=$sep4; sep4=", and " + fi + done +fi machs=$machs$sep2$last m="" @@ -52,13 +54,18 @@ installman="" installschemename="scheme" installpetitename="petite" installscriptname="scheme-script" +cflagsset=no disablex11=no disablecurses=no +addflags=yes +addwarningflags=no +default_warning_flags="-Wpointer-arith -Wall -Wextra -Werror -Wno-implicit-fallthrough" : ${CC:="gcc"} : ${CPPFLAGS:=""} : ${CFLAGS:=""} : ${LD:="ld"} : ${LDFLAGS:=""} +: ${LIBS:=""} : ${AR:="ar"} : ${ARFLAGS:="rc"} : ${RANLIB:="ranlib"} @@ -150,6 +157,13 @@ case "${CONFIG_UNAME}" in m64=a6osx tm32=ti3osx tm64=ta6osx + elif uname -a | egrep 'arm|aarch' > /dev/null 2>&1 ; then + m64=arm64osx + tm64=tarm64osx + elif uname -a | egrep 'Power' > /dev/null 2>&1 ; then + m64=ppc32osx + tm64=tppc32osx + default_warning_flags="" fi installprefix=/usr/local installmansuffix=share/man @@ -259,6 +273,12 @@ while [ $# != 0 ] ; do --disable-curses) disablecurses=yes ;; + --disable-auto-flags) + addflags=no + ;; + --enable-warning-flags) + addwarningflags=yes + ;; --libkernel) Kernel=KernelLib installkerneltarget=installkernellib @@ -283,6 +303,7 @@ while [ $# != 0 ] ; do ;; CFLAGS=*) CFLAGS=`echo $1 | sed -e 's/^CFLAGS=//'` + cflagsset=yes ;; LD=*) LD=`echo $1 | sed -e 's/^LD=//'` @@ -290,6 +311,9 @@ while [ $# != 0 ] ; do LDFLAGS=*) LDFLAGS=`echo $1 | sed -e 's/^LDFLAGS=//'` ;; + LIBS=*) + LIBS=`echo $1 | sed -e 's/^LIBS=//'` + ;; AR=*) AR=`echo $1 | sed -e 's/^AR=//'` ;; @@ -332,7 +356,7 @@ if [ "$m" = "pb" ] ; then fi if [ "$bits" = "" ] ; then - if uname -a | egrep 'amd64|x86_64|aarch64' > /dev/null 2>&1 ; then + if uname -a | egrep 'amd64|x86_64|aarch64|arm64' > /dev/null 2>&1 ; then bits=64 else bits=32 @@ -343,21 +367,28 @@ if [ "$threads" = "" ] ; then threads=yes fi +if [ $bits = 64 ] ; then + if [ $threads = yes ] ; then defaultm=$tm64 ; else defaultm=$m64 ; fi +else + if [ $threads = yes ] ; then defaultm=$tm32 ; else defaultm=$m32 ; fi +fi + if [ "$m" = "" ] ; then machine_supplied=no if [ $pb = yes ] ; then m=pb if [ $bits = 64 ] ; then mpbhost=$m64 ; else mpbhost=$m32 ; fi + flagsm=$mpbhost else - if [ $bits = 64 ] ; then - if [ $threads = yes ] ; then m=$tm64 ; else m=$m64 ; fi - else - if [ $threads = yes ] ; then m=$tm32 ; else m=$m32 ; fi - fi + m=$defaultm + flagsm=$m fi elif [ $pb = yes ] ; then mpbhost=$m + flagsm=$m m=pb +else + flagsm=$m fi if [ "$w" = "" ] ; then @@ -397,6 +428,8 @@ if [ "$help" = "yes" ]; then echo " --32|--64 specify 32/64-bit version ($bits)" echo " --disable-x11 disable X11 support" echo " --disable-curses disable [n]curses support" + echo " --disable-auto-flags no auto additions to CFLAGS/LDFLAGS/LIBS" + echo " --enable-warning-flags add GCC warning flags to CFLAGS" echo " --libkernel build libkernel.a (the default)" echo " --kernelobj build kernel.o instead of libkernel.a" echo " --installprefix=<pathname> final installation root ($installprefix)" @@ -413,10 +446,11 @@ if [ "$help" = "yes" ]; then echo " --[no]gzip-man-pages compress manual pages ($gzipmanpages)" echo " --workarea=<pathname> build directory ($w)" echo " CC=<C compiler> C compiler" - echo " CPPFLAGS=<C preprocessor flags> additional C preprocessor flags ($CPPFLAGS)" - echo " CFLAGS=<C compiler flags> additional C compiler flags ($CFLAGS)" + echo " CPPFLAGS=<C preprocessor flags> C preprocessor flags" + echo " CFLAGS=<C compiler flags> C compiler flags" echo " LD=<linker> linker" - echo " LDFLAGS=<linker flags> additional linker flags ($LDFLAGS)" + echo " LDFLAGS=<linker flags> additional linker flags" + echo " LIBS=<libraries> additional libraries" echo " AR=<archiver> archiver" echo " ARFLAGS=<archiver flgs> archiver flags" echo " RANLIB=<archive indexer> archive indexer" @@ -445,7 +479,145 @@ if [ "$help" = "yes" ]; then exit 0 fi -if [ "$m" != "" -o -f boot/$m/scheme.boot -o -f "$srcdir"/boot/$m/scheme.boot ] ; then +optFlags=-O2 + +if [ "$cflagsset" = "no" -o "$addwarningflags" = "yes" ] ; then + warningFlags="$default_warning_flags" +else + warningFlags="" +fi + +# Infer flags needed for threads: +case "${flagsm}" in + *le|*fb|*ob|*nb) + threadFlags="-D_REENTRANT -pthread" + threadLibs="-lpthread" + ;; + *s2) + threadFlags="-pthread" + threadLibs="-lpthread" + ;; + *) + threadFlags="" + threadLibs="" + ;; +esac + +# Set default CFLAGS if not provided at all. Assuming that the +# compiler is for the right platform, compilation should generally +# succeed if no flags are set; anything required should be propagated +# a different way +if [ "$cflagsset" = "no" ] ; then + case "${flagsm}" in + a6le|ta6le) + CFLAGS="-m64 -msse2 ${optFlags}" + ;; + a6fb|ta6fb|a6nb|ta6nb|a6ob|ta6ob) + CFLAGS="-m64 ${optFlags}" + ;; + a6s2|ta6s2) + CFLAGS="-m64 ${optFlags}" + ;; + a6osx|ta6osx) + CFLAGS="-m64 ${optFlags}" + ;; + arm64osx|tarm64osx) + CFLAGS="-arch arm64 ${optFlags}" + ;; + a6nt|ta6nt) + CFLAGS="${optFlags}" + ;; + arm32le|tarm32le|arm64le|tarm64le) + CFLAGS="${optFlags}" + ;; + i3le|ti3le) + CFLAGS="-m32 -msse2 ${optFlags}" + ;; + i3fb|ti3fb|i3nb|ti3nb|i3ob|ti3ob) + CFLAGS="-m32 ${optFlags}" + ;; + i3s2|ti3s2) + CFLAGS="-m32 ${optFlags}" + ;; + i3osx|ti3osx) + CFLAGS="-m32 ${optFlags}" + ;; + i3nt|ti3nt) + CFLAGS="${optFlags}" + ;; + i3qnx) + CC=qcc + CFLAGS="-m32 -N2048K ${optFlags}" + ;; + ppc32le|tppc32le) + CFLAGS="-m32 ${optFlags}" + ;; + ppc32osx|tppc32osx) + CFLAGS="${optFlags}" + ;; + esac +fi + +# Add automatic thread compilation flags, unless suppressed by --disable-auto-flags +if [ "$addflags" = "yes" ] ; then + if [ "$threadFlags" != "" ] ; then + CFLAGS="${CFLAGS} ${threadFlags}" + fi +fi + +cursesLib=-lcurses +ncursesLib=-lncurses + +if [ "$disablecurses" = "yes" ]; then + cursesLib= + ncursesLib= +fi + +# Add automatic linking flags, unless suppressed by --disable-auto-flags +if [ "$addflags" = "yes" ] ; then + case "${flagsm}" in + *le) + LDFLAGS="${LDFLAGS} -rdynamic" + ;; + *fb|*nb) + LDFLAGS="${LDFLAGS} -rdynamic -L/usr/local/lib" + ;; + *ob) + LDFLAGS="${LDFLAGS} -rdynamic -Wl,--export-dynamic -Wl,-zwxneeded -L/usr/local/lib" + ;; + *) + ;; + esac + + case "${flagsm}" in + *le) + LIBS="${LIBS} -lm -ldl ${ncursesLib} -lrt" + ;; + *fb|*ob) + LIBS="${LIBS} -liconv -lm ${ncursesLib}" + ;; + *nb) + LIBS="${LIBS} /usr/lib/i18n/libiconv_std.a -lm /usr/pkg/lib/libncurses.a" + ;; + *s2) + LIBS="${LIBS} -lnsl -ldl -lm ${cursesLib} -lrt" + ;; + *osx) + LIBS="${LIBS} -liconv -lm ${ncursesLib}" + ;; + *nt) + LIBS="${LIBS} -lshell32 -luser32 -lole32 -lrpcrt4 -luuid" + ;; + 8qnx) + LIBS="${LIBS} -lm /usr/local/lib/libiconv.so -lsocket ${ncursesLib}" + ;; + esac + if [ "$threadLibs" != "" ] ; then + LIBS="${LIBS} ${threadLibs}" + fi +fi + +if [ -f boot/$m/scheme.boot -o -f "$srcdir"/boot/$m/scheme.boot ] ; then echo "Configuring for $m" else if [ "$m" = "" ] ; then @@ -502,6 +674,7 @@ esac "$srcdir"/workarea $m $w $mpbhost sed -e 's/$(m)/'$m'/g'\ + -e 's/$(defaultm)/'$defaultm'/g'\ -e 's/$(workarea)/'$w'/g'\ "$srcdir"/makefiles/Makefile.in > Makefile @@ -517,6 +690,7 @@ sed -e 's/$(m)/'$m'/g'\ cat "$srcdir"/makefiles/Makefile-workarea.in > $w/Makefile sed -e 's/$(m)/'$m'/g'\ + -e 's/$(m)/'$m'/g'\ -e 's/$(workarea)/'$w'/g'\ "$srcdir"/makefiles/Mf-boot.in > $w/Mf-boot @@ -543,17 +717,12 @@ cat > $w/c/next_config.h << END #endif END -if [ "$disablex11" = "yes" ]; then - echo '#define DISABLE_X11' >> $w/c/next_config.h -fi - -cursesLib=-lcurses -ncursesLib=-lncurses - if [ "$disablecurses" = "yes" ]; then echo '#define DISABLE_CURSES' >> $w/c/next_config.h - cursesLib= - ncursesLib= +fi + +if [ "$disablex11" = "yes" ]; then + echo '#define DISABLE_X11' >> $w/c/next_config.h fi if [ ! -f "$w/c/config.h" ] ; then @@ -564,9 +733,6 @@ else mv $w/c/next_config.h $w/c/config.h fi -warningFlags="-Wpointer-arith -Wall -Wextra -Werror -Wno-implicit-fallthrough" -optFlags=-O2 - case "$srcdir" in /*) upupsrcdir=$srcdir @@ -583,6 +749,7 @@ CPPFLAGS=$CPPFLAGS CFLAGS=$CFLAGS LD=$LD LDFLAGS=$LDFLAGS +LIBS=$LIBS AR=$AR ARFLAGS=$ARFLAGS RANLIB=$RANLIB @@ -598,9 +765,9 @@ LZ4Lib=$LZ4Lib zlibHeaderDep=$zlibHeaderDep LZ4HeaderDep=$LZ4HeaderDep warningFlags=$warningFlags -optFlags=$optFlags KernelCFlags=$KernelCFlags Kernel=\${${Kernel}} KernelLinkDeps=\${${Kernel}LinkDeps} KernelLinkLibs=\${${Kernel}LinkLibs} +C=\${CC} \${CPPFLAGS} \${CFLAGS} \${warningFlags} END diff --git a/src/ChezScheme/makefiles/Makefile.in b/src/ChezScheme/makefiles/Makefile.in index 1dab66c8ad..b55daa0abd 100644 --- a/src/ChezScheme/makefiles/Makefile.in +++ b/src/ChezScheme/makefiles/Makefile.in @@ -57,6 +57,9 @@ reset: %.bootquick: (cd $(workarea) && $(MAKE) $*.bootquick) +auto.bootquick: + (cd $(workarea) && $(MAKE) $(defaultm).bootquick) + # Supply ORIG=<dir> to build using existing at <dir> .PHONY: from-orig from-orig: diff --git a/src/ChezScheme/makefiles/Mf-boot.in b/src/ChezScheme/makefiles/Mf-boot.in index a79688b8c5..bb97e5c9fd 100644 --- a/src/ChezScheme/makefiles/Mf-boot.in +++ b/src/ChezScheme/makefiles/Mf-boot.in @@ -21,7 +21,7 @@ doit: $(bootfiles) %.boot: rm -rf ../xc-$* - ( cd .. ; "${srcdir}"/workarea $* xc-$* ) + ( cd .. ; "${srcdir}"/workarea $* xc-$* $(m) ) ( cd ../xc-$*/s ; $(MAKE) -f Mf-cross base=../../$(workarea) m=$(m) xm=$* ) mkdir -p ../boot/$* ( cd ../xc-$*/s ; $(MAKE) keepbootfiles ) diff --git a/src/ChezScheme/makefiles/Mf-install.in b/src/ChezScheme/makefiles/Mf-install.in index 023f9dbcea..05b968eb9c 100644 --- a/src/ChezScheme/makefiles/Mf-install.in +++ b/src/ChezScheme/makefiles/Mf-install.in @@ -62,7 +62,7 @@ InstallLZ4Target= # no changes should be needed below this point # ############################################################################### -Version=csv9.5.3.39 +Version=csv9.5.3.58 Include=boot/$m PetiteBoot=boot/$m/petite.boot SchemeBoot=boot/$m/scheme.boot diff --git a/src/ChezScheme/mats/5_1.ms b/src/ChezScheme/mats/5_1.ms index 064b0c3887..c5718fec63 100644 --- a/src/ChezScheme/mats/5_1.ms +++ b/src/ChezScheme/mats/5_1.ms @@ -814,11 +814,23 @@ (fxvector? (fxvector 1 2 3 4)) (not (fxvector? '(1 2 3))) (not (fxvector? '#(1 2 3))) + (not (fxvector? '#vfl(1.0 2.0 3.0))) (not (fxvector? '#vu8(1 2 3))) (not (fxvector? "hi there")) (not (fxvector? 234234)) ) +(mat flvector? + (flvector? #vfl(1.0 2.0 3.0)) + (flvector? (flvector 1.0 2.0 3.0 4.0)) + (not (flvector? '(1 2 3))) + (not (flvector? '#(1.0 2.0 3.0))) + (not (flvector? '#vfx(1 2 3))) + (not (flvector? '#vu8(1 2 3))) + (not (flvector? "hi there")) + (not (flvector? 234234)) + ) + (mat bytevector? (bytevector? '#vu8(1 2 3)) (bytevector? (bytevector 1 2 3 4)) diff --git a/src/ChezScheme/mats/5_3.ms b/src/ChezScheme/mats/5_3.ms index 71b469ea61..e7905b2d30 100644 --- a/src/ChezScheme/mats/5_3.ms +++ b/src/ChezScheme/mats/5_3.ms @@ -2101,9 +2101,28 @@ (fl= (remainder 5.0 2.0) 1.0) (fl= (remainder -5.0 3.0) -2.0) (fl= (remainder 5.0 -3.0) 2.0) + (eqv? (remainder -4.0 2.0) 0.0) + (eqv? (remainder 4.0 -2.0) 0.0) + (eqv? (remainder 0 2.0) 0) + (fl= (remainder 5.842423430828094e+60 10) 4.0) + (fl= (remainder 5.842423430828094e+60 10.0) 4.0) + (fl= (remainder 5.842423430828094e+60 -10) 4.0) + (fl= (remainder 5.842423430828094e+60 -10.0) 4.0) + (fl= (remainder -5.842423430828094e+60 10) -4.0) + (fl= (remainder -5.842423430828094e+60 10.0) -4.0) + (fl= (remainder -5.842423430828094e+60 -10) -4.0) + (fl= (remainder -5.842423430828094e+60 -10.0) -4.0) + (fl= (remainder (exact 5.842423430828094e+60) 10.0) 4.0) + (fl= (remainder (exact 5.842423430828094e+60) -10.0) 4.0) + (fl= (remainder (exact -5.842423430828094e+60) 10.0) -4.0) + (fl= (remainder (exact -5.842423430828094e+60) -10.0) -4.0) + (eqv? (remainder (exact 5.842423430828094e+60) 10) 4) + (eqv? (remainder (exact 5.842423430828094e+60) -10) 4) + (eqv? (remainder (exact -5.842423430828094e+60) 10) -4) + (eqv? (remainder (exact -5.842423430828094e+60) -10) -4) ;; following returns incorrect result with naive algorithm, ;; i.e., remainder = (lambda (x,y) (- x (* (quotient x y) y))) - (fl= (remainder 1e194 10.0) 0.0) + (fl= (remainder 1e194 10.0) 8.0) ;; following returns incorrect result in all versions prior to 5.9b (eq? (remainder (most-negative-fixnum) (- (most-negative-fixnum))) 0) ) @@ -2130,6 +2149,25 @@ (fl= (modulo 5.0 2) 1.0) (fl= (modulo 5.0 2.0) 1.0) (fl= (modulo 5.0 2.0) 1.0) + (eqv? (modulo -4.0 2.0) 0.0) + (eqv? (modulo 4.0 -2.0) 0.0) + (eqv? (modulo 0 2.0) 0) + (fl= (modulo 5.842423430828094e+60 10) 4.0) + (fl= (modulo 5.842423430828094e+60 10.0) 4.0) + (fl= (modulo -5.842423430828094e+60 10) 6.0) + (fl= (modulo -5.842423430828094e+60 10.0) 6.0) + (fl= (modulo 5.842423430828094e+60 -10) -6.0) + (fl= (modulo 5.842423430828094e+60 -10.0) -6.0) + (fl= (modulo -5.842423430828094e+60 -10) -4.0) + (fl= (modulo -5.842423430828094e+60 -10.0) -4.0) + (fl= (modulo (exact 5.842423430828094e+60) 10.0) 4.0) + (fl= (modulo (exact -5.842423430828094e+60) 10.0) 6.0) + (fl= (modulo (exact 5.842423430828094e+60) -10.0) -6.0) + (fl= (modulo (exact -5.842423430828094e+60) -10.0) -4.0) + (eqv? (modulo (exact 5.842423430828094e+60) 10) 4) + (eqv? (modulo (exact -5.842423430828094e+60) 10) 6) + (eqv? (modulo (exact 5.842423430828094e+60) -10) -6) + (eqv? (modulo (exact -5.842423430828094e+60) -10) -4) ) (mat truncate diff --git a/src/ChezScheme/mats/5_6.ms b/src/ChezScheme/mats/5_6.ms index 0e46f14fd6..bd4afe218b 100644 --- a/src/ChezScheme/mats/5_6.ms +++ b/src/ChezScheme/mats/5_6.ms @@ -207,31 +207,21 @@ ) (mat $fxvector-ref-check? - (let ([fv (make-fxvector 3)] [imm-fv (fxvector->immutable-fxvector (make-fxvector 3))] [not-fv (make-vector 3)]) + (let ([fv (make-fxvector 3)] [not-fv (make-vector 3)]) (let ([i-1 -1] [i0 0] [i1 1] [i2 2] [i3 3] [ifalse #f] [ibig (+ (most-positive-fixnum) 1)]) (and (not (#%$fxvector-ref-check? not-fv i0)) (not (#%$fxvector-ref-check? fv ifalse)) (not (#%$fxvector-ref-check? fv i-1)) - (not (#%$fxvector-ref-check? imm-fv i-1)) (#%$fxvector-ref-check? fv 0) (#%$fxvector-ref-check? fv 1) (#%$fxvector-ref-check? fv 2) - (#%$fxvector-ref-check? imm-fv 0) - (#%$fxvector-ref-check? imm-fv 1) - (#%$fxvector-ref-check? imm-fv 2) (#%$fxvector-ref-check? fv i0) (#%$fxvector-ref-check? fv i1) (#%$fxvector-ref-check? fv i2) - (#%$fxvector-ref-check? imm-fv i0) - (#%$fxvector-ref-check? imm-fv i1) - (#%$fxvector-ref-check? imm-fv i2) (not (#%$fxvector-ref-check? fv 3)) (not (#%$fxvector-ref-check? fv i3)) - (not (#%$fxvector-ref-check? fv ibig)) - (not (#%$fxvector-ref-check? imm-fv 3)) - (not (#%$fxvector-ref-check? imm-fv i3)) - (not (#%$fxvector-ref-check? imm-fv ibig))))) + (not (#%$fxvector-ref-check? fv ibig))))) ) (mat fxvector-ref @@ -326,6 +316,161 @@ (error? (fxvector->list '(a b c))) ) +(mat flvector + (equal? (flvector 1.0 2.0 3.0 4.0) '#vfl(1.0 2.0 3.0 4.0)) + (eq? (flvector) '#vfl()) + (flvector? (flvector 1.0)) + (flvector? (flvector -1.0)) + (error? (flvector 1)) + (error? (flvector 'a)) + (error? (flvector 1.0 2.0 'a 4.0)) + ) + +(mat make-flvector + (eqv? (flvector-length (make-flvector 10)) 10) + (eqv? (flvector-length (make-flvector 100)) 100) + (eqv? (flvector-length (make-flvector (+ 100 17))) 117) + (eq? (make-flvector 0) '#vfl()) + (let ([x (make-flvector 10)]) + (and (= (flvector-length x) 10) + (andmap flonum? (flvector->list x)))) + (error? (make-flvector 3 'a)) + (error? (make-flvector 10 1)) + (error? (make-flvector 10 'a)) + (equal? (make-flvector 10 7.0) (flvector 7.0 7.0 7.0 7.0 7.0 7.0 7.0 7.0 7.0 7.0)) + (equal? (make-flvector (- 4 2) (+ 1.0 1.0)) (flvector 2.0 2.0)) + (eqv? (make-flvector (- 4 4) (+ 1.0 1.0)) (flvector)) + ) + +(mat flvector-syntax + (eq? '#vfl() '#vfl()) + (eq? '#0vfl() #vfl()) + (equal? + '(#vfl(1.0 2.0 3.0) #3vfl(1.0 2.0 3.0) #6vfl(1.0 2.0 3.0)) + (list (flvector 1.0 2.0 3.0) (flvector 1.0 2.0 3.0) (flvector 1.0 2.0 3.0 3.0 3.0 3.0))) + (let ([x #10vfl()]) + (and (= (flvector-length x) 10) + (andmap flonum? (flvector->list x)))) + ; the following is invalid because the reader doesn't allow graph marks + ; and references within an flvector + ; (equal? '(#0=#vfl(#1=33 #2# #1# #2=44 #3#) #2# #3=55) + ; '(#vfl(33 44 33 44 55) 44 55)) +) + +(mat flvector-length + (eqv? (flvector-length '#vfl(3.0 4.0 5.0)) 3) + (eqv? (flvector-length '#100vfl(5.0 4.0 3.0)) 100) + (eqv? (flvector-length '#vfl()) 0) + (error? (flvector-length '(a b c))) + ) + +(mat $flvector-ref-check? + (let ([fv (make-flvector 3)] [not-fv (make-vector 3)]) + (let ([i-1 -1] [i0 0] [i1 1] [i2 2] [i3 3] [ifalse #f] [ibig (+ (most-positive-fixnum) 1)]) + (and + (not (#%$flvector-ref-check? not-fv i0)) + (not (#%$flvector-ref-check? fv ifalse)) + (not (#%$flvector-ref-check? fv i-1)) + (#%$flvector-ref-check? fv 0) + (#%$flvector-ref-check? fv 1) + (#%$flvector-ref-check? fv 2) + (#%$flvector-ref-check? fv i0) + (#%$flvector-ref-check? fv i1) + (#%$flvector-ref-check? fv i2) + (not (#%$flvector-ref-check? fv 3)) + (not (#%$flvector-ref-check? fv i3)) + (not (#%$flvector-ref-check? fv ibig))))) + ) + +(mat flvector-ref + (eqv? (flvector-ref '#vfl(3.0 4.0 5.0) 0) '3.0) + (eqv? (flvector-ref '#vfl(3.0 4.0 5.0) 1) '4.0) + (eqv? (flvector-ref '#vfl(3.0 4.0 5.0) 2) '5.0) + (error? (flvector-ref '#vfl(3.0 4.0 5.0) 3)) + (error? (flvector-ref '#vfl(3.0 4.0 5.0) -1)) + (error? (flvector-ref '#vfl(3.0 4.0 5.0) 'a)) + (error? (flvector-ref '#(3.0 4.0 5.0) 2)) + (error? (flvector-ref '(3.0 4.0 5.0) 2)) + ) + +(mat flvector-set! + (let ((v (flvector '3.0 '4.0 '5.0))) + (and + (begin (flvector-set! v 0 '33.0) (equal? v '#vfl(33.0 4.0 5.0))) + (begin (flvector-set! v 1 '44.0) (equal? v '#vfl(33.0 44.0 5.0))) + (begin (flvector-set! v 2 '55.0) (equal? v '#vfl(33.0 44.0 55.0))))) + (error? (flvector-set! (flvector '3.0 '4.0 '5.0) 3 'd)) + (error? (flvector-set! (flvector '3.0 '4.0 '5.0) -1 'd)) + (error? (flvector-set! (flvector '3.0 '4.0 '5.0) 'a 'd)) + (error? (flvector-set! (flvector '3.0 '4.0 '5.0) 2 'd)) + (error? (flvector-set! (list '3.0 '4.0 '5.0) 2 'd)) + (error? (flvector-set! (flvector 3.0 4.0 5.0) 1 1)) + (error? (flvector-set! (flvector 3.0 4.0 5.0) 0 'a)) + (begin + (define test-flvector-set! + (lambda (v i x) + (flvector-set! v i x))) + #t) + (equal? + (let ([v (flvector 3.0 4.0 5.0)]) + (test-flvector-set! v 0 -3.0) + (test-flvector-set! v 1 -4.0) + (test-flvector-set! v 2 17.0) + v) + #vfl(-3.0 -4.0 17.0)) + (error? (test-flvector-set! (list 3.0 4.0 5.0) 0 9.0)) + (error? (test-flvector-set! (vector 3.0 4.0) 0 9.0)) + (error? (test-flvector-set! (flvector 3.0 4.0 5.0) 3 9.0)) + (error? (test-flvector-set! (flvector 3.0 4.0 5.0) -3 9.0)) + (error? (test-flvector-set! (flvector 3.0 4.0 5.0) (+ (most-positive-fixnum) 1) 9.0)) + (error? (test-flvector-set! (flvector 3.0 4.0 5.0) (- (most-negative-fixnum) 1) 9.0)) + (error? (test-flvector-set! (flvector 3.0 4.0 5.0) 'a 9.0)) + (error? (test-flvector-set! (flvector 3.0 4.0 5.0) 2 1)) + (error? (test-flvector-set! (flvector 3.0 4.0 5.0) 2 'a)) + ) + +(mat flvector-copy + (equal? (flvector-copy '#vfl()) '#vfl()) + (equal? (flvector-copy '#vfl(3.0 4.0 5.0)) '#vfl(3.0 4.0 5.0)) + (let* ((x1 (flvector 1.0 2.0 3.0)) (x2 (flvector-copy x1))) + (and (equal? x2 x1) (not (eq? x2 x1)))) + (andmap + (lambda (n) + (let ([v (list->flvector (map (lambda (x) (random (inexact x))) (make-list n 1000)))]) + (equal? (flvector-copy v) v))) + (map random (make-list 500 2500))) + (error? (flvector-copy '(a b c))) + ) + +(mat flvector-fill! + (let ([v (flvector-copy '#5vfl(1.0 2.0 3.0 4.0 5.0))]) + (and (equal? v '#5vfl(1.0 2.0 3.0 4.0 5.0)) + (begin + (flvector-fill! v 9.0) + (equal? v '#5vfl(9.0))))) + (let ([v (flvector-copy '#5vfl(1.0 2.0 3.0 4.0 5.0))]) + (and (equal? v '#5vfl(1.0 2.0 3.0 4.0 5.0)) + (begin + (flvector-fill! v -17.0) + (equal? v '#5vfl(-17.0))))) + (error? (let ([v (flvector 1.0)]) (flvector-fill! v 'a))) + (error? (let ([v (vector 1.0)]) (flvector-fill! v 3.0))) + ) + +(mat list->flvector + (equal? (list->flvector '(1.0 2.0 3.0)) '#vfl(1.0 2.0 3.0)) + (equal? (list->flvector '()) '#vfl()) + (error? (list->flvector '#(a b c))) + (error? (list->flvector '(1.0 2.0 . 3.0))) + (error? (list->flvector (let ([ls (list 1.0 2.0 3.0)]) (set-cdr! (cddr ls) (cdr ls)) ls))) + ) + +(mat flvector->list + (equal? (flvector->list '#vfl(1.0 2.0 3.0)) '(1.0 2.0 3.0)) + (equal? (flvector->list '#vfl()) '()) + (error? (flvector->list '(a b c))) + ) + (mat vector-map (error? ; invalid number of arguments (vector-map)) @@ -1226,35 +1371,6 @@ (error? (vector-sort! < immutable-123-vector)) ) - - -(mat fxvector->immutable-fxvector - (begin - (define immutable-123-fxvector - (fxvector->immutable-fxvector (fxvector 1 2 3))) - #t) - - (immutable-fxvector? immutable-123-fxvector) - (not (mutable-fxvector? immutable-123-fxvector)) - - (equal? '#vfx(1 2 3) immutable-123-fxvector) - (eq? immutable-123-fxvector - (fxvector->immutable-fxvector immutable-123-fxvector)) - - (mutable-fxvector? (make-fxvector 5)) - (not (immutable-fxvector? (make-fxvector 5))) - - (immutable-fxvector? (fxvector->immutable-fxvector (fxvector))) - (not (mutable-fxvector? (fxvector->immutable-fxvector (fxvector)))) - (not (immutable-fxvector? (fxvector))) - (mutable-fxvector? (fxvector)) - - (not (immutable-fxvector? (fxvector-copy immutable-123-fxvector))) - - (error? (fxvector-set! immutable-123-fxvector 0 1)) - (error? (fxvector-fill! immutable-123-fxvector 0)) -) - (mat vector-cas! (begin (define vec1 (vector 1 2 3)) diff --git a/src/ChezScheme/mats/6.ms b/src/ChezScheme/mats/6.ms index af58d8dcff..3fcf385e99 100644 --- a/src/ChezScheme/mats/6.ms +++ b/src/ChezScheme/mats/6.ms @@ -782,6 +782,13 @@ (or (< i 0) (and (fx= (fxvector-ref x i) (fxvector-ref y i)) (f (1- i))))))] + [(flvector? x) + (and (flvector? y) + (= (flvector-length x) (flvector-length y)) + (let f ([i (- (flvector-length x) 1)]) + (or (< i 0) + (and (fl= (flvector-ref x i) (flvector-ref y i)) + (f (1- i))))))] [(bytevector? x) (and (bytevector? y) (bytevector=? x y))] diff --git a/src/ChezScheme/mats/8.ms b/src/ChezScheme/mats/8.ms index 2992b4f073..c0519eead2 100644 --- a/src/ChezScheme/mats/8.ms +++ b/src/ChezScheme/mats/8.ms @@ -9302,6 +9302,43 @@ '(#t . #t)) (equal? (let () (import (testfile-clo-3a)) (h)) (void)) (not (let () (import (testfile-clo-3a)) (g))) + + ; testing support of procedures with improper formals + (begin + (with-output-to-file "testfile-clo-4a.ss" + (lambda () + (pretty-print + '(library (testfile-clo-4a) + (export f g) + (import (chezscheme)) + (define (f a . rest) + (apply list a rest)) + (define g + (case-lambda + [(a) "foo"] + [(a . rest) (apply list a rest)]))))) + 'replace) + #t) + (begin + (load-library "testfile-clo-4a.ss" + (lambda (x) (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f] [current-eval compile]) + (eval x)))) + #t) + (or + (and (compile-profile) #t) ; => testfile-clo-4a was compiled with profiling, so not quite the same as below + (equivalent-expansion? + (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) + (expand/optimize + '(lambda (x y z) + (import (testfile-clo-4a)) + (list + (f x y z) + (g x y z))))) + '(begin + (#3%$invoke-library '(testfile-clo-4a) '() 'testfile-clo-4a) + (lambda (x y z) + (#2%list (#2%list x y z) + ((#3%$top-level-value 'g) x y z)))))) ) (mat lots-of-libraries diff --git a/src/ChezScheme/mats/Mf-arm64osx b/src/ChezScheme/mats/Mf-arm64osx new file mode 100644 index 0000000000..b1d870ab48 --- /dev/null +++ b/src/ChezScheme/mats/Mf-arm64osx @@ -0,0 +1,14 @@ +# Mf-arm64osx + +m ?= arm64osx + +fsrc = foreign1.c foreign2.c foreign3.c foreign4.c +fobj = foreign1.so + +include Mf-base + +foreign1.so: ${fsrc} ../boot/$m/scheme.h + cc -dynamiclib -undefined dynamic_lookup -I${Include} -o foreign1.so ${fsrc} + +cat_flush: cat_flush.c + cc -o cat_flush cat_flush.c diff --git a/src/ChezScheme/mats/Mf-base b/src/ChezScheme/mats/Mf-base index 712734a7cf..74007de5df 100644 --- a/src/ChezScheme/mats/Mf-base +++ b/src/ChezScheme/mats/Mf-base @@ -444,6 +444,9 @@ prettyclean: clean: prettyclean rm -f Make.out +.PHONY: run +run: + env SCHEMEHEAPDIRS=../boot/$m/ ../bin/$m/scheme $(ARGS) ### rules for generating various experr files diff --git a/src/ChezScheme/mats/Mf-ppc32osx b/src/ChezScheme/mats/Mf-ppc32osx new file mode 100644 index 0000000000..21599d86b5 --- /dev/null +++ b/src/ChezScheme/mats/Mf-ppc32osx @@ -0,0 +1,14 @@ +# Mf-ppc32osx + +m ?= ppc32osx + +fsrc = foreign1.c foreign2.c foreign3.c foreign4.c +fobj = foreign1.so + +include Mf-base + +foreign1.so: ${fsrc} ../boot/$m/scheme.h + cc -dynamiclib -undefined dynamic_lookup -I${Include} -o foreign1.so ${fsrc} + +cat_flush: cat_flush.c + cc -o cat_flush cat_flush.c diff --git a/src/ChezScheme/mats/Mf-tarm64osx b/src/ChezScheme/mats/Mf-tarm64osx new file mode 100644 index 0000000000..520b683f43 --- /dev/null +++ b/src/ChezScheme/mats/Mf-tarm64osx @@ -0,0 +1,5 @@ +# Mf-tarm64osx + +m = tarm64osx + +include Mf-arm64osx diff --git a/src/ChezScheme/mats/Mf-tppc32osx b/src/ChezScheme/mats/Mf-tppc32osx new file mode 100644 index 0000000000..2a1a6584ed --- /dev/null +++ b/src/ChezScheme/mats/Mf-tppc32osx @@ -0,0 +1,5 @@ +# Mf-tppc32osx + +m ?= tppc32osx + +include Mf-ppc32osx diff --git a/src/ChezScheme/mats/bytevector.ms b/src/ChezScheme/mats/bytevector.ms index e126dfc722..5cd08cd25e 100644 --- a/src/ChezScheme/mats/bytevector.ms +++ b/src/ChezScheme/mats/bytevector.ms @@ -34,7 +34,7 @@ (case (machine-type) [(i3le ti3le i3nt ti3nt a6nt ta6nt i3ob ti3ob i3fb ti3fb i3nb ti3nb i3osx ti3osx a6le ta6le a6nb ta6nb a6osx ta6osx a6fb ta6fb a6ob ta6ob a6s2 ta6s2 i3s2 ti3s2 i3qnx ti3qnx - arm32le tarm32le arm64le tarm64le) + arm32le tarm32le arm64le tarm64le arm64osx tarm64osx) 'little] [(ppc32le tppc32le) 'big] [(pb) (native-endianness)] diff --git a/src/ChezScheme/mats/cp0.ms b/src/ChezScheme/mats/cp0.ms index 3da3b9642c..00346420c1 100644 --- a/src/ChezScheme/mats/cp0.ms +++ b/src/ChezScheme/mats/cp0.ms @@ -377,6 +377,18 @@ '(lambda (x) (#3%$value (if x 1 (#2%values 3 3 3))) #t))) + + (not + (equivalent-expansion? + (expand/optimize + '(lambda (g x y) + (call-with-values (lambda () + (values + (values x y))) + (case-lambda + [(x y) (g x y)])))) + '(lambda (g x y) (g x y)))) + ) (cp0-mat cp0-mrvs @@ -2453,7 +2465,11 @@ (begin (#%write 'e) ($xxx-ok)))))) ; other possibilities exist... '(begin (#%write 'a) (#%write 'b) (#%cdr (begin (#%write 'c) (#%write 'd) (#%write 'e) ($xxx-ok))))) - ) + (expansion-matches? + '(cdr (let ([x (#%write 1)]) + (cons x (#%write 2)))) + '(begin (#%write 1) (#%write 2))) + ) (mat cp0-seq-ref (equivalent-expansion? @@ -2858,13 +2874,14 @@ '(let () (define-record foo ((immutable boolean x))) (or (foo-x e1) e2)))) - `(if (let ([g0 e1]) - (if (#3%record? g0 ',record-type-descriptor?) - (#2%void) - (#3%$record-oops 'foo-x g0 ',record-type-descriptor?)) - (#3%$object-ref 'boolean g0 ,fixnum?)) - #t - e2)) + `(let ([g0 e1]) + (if (begin + (if (#3%record? g0 ',record-type-descriptor?) + (#2%void) + (#3%$record-oops 'foo-x g0 ',record-type-descriptor?)) + (#3%$object-ref 'boolean g0 ,fixnum?)) + #t + e2))) (equivalent-expansion? (parameterize ([#%$suppress-primitive-inlining #f] [run-cp0 (lambda (cp0 x) (cp0 x))] [optimize-level 3] [compile-profile #f]) (expand/optimize @@ -3139,5 +3156,186 @@ (list (mk (lambda () 1)) (mk (lambda () (values 1 2)))))) '(#t #f))) + + (or (not (enable-cp0)) + (eq? (current-eval) interpret) + (procedure-known-single-valued? (lambda (f) (#3%$app/value f)))) + (or (not (enable-cp0)) + (not (procedure-known-single-valued? (lambda (f) (#2%$app/value f))))) + (or (not (enable-cp0)) + (eq? (current-eval) interpret) + (procedure-known-single-valued? (case-lambda + [(f) (#3%$app/value f)] + [(f g) (if (g) + (abort 'oops) + (#3%$app/value f))]))) + (or (not (enable-cp0)) + (eq? (current-eval) interpret) + (procedure-known-single-valued? (lambda () (abort 'x)))) + (or (not (enable-cp0)) + (eq? (current-eval) interpret) + (procedure-known-single-valued? (lambda (f) (#3%$app/no-return f)))) + (or (not (enable-cp0)) + (not (procedure-known-single-valued? (lambda (f) (#2%$app/no-return f))))) + (or (not (enable-cp0)) + (eq? (current-eval) interpret) + (procedure-known-single-valued? (case-lambda + [(f) (#3%$app/no-return f)] + [(f g) (if (g) + (abort 'oops) + (#3%$app/no-return f))]))) + +) + +(mat make-wrapper-procedure + (equivalent-expansion? + (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f]) + (expand/optimize '((make-wrapper-procedure (lambda (x) x) 2 'ok) 5))) + 5) + (equivalent-expansion? + (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f]) + (expand/optimize '((make-arity-wrapper-procedure (lambda (x) x) 2 'ok) 5))) + 5) + + (equivalent-expansion? + (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f]) + (expand/optimize '((make-wrapper-procedure (lambda (x) x) 2 (g)) 5))) + (if (= 3 (optimize-level)) + '(begin (g) 5) + '(begin (#3%$value (g)) 5))) + (equivalent-expansion? + (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f]) + (expand/optimize '((make-arity-wrapper-procedure (lambda (x) x) 2 (g)) 5))) + (if (= 3 (optimize-level)) + '(begin (g) 5) + '(begin (#3%$value (g)) 5))) + + (equivalent-expansion? + (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f]) + (expand/optimize '(let ([f (make-wrapper-procedure (lambda (x) x) 2 (g))]) (f 5)))) + (if (= 3 (optimize-level)) + '(begin (g) 5) + '(begin (#3%$value (g)) 5))) + (equivalent-expansion? + (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f]) + (expand/optimize '(let ([f (make-arity-wrapper-procedure (lambda (x) x) 2 (g))]) (f 5)))) + (if (= 3 (optimize-level)) + '(begin (g) 5) + '(begin (#3%$value (g)) 5))) + + (equivalent-expansion? + (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f]) + (expand/optimize '(let ([g (let ([f (make-wrapper-procedure (lambda (x) x) 2 (g))]) f)]) (g 5)))) + (if (= 3 (optimize-level)) + '(begin (g) 5) + '(begin (#3%$value (g)) 5))) + + (not + (equivalent-expansion? + (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f]) + (expand/optimize '(let ([f (#2%make-wrapper-procedure (lambda (x) x) 2 (g))]) (#2%list (g f) (f 5))))) + '(#2%list (g (#2%make-wrapper-procedure (lambda (x) x) 2 (g))) 5))) + (not + (equivalent-expansion? + (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f]) + (expand/optimize '(let ([f (#2%make-arity-wrapper-procedure (lambda (x) x) 2 (g))]) (#2%list (g f) (f 5))))) + '(#2%list (g (#2%make-arity-wrapper-procedure (lambda (x) x) 2 (g))) 5))) + + (not + (equivalent-expansion? + (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f]) + ;; arity mismatch: + (expand/optimize '((make-arity-wrapper-procedure (lambda (x) x) 1 'ok) 5))) + 5)) + ) + +(mat uncprep-app-variants + (parameterize ([enable-cp0 #t]) + (equivalent-expansion? + (expand/optimize '(x y)) + '(x y))) + (parameterize ([enable-cp0 #t]) + (equivalent-expansion? + (expand/optimize '(#%$app x y)) + '(x y))) + (parameterize ([enable-cp0 #t]) + (equivalent-expansion? + (expand/optimize '(#3%$app x y)) + (if (eqv? 3 (optimize-level)) + '(x y) + '(#3%$app x y)))) + (parameterize ([enable-unsafe-application #t] + [enable-cp0 #t]) + (equivalent-expansion? + (expand/optimize '(x y)) + '(x y))) + (parameterize ([enable-unsafe-application #t] + [enable-cp0 #t]) + (equivalent-expansion? + (expand/optimize '(#3%$app x y)) + '(x y))) + + (parameterize ([enable-cp0 #t]) + (equivalent-expansion? + (expand/optimize '(#%$app/no-return x y)) + '($app/no-return x y))) + (parameterize ([enable-cp0 #t]) + (equivalent-expansion? + (expand/optimize '(#3%$app/no-return x y)) + (if (eqv? 3 (optimize-level)) + '($app/no-return x y) + '(#3%$app/no-return x y)))) + (parameterize ([enable-unsafe-application #t] + [enable-cp0 #t]) + (equivalent-expansion? + (expand/optimize '(#%$app/no-return x y)) + '($app/no-return x y))) + (parameterize ([enable-unsafe-application #t] + [enable-cp0 #t]) + (equivalent-expansion? + (expand/optimize '(#3%$app/no-return x y)) + '($app/no-return x y))) + + (parameterize ([enable-cp0 #t]) + (equivalent-expansion? + (expand/optimize '(#%$app/no-inline x y)) + '($app/no-inline x y))) + (parameterize ([enable-cp0 #t]) + (equivalent-expansion? + (expand/optimize '(#3%$app/no-inline x y)) + (if (eqv? 3 (optimize-level)) + '($app/no-inline x y) + '(#3%$app/no-inline x y)))) + (parameterize ([enable-unsafe-application #t] + [enable-cp0 #t]) + (equivalent-expansion? + (expand/optimize '(#%$app/no-inline x y)) + '($app/no-inline x y))) + (parameterize ([enable-unsafe-application #t] + [enable-cp0 #t]) + (equivalent-expansion? + (expand/optimize '(#3%$app/no-inline x y)) + '($app/no-inline x y))) + + (parameterize ([enable-cp0 #t]) + (equivalent-expansion? + (expand/optimize '(#%$app/value x y)) + '($app/value x y))) + (parameterize ([enable-cp0 #t]) + (equivalent-expansion? + (expand/optimize '(#3%$app/value x y)) + (if (eqv? 3 (optimize-level)) + '($app/value x y) + '(#3%$app/value x y)))) + (parameterize ([enable-unsafe-application #t] + [enable-cp0 #t]) + (equivalent-expansion? + (expand/optimize '(#%$app/value x y)) + '($app/value x y))) + (parameterize ([enable-unsafe-application #t] + [enable-cp0 #t]) + (equivalent-expansion? + (expand/optimize '(#3%$app/value x y)) + '($app/value x y))) ) diff --git a/src/ChezScheme/mats/cptypes.ms b/src/ChezScheme/mats/cptypes.ms index a14af82f71..c1624af97e 100644 --- a/src/ChezScheme/mats/cptypes.ms +++ b/src/ChezScheme/mats/cptypes.ms @@ -126,10 +126,10 @@ '(let ([y (vector 1 2 3)]) (display (list y y)) #t)) (cptypes-equivalent-expansion? '(vector? (let ([y (vector 1 2 3)]) (display (list y y)) y)) - '(begin (let ([y (vector 1 2 3)]) (display (list y y)) y) #t)) + '(let ([y (vector 1 2 3)]) (display (list y y)) #t)) (cptypes-equivalent-expansion? '(vector? (let ([y (vector 1 2 3)]) (display (list y y)) (vector 4 5 6))) - '(begin (let ([y (vector 1 2 3)]) (display (list y y)) (vector 4 5 6)) #t)) + '(let ([y (vector 1 2 3)]) (display (list y y)) #t)) (cptypes-equivalent-expansion? '(lambda (x) (when (null? x) (display x))) '(lambda (x) (when (null? x) (display '())))) @@ -198,6 +198,18 @@ (cptypes-equivalent-expansion? '(lambda (x) (vector-set! x 0 0) (#2%odd? x) 1) '(lambda (x) (vector-set! x 0 0) (#2%odd? x) 2)) + (cptypes-equivalent-expansion? + '(lambda (x) (when (or (fixnum? x) (bignum? x)) (zero? x))) + '(lambda (x) (when (or (fixnum? x) (bignum? x)) (#3%eq? x 0)))) + (cptypes-equivalent-expansion? + '(lambda (x) (when (and (or (fixnum? x) (bignum? x)) (zero? x)) x)) + '(lambda (x) (when (and (or (fixnum? x) (bignum? x)) (zero? x)) 0))) + (cptypes-equivalent-expansion? + '(lambda (x) (when (fixnum? x) (zero? x))) + '(lambda (x) (when (fixnum? x) (#3%fxzero? x)))) + (cptypes-equivalent-expansion? + '(lambda (x) (when (and (fixnum? x) (zero? x)) x)) + '(lambda (x) (when (and (fixnum? x) (zero? x)) 0))) ) (mat cptypes-type-if @@ -548,7 +560,8 @@ (test-chain '((lambda (x) (eq? x 0)) fixnum? #;exact-integer? real? number?)) (test-chain* '(fixnum? integer? real?)) (test-chain* '(fixnum? exact? number?)) ; exact? may raise an error - (test-chain* '((lambda (x) (eq? x (expt 256 100))) real? number?)) ; bignum? + (test-chain* '(bignum? exact? number?)) ; exact? may raise an error + (test-chain* '((lambda (x) (eq? x (expt 256 100))) bignum? real? number?)) (test-chain '((lambda (x) (eqv? 0.0 x)) flonum? real? number?)) (test-chain '(gensym? symbol?)) (test-chain '(not boolean?)) diff --git a/src/ChezScheme/mats/fl.ms b/src/ChezScheme/mats/fl.ms index 17e63d9f90..8658aeeaba 100644 --- a/src/ChezScheme/mats/fl.ms +++ b/src/ChezScheme/mats/fl.ms @@ -1172,6 +1172,12 @@ (check-loop-allocation (lambda (v) (let ([v (fl+ v 1.0)]) (bytevector-ieee-double-native-set! bv 0 v) (fl* v 0.99))))) + (let ([flv (make-flvector 8 0.0)]) + (check-loop-allocation (lambda (v) (fl+ v (flvector-ref flv 0))))) + (let ([flv (make-flvector 8 0.0)]) + (check-loop-allocation (lambda (v) (let ([v (fl+ v 1.0)]) + (flvector-set! flv 0 v) + (fl* v 0.99))))) (or (not (enable-cp0)) (let () (define-record pseudo-random-generator diff --git a/src/ChezScheme/mats/foreign.ms b/src/ChezScheme/mats/foreign.ms index de2c6d86bf..6ff0133bfc 100644 --- a/src/ChezScheme/mats/foreign.ms +++ b/src/ChezScheme/mats/foreign.ms @@ -221,7 +221,7 @@ (error? (load-shared-object 3)) ) ] - [(i3osx ti3osx a6osx ta6osx) + [(i3osx ti3osx a6osx ta6osx ppc32osx tppc32osx arm64osx tarm64osx) (mat load-shared-object (file-exists? "foreign1.so") (begin (load-shared-object "./foreign1.so") #t) @@ -1044,10 +1044,13 @@ (define call-df (foreign-procedure "call_df" (ptr double-float int int) double-float)) (define call-varargs-df (foreign-procedure "call_varargs_df" (ptr double-float int int) double-float)) (define call-varargs-i7df (foreign-procedure "call_varargs_i7df" (ptr int - double-float double-float double-float - double-float double-float double-float - double-float) + double-float double-float double-float + double-float double-float double-float + double-float) double-float)) + (define call-varargs-dfii (foreign-procedure "call_varargs_dfii" (ptr double-float int int) double-float)) + (define call-varargs-dfidf (foreign-procedure "call_varargs_dfidf" (ptr double-float int double-float) double-float)) + (define call-varargs-dfsfi (foreign-procedure "call_varargs_dfsfi" (ptr double-float single-float int) double-float)) (define ($test-call-int signed? size call-int make-fc) (define n10000 (expt 256 size)) (define nffff (- n10000 1)) @@ -1178,6 +1181,35 @@ 1 2.2 3.2 4.5 6.7 8.9 10.1 11.5) 55.1) + (equal? + (call-varargs-dfii + (foreign-callable + (__varargs_after 2) + (lambda (x y z) (+ x y z)) + (double-float int int) double-float) + 10.25 20 300) + 620.25) + + (equal? + (call-varargs-dfidf + (foreign-callable + (__varargs_after 2) + (lambda (x y z) (+ x y z)) + (double-float int double-float) double-float) + 10.25 20 300.25) + 330.75) + + (equal? + (call-varargs-dfsfi + (foreign-callable + (__varargs_after 2) + (lambda (x y z) (+ x y z)) + (double-float single-float int) double-float) + 10.25 20.0 300) + 620.5) + + ;(define call-varargs-dfsfi (foreign-procedure #;__varargs #;2 "call_varargs_dfsfi" (ptr double-float single-float int) double-float)) + (error? (call-i8 (foreign-callable @@ -2735,9 +2767,15 @@ '(load-shared-object "libc.so.7")] [(i3nt ti3nt a6nt ta6nt) '(load-shared-object "msvcrt.dll")] - [(i3osx ti3osx a6osx ta6osx) + [(i3osx ti3osx a6osx ta6osx ppc32osx tppc32osx arm64osx tarm64osx) '(load-shared-object "libc.dylib")] [else (error 'load-libc "unrecognized machine type ~s" (machine-type))])) + (define varargs_df (foreign-procedure (__varargs_after 1) "varargs_df" (double int int) double)) + (define varargs_dfii (foreign-procedure (__varargs_after 2) "varargs_dfii" (double int int) double)) + (define varargs_dfidf (foreign-procedure (__varargs_after 2) "varargs_dfidf" (double int double) double)) + (define varargs_sfdfi (foreign-procedure (__varargs_after 2) "varargs_sfdfi" (float double int) double)) + (define varargs_i7df (foreign-procedure (__varargs_after 1) "varargs_i7df" (int double double double double double double double) + double)) #t) (equal? (with-input-from-string @@ -2798,6 +2836,22 @@ (double-float double-float) single-float) 3.5 -5.25))) 3.25) + + (equal? + (varargs_df 13.5 7 10) + 30.5) + (equal? + (varargs_dfii 13.5 -7 -10) + -3.5) + (equal? + (varargs_dfidf 13.5 10 7.5) + 31.0) + (equal? + (varargs_sfdfi 10.5 3.25 8) + 21.75) + (equal? + (varargs_i7df 1 2.0 3.0 4.0 5.0 6.0 7.0 8.0) + 36.0) ) (mat structs diff --git a/src/ChezScheme/mats/foreign2.c b/src/ChezScheme/mats/foreign2.c index 56b2f5b2db..ae6af8b666 100644 --- a/src/ChezScheme/mats/foreign2.c +++ b/src/ChezScheme/mats/foreign2.c @@ -16,6 +16,7 @@ #include <stdio.h> #include <wchar.h> +#include <stdarg.h> #ifdef _WIN32 # define SCHEME_IMPORT @@ -244,10 +245,27 @@ EXPORT double_float call_df(ptr code, double_float x, int m, int k) { return (*((double_float (*) (double_float))Sforeign_callable_entry_point(code)))(x + m) + k; } +/* varargs after 1 argument */ EXPORT double_float call_varargs_df(ptr code, double_float x, int m, int k) { return (*((double_float (*) (double, ...))Sforeign_callable_entry_point(code)))(x - m, x + m) + k; } +/* varargs after 2 arguments */ +EXPORT double_float call_varargs_dfii(ptr code, double_float x, int m, int k) { + return (*((double_float (*) (double, int, ...))Sforeign_callable_entry_point(code)))(x - m, x + m, k) + k; +} + +/* varargs after 2 arguments */ +EXPORT double_float call_varargs_dfidf(ptr code, double_float x, int m, double k) { + return (*((double_float (*) (double, int, ...))Sforeign_callable_entry_point(code)))(x - m, x + m, x) + k; +} + +/* varargs after 2 arguments */ +EXPORT double_float call_varargs_dfsfi(ptr code, double_float x, single_float m, int k) { + return (*((double_float (*) (double, float, ...))Sforeign_callable_entry_point(code)))(x - m, x + m, k) + k; +} + +/* varargs after 1 argument */ EXPORT double_float call_varargs_i7df(ptr code, int i, double_float a, double_float b, double_float c, double_float d, double_float e, double_float f, @@ -255,6 +273,62 @@ EXPORT double_float call_varargs_i7df(ptr code, int i, return (*((double_float (*) (int, ...))Sforeign_callable_entry_point(code)))(i, a, b, c, d, e, f, g); } +EXPORT double_float varargs_df(double_float x, ...) { + va_list va; + int m, k; + va_start(va, x); + m = va_arg(va, int); + k = va_arg(va, int); + va_end(va); + return x + m + k; +} + +EXPORT double_float varargs_dfii(double_float x, int m, ...) { + va_list va; + int k; + va_start(va, m); + k = va_arg(va, int); + va_end(va); + return x + m + k; +} + +EXPORT double_float varargs_dfidf(double_float x, int m, ...) { + va_list va; + double k; + va_start(va, m); + k = va_arg(va, double); + va_end(va); + return x + m + k; +} + +EXPORT double_float varargs_sfdfi(single_float x, double_float m, ...) { + va_list va; + int k; + va_start(va, m); + k = va_arg(va, int); + va_end(va); + return x + m + k; +} + +EXPORT double_float varargs_i7df(int i, ...) { + va_list va; + double_float a, b, c; + double_float d, e, f; + double_float g; + + va_start(va, i); + a = va_arg(va, double_float); + b = va_arg(va, double_float); + c = va_arg(va, double_float); + d = va_arg(va, double_float); + e = va_arg(va, double_float); + f = va_arg(va, double_float); + g = va_arg(va, double_float); + va_end(va); + + return a + b + c + d + e + f + g + i; +} + EXPORT u8 *u8_star_to_u8_star(u8 *s) { return s == (u8 *)0 ? (u8 *)0 : s + 1; } diff --git a/src/ChezScheme/mats/fx.ms b/src/ChezScheme/mats/fx.ms index 7654f5064b..a7c18e66e2 100644 --- a/src/ChezScheme/mats/fx.ms +++ b/src/ChezScheme/mats/fx.ms @@ -465,6 +465,25 @@ (test-cp0-expansion eqv? '(r6rs:fx+ 3 3) 6) ) +(mat fx+/wraparound + (eqv? (fx+/wraparound 3 0) 3) + (eqv? (fx+/wraparound 3 1) 4) + (eqv? (fx+/wraparound -3 4) 1) + (error? (fx+/wraparound '(a . b) 0)) + (error? (fx+ (add1 (most-positive-fixnum)) 1)) + (error? (fx+ 1 (add1 (most-positive-fixnum)))) + (error? (fx+ (sub1 (most-negative-fixnum)) 1)) + (error? (fx+ 1 (sub1 (most-negative-fixnum)))) + (eqv? (fx+/wraparound (most-positive-fixnum) 1) (most-negative-fixnum)) + (eqv? (fx+/wraparound (most-positive-fixnum) 2) (add1 (most-negative-fixnum))) + (eqv? (fx+/wraparound (most-negative-fixnum) -1) (most-positive-fixnum)) + (eqv? (fx+/wraparound (most-negative-fixnum) -2) (sub1 (most-positive-fixnum))) + (eqv? (fx+/wraparound (most-positive-fixnum) (most-positive-fixnum)) -2) + (eqv? (fx+/wraparound (most-negative-fixnum) (most-negative-fixnum)) 0) + (eqv? (fx+/wraparound (collect-maximum-generation) 0) (collect-maximum-generation)) + (eqv? (fx+/wraparound 0 (collect-maximum-generation)) (collect-maximum-generation)) + ) + (mat fx- (eqv? (fx- 3 0) 3) (eqv? (fx- 3 1) 2) @@ -533,6 +552,24 @@ (test-cp0-expansion eqv? '(r6rs:fx- 3) -3) ) +(mat fx-/wraparound + (eqv? (fx-/wraparound 3 0) 3) + (eqv? (fx-/wraparound 3 1) 2) + (eqv? (fx-/wraparound -3 4) -7) + (error? (fx-/wraparound '(a . b) 0)) + (error? (fx- (add1 (most-positive-fixnum)) 1)) + (error? (fx- 1 (add1 (most-positive-fixnum)))) + (error? (fx- (sub1 (most-negative-fixnum)) 1)) + (error? (fx- 1 (sub1 (most-negative-fixnum)))) + (eqv? (fx-/wraparound (most-negative-fixnum) 1) (most-positive-fixnum)) + (eqv? (fx-/wraparound (most-negative-fixnum) 2) (sub1 (most-positive-fixnum))) + (eqv? (fx-/wraparound (most-positive-fixnum) -1) (most-negative-fixnum)) + (eqv? (fx-/wraparound (most-positive-fixnum) -2) (add1 (most-negative-fixnum))) + (eqv? (fx-/wraparound (most-positive-fixnum) (most-negative-fixnum)) -1) + (eqv? (fx-/wraparound (most-negative-fixnum) (most-positive-fixnum)) 1) + (eqv? (fx-/wraparound (collect-maximum-generation) 0) (collect-maximum-generation)) + ) + (mat fx* (eqv? (fx* 3 0) 0) (eqv? (fx* 3 1) 3) @@ -589,6 +626,26 @@ (test-cp0-expansion eqv? '(r6rs:fx* 3 3) 9) ) +(mat fx*/wraparound + (eqv? (fx*/wraparound 3 0) 0) + (eqv? (fx*/wraparound 3 1) 3) + (eqv? (fx*/wraparound -3 4) -12) + (error? (fx*/wraparound '(a . b) 0)) + (error? (fx* (add1 (most-positive-fixnum)) 1)) + (error? (fx* 1 (add1 (most-positive-fixnum)))) + (error? (fx* (sub1 (most-negative-fixnum)) 1)) + (error? (fx* 1 (sub1 (most-negative-fixnum)))) + (eqv? (fx*/wraparound (most-negative-fixnum) -1) (most-negative-fixnum)) + (eqv? (fx*/wraparound (most-negative-fixnum) 2) 0) + (eqv? (fx*/wraparound (most-positive-fixnum) -1) (add1 (most-negative-fixnum))) + (eqv? (fx*/wraparound (most-positive-fixnum) 2) -2) + (eqv? (fx*/wraparound (most-positive-fixnum) -2) 2) + (eqv? (fx*/wraparound (most-positive-fixnum) (most-negative-fixnum)) (most-negative-fixnum)) + (eqv? (fx*/wraparound (most-negative-fixnum) (most-positive-fixnum)) (most-negative-fixnum)) + (eqv? (fx*/wraparound (collect-maximum-generation) 1) (collect-maximum-generation)) + (eqv? (fx*/wraparound 1 (collect-maximum-generation)) (collect-maximum-generation)) + ) + (mat fxquotient (eqv? (fxquotient 3 1) 3) (eqv? (fxquotient 3 4) 0) @@ -1456,7 +1513,7 @@ (test-cp0-expansion eqv? '(fxsll 1 3) 8) (test-cp0-expansion eqv? '(fxsll 1 4) 16) (test-cp0-expansion eqv? '(fxsll 1 (/ 8 2)) 16) - ) + ) (mat fxarithmetic-shift-left ; bound on shift count is one less than for fxsll @@ -1500,7 +1557,25 @@ (test-cp0-expansion eqv? '(fxarithmetic-shift-left 1 3) 8) (test-cp0-expansion eqv? '(fxarithmetic-shift-left 1 4) 16) (test-cp0-expansion eqv? '(fxarithmetic-shift-left 1 (/ 8 2)) 16) - ) + ) + +(mat fsll/wraparound + (eqv? (fxsll/wraparound 3 0) 3) + (eqv? (fxsll/wraparound 3 1) 6) + (eqv? (fxsll/wraparound -3 4) -48) + (error? (fxsll/wraparound '(a . b) 0)) + (error? (fxsll/wraparound 4 -3)) + (error? (fxsll/wraparound 4 1000)) + (error? (fxsll/wraparound 4 -1000)) + (error? (fxsll (add1 (most-positive-fixnum)) 1)) + (error? (fxsll 1 (add1 (most-positive-fixnum)))) + (error? (fxsll (sub1 (most-negative-fixnum)) 1)) + (error? (fxsll 1 (sub1 (most-negative-fixnum)))) + (eqv? (fxsll/wraparound (most-negative-fixnum) 1) 0) + (eqv? (fxsll/wraparound (most-negative-fixnum) 30) 0) + (eqv? (fxsll/wraparound (most-positive-fixnum) 1) -2) + (eqv? (fxsll/wraparound (most-positive-fixnum) 5) -32) + ) (mat fxsrl (error? (fxsrl 1 -1)) @@ -2904,3 +2979,40 @@ '(fxreverse-bit-field -1 0 (fx- (fixnum-width) 1)) -1) ) + +(mat cp-regression-check + (begin + (define ($regression-go th) (th 'break)) + (define ($regression-slow v) (inexact->exact (exact->inexact v))) + + (let () + (define l '(1 2 3 4 5)) + (define expected (fxvector 1 2 3 4 5)) + + (define xs (make-fxvector (length l))) + + (define (list->fxvector vs) + (let ([n 5]) + ($regression-go + (lambda (break) + (let loop ([i 0] [vs vs]) + (unless (null? vs) + (let ([v (car vs)]) + (#3%fxvector-set! xs i ($regression-slow v)) + (loop (fx+ i 1) (cdr vs))))))) + xs)) + + (let loop ([i 1000000]) + (cond + [(zero? i) #t] + [else + (fxvector-set! xs 0 0) + (fxvector-set! xs 1 0) + (fxvector-set! xs 2 0) + (fxvector-set! xs 3 0) + (fxvector-set! xs 4 0) + (let ([v (list->fxvector l)]) + (unless (equal? v expected) + (error 'failed "~a oops ~s\n" i v))) + (loop (sub1 i))])))) + ) diff --git a/src/ChezScheme/mats/hash.ms b/src/ChezScheme/mats/hash.ms index a61f7c7643..2918e7097a 100644 --- a/src/ChezScheme/mats/hash.ms +++ b/src/ChezScheme/mats/hash.ms @@ -1367,7 +1367,7 @@ ; test for proper shrinkage (eqv? - (let ([ht (make-eq-hashtable 32)]) + (let ([ht (make-weak-eq-hashtable 32)]) (for-each (lambda (k*) (for-each (lambda (k) (hashtable-delete! ht k)) k*)) (let ([k** (map (lambda (x) (map list (make-list 1000))) @@ -1592,7 +1592,7 @@ ; test for proper shrinkage (eqv? - (let ([ht (make-eq-hashtable 32)]) + (let ([ht (make-ephemeron-eq-hashtable 32)]) (for-each (lambda (k*) (for-each (lambda (k) (hashtable-delete! ht k)) k*)) (let ([k** (map (lambda (x) (map list (make-list 1000))) @@ -1663,6 +1663,7 @@ [(5) (open-output-string)] [(6) (fxvector 15 55)] [(7) (lambda () x)] + [(8) (flvector 15.0 55.0)] [else (box 'top)]))) (let ([ls1 (let f ([n 10000]) (if (fx= n 0) @@ -2055,7 +2056,7 @@ ; test for proper shrinkage (eqv? - (let ([ht (make-eq-hashtable 32)]) + (let ([ht (make-weak-eq-hashtable 32)]) (for-each (lambda (k*) (for-each (lambda (k) (eq-hashtable-delete! ht k)) k*)) (let ([k** (map (lambda (x) (map list (make-list 1000))) @@ -2234,7 +2235,7 @@ ; test for proper shrinkage (eqv? - (let ([ht (make-eq-hashtable 32)]) + (let ([ht (make-ephemeron-eq-hashtable 32)]) (for-each (lambda (k*) (for-each (lambda (k) (eq-hashtable-delete! ht k)) k*)) (let ([k** (map (lambda (x) (map list (make-list 1000))) @@ -2748,20 +2749,20 @@ (set! ko (void)) (collect (collect-maximum-generation)) (list (hashtable-size h2) (hashtable-size h3))) - '(4 4)) - (equal-entries? h2 `#((c) -5.75 17 ,(+ (most-positive-fixnum) 5)) '#(cval mval nval oval)) - (equal-entries? h3 `#((c) -5.75 17 ,(+ (most-positive-fixnum) 5)) '#(cval mval nval oval)) + '(2 2)) + (equal-entries? h2 `#((c) 17) '#(cval nval)) + (equal-entries? h3 `#((c) 17) '#(cval nval)) (eqv? (begin (set! h3 (void)) (collect (collect-maximum-generation)) (hashtable-size h2)) - 4) - (equal-entries? h2 `#((c) -5.75 17 ,(+ (most-positive-fixnum) 5)) '#(cval mval nval oval)) + 2) + (equal-entries? h2 `#((c) 17) '#(cval nval)) ; test for proper shrinkage (equal? - (let ([ht (make-eqv-hashtable 32)]) + (let ([ht (make-weak-eqv-hashtable 32)]) (for-each (lambda (k*) (for-each (lambda (k) (hashtable-delete! ht k)) k*)) (let ([k** (map (lambda (x) (map list (make-list 1000))) @@ -2983,20 +2984,20 @@ (set! ko (void)) (collect (collect-maximum-generation)) (list (hashtable-size h2) (hashtable-size h3))) - '(4 4)) - (equal-entries? h2 `#((c) -5.75 17 ,(+ (most-positive-fixnum) 5)) '#(cval mval nval oval)) - (equal-entries? h3 `#((c) -5.75 17 ,(+ (most-positive-fixnum) 5)) '#(cval mval nval oval)) + '(2 2)) + (equal-entries? h2 `#((c) 17) '#(cval nval)) + (equal-entries? h3 `#((c) 17) '#(cval nval)) (eqv? (begin (set! h3 (void)) (collect (collect-maximum-generation)) (hashtable-size h2)) - 4) - (equal-entries? h2 `#((c) -5.75 17 ,(+ (most-positive-fixnum) 5)) '#(cval mval nval oval)) + 2) + (equal-entries? h2 `#((c) 17) '#(cval nval)) ; test for proper shrinkage (equal? - (let ([ht (make-eqv-hashtable 32)]) + (let ([ht (make-ephemeron-eqv-hashtable 32)]) (for-each (lambda (k*) (for-each (lambda (k) (hashtable-delete! ht k)) k*)) (let ([k** (map (lambda (x) (map list (make-list 1000))) @@ -3038,6 +3039,7 @@ [(5) (open-output-string)] [(6) (fxvector 15 55)] [(7) (lambda () x)] + [(8) (flvector 15.0 55.0)] [else (box 'top)]))) (let ([ls1 (let f ([n 10000]) (if (fx= n 0) @@ -3789,6 +3791,510 @@ (test-hash 100000)) ) +(mat generic-hashtable-arguments + (error? ; wrong argument count + (make-weak-hashtable)) + (error? ; wrong argument count + (make-weak-hashtable equal-hash)) + (error? ; wrong argument count + (make-weak-hashtable equal-hash equal? 45 53)) + (error? ; not a procedure + (make-weak-hashtable 'a equal? 45)) + (error? ; not a procedure + (make-weak-hashtable equal-hash 'a 45)) + (error? ; invalid size + (make-weak-hashtable equal-hash equal? 'a)) + (error? ; invalid size + (make-weak-hashtable equal-hash equal? -45)) + (error? ; invalid size + (make-weak-hashtable equal-hash equal? 45.0)) + (error? ; wrong argument count + (make-ephemeron-hashtable)) + (error? ; wrong argument count + (make-ephemeron-hashtable equal-hash)) + (error? ; wrong argument count + (make-ephemeron-hashtable equal-hash equal? 45 53)) + (error? ; not a procedure + (make-ephemeron-hashtable 'a equal? 45)) + (error? ; not a procedure + (make-ephemeron-hashtable equal-hash 'a 45)) + (error? ; invalid size + (make-ephemeron-hashtable equal-hash equal? 'a)) + (error? ; invalid size + (make-ephemeron-hashtable equal-hash equal? -45)) + (error? ; invalid size + (make-ephemeron-hashtable equal-hash equal? 45.0))) + +(mat weak-equal-hashtable + (begin + (define ka (list 'a)) + (define kb (list 'b)) + (define kc (list 'c)) + (define kq (list 'q)) + (define ky (list 'y)) + (define kz (list 'z)) + (define km -5.75) + (define kn 17) + (define ko (+ (most-positive-fixnum) 5)) + #t) + (begin + (define h (make-weak-hashtable equal-hash equal? 32)) + (and (hashtable? h) + (not (eq-hashtable? h)) + (hashtable-mutable? h) + (hashtable-weak? h))) + (eq? (hashtable-hash-function h) equal-hash) + (eq? (hashtable-equivalence-function h) equal?) + (equal? (hashtable-size h) 0) + (same-elements? (hashtable-keys h) '#()) + (same-elements? (hashtable-values h) '#()) + (equal-entries? h '#() '#()) + (same-elements? (hashtable-cells h) '#()) + (same-elements? (hashtable-cells h 0) '#()) + (same-elements? (hashtable-cells h 10) '#()) + (eqv? (hashtable-set! h ka 'aval) (void)) + (equal? + (list + (hashtable-contains? h ka) + (hashtable-contains? h kb) + (hashtable-contains? h kc) + (hashtable-contains? h km) + (hashtable-contains? h kn) + (hashtable-contains? h ko)) + '(#t #f #f #f #f #f)) + (eqv? (hashtable-set! h kb 'bval) (void)) + (equal? + (list + (hashtable-contains? h ka) + (hashtable-contains? h kb) + (hashtable-contains? h kc) + (hashtable-contains? h km) + (hashtable-contains? h kn) + (hashtable-contains? h ko)) + '(#t #t #f #f #f #f)) + (eqv? (hashtable-set! h kc 'cval) (void)) + (equal? + (list + (hashtable-contains? h ka) + (hashtable-contains? h kb) + (hashtable-contains? h kc) + (hashtable-contains? h km) + (hashtable-contains? h kn) + (hashtable-contains? h ko)) + '(#t #t #t #f #f #f)) + (eqv? (hashtable-set! h km 'mval) (void)) + (equal? + (list + (hashtable-contains? h ka) + (hashtable-contains? h kb) + (hashtable-contains? h kc) + (hashtable-contains? h km) + (hashtable-contains? h kn) + (hashtable-contains? h ko)) + '(#t #t #t #t #f #f)) + (eqv? (hashtable-set! h kn 'nval) (void)) + (equal? + (list + (hashtable-contains? h ka) + (hashtable-contains? h kb) + (hashtable-contains? h kc) + (hashtable-contains? h km) + (hashtable-contains? h kn) + (hashtable-contains? h ko)) + '(#t #t #t #t #t #f)) + (eqv? (hashtable-set! h ko 'oval) (void)) + (equal? + (list + (hashtable-contains? h ka) + (hashtable-contains? h kb) + (hashtable-contains? h kc) + (hashtable-contains? h km) + (hashtable-contains? h kn) + (hashtable-contains? h ko)) + '(#t #t #t #t #t #t)) + (equal? (hashtable-size h) 6) + (equal-entries? h `#((a) (b) (c) -5.75 17 ,ko) '#(aval bval cval mval nval oval)) + #;(same-elements? + (list->vector (hashtable-map h cons)) + `#(((a) . aval) ((b) . bval) ((c) . cval) (-5.75 . mval) (17 . nval) (,ko . oval))) + #;(same-elements? + (let ([v (make-vector 6)] [i 0]) + (hashtable-for-each h (lambda (key val) (vector-set! v i (cons key val)) (set! i (fx+ i 1)))) + v) + `#(((a) . aval) ((b) . bval) ((c) . cval) (-5.75 . mval) (17 . nval) (,ko . oval))) + #;(same-elements? + (let ([v (make-vector 6)] [i 0]) + (hashtable-for-each-cell h (lambda (a) (vector-set! v i a) (set! i (fx+ i 1)))) + v) + `#(((a) . aval) ((b) . bval) ((c) . cval) (-5.75 . mval) (17 . nval) (,ko . oval))) + (eq? (hashtable-ref h ka 1) 'aval) + (eq? (hashtable-ref h kb #f) 'bval) + (eq? (hashtable-ref h kc 'nope) 'cval) + (eq? (hashtable-ref h (+ 2 -7.75) 'ugh) 'mval) + (eq? (hashtable-ref h (/ 34 2) 'ugh) 'nval) + (eq? (hashtable-ref h (+ (most-positive-fixnum) 7 -2) 'ugh) 'oval) + (eqv? (hashtable-delete! h kb) (void)) + (equal? (hashtable-size h) 5) + (equal-entries? h `#((a) (c) -5.75 17 ,ko) '#(aval cval mval nval oval)) + (begin + (define h2 (hashtable-copy h #t)) + (and (hashtable? h2) + (hashtable-mutable? h2) + (hashtable-weak? h2))) + (eq? (hashtable-hash-function h2) equal-hash) + (eq? (hashtable-equivalence-function h2) equal?) + (equal? (hashtable-size h2) 5) + (equal-entries? h `#((a) (c) -5.75 17 ,ko) '#(aval cval mval nval oval)) + (eqv? (hashtable-clear! h 4) (void)) + (equal? + (list + (hashtable-size h) + (hashtable-ref h ka 1) + (hashtable-ref h kb #f) + (hashtable-ref h kc 'nope) + (hashtable-ref h km 'nope) + (hashtable-ref h kn 'nope) + (hashtable-ref h ko 'nope)) + '(0 1 #f nope nope nope nope)) + (equal-entries? h '#() '#()) + (equal? + (list + (hashtable-size h2) + (hashtable-ref h2 ka 1) + (hashtable-ref h2 kb #f) + (hashtable-ref h2 kc 'nope) + (hashtable-ref h2 (- (+ km 1) 1) 'nope) + (hashtable-ref h2 (- (+ kn 1) 1) 'nope) + (hashtable-ref h2 (- (+ ko 1) 1) 'nope)) + '(5 aval #f cval mval nval oval)) + (equal-entries? h2 `#((a) (c) -5.75 17 ,ko) '#(aval cval mval nval oval)) + (eqv? + (hashtable-update! h kq + (lambda (x) (+ x 1)) + 17) + (void)) + (equal? (hashtable-ref h kq #f) 18) + (eqv? + (hashtable-update! h kq + (lambda (x) (+ x 1)) + 17) + (void)) + (equal? (hashtable-ref h kq #f) 19) + (equal? (hashtable-size h) 1) + (equal-entries? h '#((q)) '#(19)) + (eqv? + (begin + (set! kq (void)) + (collect (collect-maximum-generation)) + (hashtable-size h)) + 0) + (equal-entries? h '#() '#()) + (equal? (hashtable-ref h ky #f) #f) + (eqv? + (hashtable-set! h ky 'toad) + (void)) + (equal? (hashtable-ref h ky #f) 'toad) + (equal? (hashtable-ref h kz #f) #f) + (eqv? + (hashtable-update! h kz list 'frog) + (void)) + (equal? (hashtable-ref h kz #f) '(frog)) + (equal-entries? + h + (vector kz ky) + (vector (hashtable-ref h kz #f) 'toad)) + (eqv? (hashtable-ref h '(zippo) 'nil) 'nil) + (begin + (define h3 (hashtable-copy h2 #f)) + (and (hashtable? h3) + (not (hashtable-mutable? h3)) + (hashtable-weak? h3))) + (equal-entries? h2 `#((a) (c) -5.75 17 ,ko) '#(aval cval mval nval oval)) + (equal-entries? h3 `#((a) (c) -5.75 17 ,ko) '#(aval cval mval nval oval)) + (equal? + (begin + (set! ka (void)) + (set! km (void)) + (set! kn (void)) + (set! ko (void)) + (collect (collect-maximum-generation)) + (list (hashtable-size h2) (hashtable-size h3))) + '(2 2)) + (equal-entries? h2 `#((c) 17) '#(cval nval)) + (equal-entries? h3 `#((c) 17) '#(cval nval)) + (eqv? + (begin + (set! h3 (void)) + (collect (collect-maximum-generation)) + (hashtable-size h2)) + 2) + (equal-entries? h2 `#((c) 17) '#(cval nval)) + + ; test for proper shrinkage + (equal? + (let ([ht (make-weak-hashtable equal-hash equal? 32)]) + (for-each + (lambda (k*) (for-each (lambda (k) (hashtable-delete! ht k)) k*)) + (let ([k** (map (lambda (x) (map list (make-list 1000))) + (make-list 100))]) + (for-each + (lambda (k*) (map (lambda (k) (hashtable-set! ht k 75)) k*)) + k**) + k**)) + (call-with-values (lambda () (#%$hashtable-veclen ht)) cons)) + '(32 . 32)) + + ; test for proper shrinkage as objects are bwp'd + ; uses delete to trigger final shrinkage + (equal? + (let ([ht (make-weak-hashtable equal-hash equal? 32)]) + (hashtable-set! ht 'a 'b) + (for-each + (lambda (k*) (map (lambda (k) (hashtable-set! ht k 75)) k*)) + (map (lambda (x) (map list (make-list 1000))) (make-list 100))) + (collect (collect-maximum-generation)) + (hashtable-delete! ht 'a) + (list (hashtable-size ht) + (let-values ([(n1 n2) (#%$hashtable-veclen ht)]) + (= n1 n2 32)))) + '(0 #t)) + ) + +(mat ephemeron-equal-hashtable + (begin + (define ka (list 'a)) + (define kb (list 'b)) + (define kc (list 'c)) + (define kq (list 'q)) + (define ky (list 'y)) + (define kz (list 'z)) + (define km -5.75) + (define kn 17) + (define ko (+ (most-positive-fixnum) 5)) + #t) + (begin + (define h (make-ephemeron-hashtable equal-hash equal? 32)) + (and (hashtable? h) + (not (eq-hashtable? h)) + (hashtable-mutable? h) + (hashtable-ephemeron? h))) + (eq? (hashtable-hash-function h) equal-hash) + (eq? (hashtable-equivalence-function h) equal?) + (equal? (hashtable-size h) 0) + (same-elements? (hashtable-keys h) '#()) + (same-elements? (hashtable-values h) '#()) + (equal-entries? h '#() '#()) + (same-elements? (hashtable-cells h) '#()) + (same-elements? (hashtable-cells h 0) '#()) + (same-elements? (hashtable-cells h 10) '#()) + (eqv? (hashtable-set! h ka 'aval) (void)) + (equal? + (list + (hashtable-contains? h ka) + (hashtable-contains? h kb) + (hashtable-contains? h kc) + (hashtable-contains? h km) + (hashtable-contains? h kn) + (hashtable-contains? h ko)) + '(#t #f #f #f #f #f)) + (eqv? (hashtable-set! h kb 'bval) (void)) + (equal? + (list + (hashtable-contains? h ka) + (hashtable-contains? h kb) + (hashtable-contains? h kc) + (hashtable-contains? h km) + (hashtable-contains? h kn) + (hashtable-contains? h ko)) + '(#t #t #f #f #f #f)) + (eqv? (hashtable-set! h kc 'cval) (void)) + (equal? + (list + (hashtable-contains? h ka) + (hashtable-contains? h kb) + (hashtable-contains? h kc) + (hashtable-contains? h km) + (hashtable-contains? h kn) + (hashtable-contains? h ko)) + '(#t #t #t #f #f #f)) + (eqv? (hashtable-set! h km 'mval) (void)) + (equal? + (list + (hashtable-contains? h ka) + (hashtable-contains? h kb) + (hashtable-contains? h kc) + (hashtable-contains? h km) + (hashtable-contains? h kn) + (hashtable-contains? h ko)) + '(#t #t #t #t #f #f)) + (eqv? (hashtable-set! h kn 'nval) (void)) + (equal? + (list + (hashtable-contains? h ka) + (hashtable-contains? h kb) + (hashtable-contains? h kc) + (hashtable-contains? h km) + (hashtable-contains? h kn) + (hashtable-contains? h ko)) + '(#t #t #t #t #t #f)) + (eqv? (hashtable-set! h ko 'oval) (void)) + (equal? + (list + (hashtable-contains? h ka) + (hashtable-contains? h kb) + (hashtable-contains? h kc) + (hashtable-contains? h km) + (hashtable-contains? h kn) + (hashtable-contains? h ko)) + '(#t #t #t #t #t #t)) + (equal? (hashtable-size h) 6) + (equal-entries? h `#((a) (b) (c) -5.75 17 ,ko) '#(aval bval cval mval nval oval)) + #;(same-elements? + (list->vector (hashtable-map h cons)) + `#(((a) . aval) ((b) . bval) ((c) . cval) (-5.75 . mval) (17 . nval) (,ko . oval))) + #;(same-elements? + (let ([v (make-vector 6)] [i 0]) + (hashtable-for-each h (lambda (key val) (vector-set! v i (cons key val)) (set! i (fx+ i 1)))) + v) + `#(((a) . aval) ((b) . bval) ((c) . cval) (-5.75 . mval) (17 . nval) (,ko . oval))) + #;(same-elements? + (let ([v (make-vector 6)] [i 0]) + (hashtable-for-each-cell h (lambda (a) (vector-set! v i a) (set! i (fx+ i 1)))) + v) + `#(((a) . aval) ((b) . bval) ((c) . cval) (-5.75 . mval) (17 . nval) (,ko . oval))) + (eq? (hashtable-ref h ka 1) 'aval) + (eq? (hashtable-ref h kb #f) 'bval) + (eq? (hashtable-ref h kc 'nope) 'cval) + (eq? (hashtable-ref h (+ 2 -7.75) 'ugh) 'mval) + (eq? (hashtable-ref h (/ 34 2) 'ugh) 'nval) + (eq? (hashtable-ref h (+ (most-positive-fixnum) 7 -2) 'ugh) 'oval) + (eqv? (hashtable-delete! h kb) (void)) + (equal? (hashtable-size h) 5) + (equal-entries? h `#((a) (c) -5.75 17 ,ko) '#(aval cval mval nval oval)) + (begin + (define h2 (hashtable-copy h #t)) + (and (hashtable? h2) + (hashtable-mutable? h2) + (hashtable-ephemeron? h2))) + (eq? (hashtable-hash-function h2) equal-hash) + (eq? (hashtable-equivalence-function h2) equal?) + (equal? (hashtable-size h2) 5) + (equal-entries? h `#((a) (c) -5.75 17 ,ko) '#(aval cval mval nval oval)) + (eqv? (hashtable-clear! h 4) (void)) + (equal? + (list + (hashtable-size h) + (hashtable-ref h ka 1) + (hashtable-ref h kb #f) + (hashtable-ref h kc 'nope) + (hashtable-ref h km 'nope) + (hashtable-ref h kn 'nope) + (hashtable-ref h ko 'nope)) + '(0 1 #f nope nope nope nope)) + (equal-entries? h '#() '#()) + (equal? + (list + (hashtable-size h2) + (hashtable-ref h2 ka 1) + (hashtable-ref h2 kb #f) + (hashtable-ref h2 kc 'nope) + (hashtable-ref h2 (- (+ km 1) 1) 'nope) + (hashtable-ref h2 (- (+ kn 1) 1) 'nope) + (hashtable-ref h2 (- (+ ko 1) 1) 'nope)) + '(5 aval #f cval mval nval oval)) + (equal-entries? h2 `#((a) (c) -5.75 17 ,ko) '#(aval cval mval nval oval)) + (eqv? + (hashtable-update! h kq + (lambda (x) (+ x 1)) + 17) + (void)) + (equal? (hashtable-ref h kq #f) 18) + (eqv? + (hashtable-update! h kq + (lambda (x) (+ x 1)) + 17) + (void)) + (equal? (hashtable-ref h kq #f) 19) + (equal? (hashtable-size h) 1) + (equal-entries? h '#((q)) '#(19)) + (eqv? + (begin + (set! kq (void)) + (collect (collect-maximum-generation)) + (hashtable-size h)) + 0) + (equal-entries? h '#() '#()) + (equal? (hashtable-ref h ky #f) #f) + (eqv? + (hashtable-set! h ky 'toad) + (void)) + (equal? (hashtable-ref h ky #f) 'toad) + (equal? (hashtable-ref h kz #f) #f) + (eqv? + (hashtable-update! h kz list 'frog) + (void)) + (equal? (hashtable-ref h kz #f) '(frog)) + (equal-entries? + h + (vector kz ky) + (vector (hashtable-ref h kz #f) 'toad)) + (eqv? (hashtable-ref h '(zippo) 'nil) 'nil) + (begin + (define h3 (hashtable-copy h2 #f)) + (and (hashtable? h3) + (not (hashtable-mutable? h3)) + (hashtable-ephemeron? h3))) + (equal-entries? h2 `#((a) (c) -5.75 17 ,ko) '#(aval cval mval nval oval)) + (equal-entries? h3 `#((a) (c) -5.75 17 ,ko) '#(aval cval mval nval oval)) + (equal? + (begin + (set! ka (void)) + (set! km (void)) + (set! kn (void)) + (set! ko (void)) + (collect (collect-maximum-generation)) + (list (hashtable-size h2) (hashtable-size h3))) + '(2 2)) + (equal-entries? h2 `#((c) 17) '#(cval nval)) + (equal-entries? h3 `#((c) 17) '#(cval nval)) + (eqv? + (begin + (set! h3 (void)) + (collect (collect-maximum-generation)) + (hashtable-size h2)) + 2) + (equal-entries? h2 `#((c) 17) '#(cval nval)) + + ; test for proper shrinkage + (equal? + (let ([ht (make-ephemeron-hashtable equal-hash equal? 32)]) + (for-each + (lambda (k*) (for-each (lambda (k) (hashtable-delete! ht k)) k*)) + (let ([k** (map (lambda (x) (map list (make-list 1000))) + (make-list 100))]) + (for-each + (lambda (k*) (map (lambda (k) (hashtable-set! ht k 75)) k*)) + k**) + k**)) + (call-with-values (lambda () (#%$hashtable-veclen ht)) cons)) + '(32 . 32)) + + ; test for proper shrinkage as objects are bwp'd + ; uses delete to trigger final shrinkage + (equal? + (let ([ht (make-ephemeron-hashtable equal-hash equal? 32)]) + (hashtable-set! ht 'a 'b) + (for-each + (lambda (k*) (map (lambda (k) (hashtable-set! ht k 75)) k*)) + (map (lambda (x) (map list (make-list 1000))) (make-list 100))) + (collect (collect-maximum-generation)) + (hashtable-delete! ht 'a) + (list (hashtable-size ht) + (let-values ([(n1 n2) (#%$hashtable-veclen ht)]) + (= n1 n2 32)))) + '(0 #t)) +) + (mat hash-functions ; equal-hash (error? ; wrong argument count diff --git a/src/ChezScheme/mats/misc.ms b/src/ChezScheme/mats/misc.ms index b18754e9a0..3c88348f38 100644 --- a/src/ChezScheme/mats/misc.ms +++ b/src/ChezScheme/mats/misc.ms @@ -1108,49 +1108,49 @@ (let loop () (unless (check) (sleep (make-time 'time-duration 10000 0)) - (loop))))] - [th (fork-thread - (lambda () - (let ([bstr (make-bytevector N)]) - (box-cas! ready #f 'go) - ;; Block so that thread becomes deactivated - (mutex-acquire m) - (mutex-release m) - ;; bstr is retained in the thread's continuation until here - (set-box! saved (bytevector-u8-ref bstr 0)) - (pause-until (lambda () (box-cas! ready 'finish 'done))) - ;; Block so that thread becomes deactivated, again - (mutex-acquire m) - (mutex-release m))))]) + (loop))))]) (mutex-acquire m) - ;; Wait for thread to start - (pause-until (lambda () (eq? 'go (unbox ready)))) - ;; Wait for thread to become inactive, blocked on the mutex - (pause-until (lambda () (= 1 (#%$top-level-value '$active-threads)))) - ;; Get thread's size, which should include bstr - (let ([pre-sizes (compute-size-increments (list th))]) - (mutex-release m) - ;; Wait for bytevector to be discarded in the thread - (pause-until (lambda () (unbox saved))) - (mutex-acquire m) - (set-box! ready 'finish) - ;; Wait for thread to become inactive again + (let ([th (fork-thread + (lambda () + (let ([bstr (make-bytevector N)]) + (box-cas! ready #f 'go) + ;; Block so that thread becomes deactivated + (mutex-acquire m) + (mutex-release m) + ;; bstr is retained in the thread's continuation until here + (set-box! saved (bytevector-u8-ref bstr 0)) + (pause-until (lambda () (box-cas! ready 'finish 'done))) + ;; Block so that thread becomes deactivated, again + (mutex-acquire m) + (mutex-release m))))]) + ;; Wait for thread to start + (pause-until (lambda () (eq? 'go (unbox ready)))) + ;; Wait for thread to become inactive, blocked on the mutex (pause-until (lambda () (= 1 (#%$top-level-value '$active-threads)))) - ;; Get thread's size, which should'nt include bstr - (let ([post-sizes (compute-size-increments (list th))]) + ;; Get thread's size, which should include bstr + (let ([pre-sizes (compute-size-increments (list th))]) (mutex-release m) - ;; Wait for thread to exit - (let () - (define $threads (foreign-procedure "(cs)threads" () scheme-object)) - (pause-until (lambda () (= 1 (length ($threads)))))) - ;; Make sure `compute-size-increments` doesn't crash on a - ;; terminated thread: - (compute-size-increments (list th)) - ;; Main result: detected size of `bstr` in the thread - ;; while it was part of the continuation - (or (eq? (current-eval) interpret) ; interpreter continuaton is not precise enough - (and (> (car pre-sizes) N) - (< (car post-sizes) N))))))) + ;; Wait for bytevector to be discarded in the thread + (pause-until (lambda () (unbox saved))) + (mutex-acquire m) + (set-box! ready 'finish) + ;; Wait for thread to become inactive again + (pause-until (lambda () (= 1 (#%$top-level-value '$active-threads)))) + ;; Get thread's size, which shouldn't include bstr + (let ([post-sizes (compute-size-increments (list th))]) + (mutex-release m) + ;; Wait for thread to exit + (let () + (define $threads (foreign-procedure "(cs)threads" () scheme-object)) + (pause-until (lambda () (= 1 (length ($threads)))))) + ;; Make sure `compute-size-increments` doesn't crash on a + ;; terminated thread: + (compute-size-increments (list th)) + ;; Main result: detected size of `bstr` in the thread + ;; while it was part of the continuation + (or (eq? (current-eval) interpret) ; interpreter continuation is not precise enough + (and (> (car pre-sizes) N) + (< (car post-sizes) N)))))))) ) (mat collect+compute-size-increments @@ -2011,10 +2011,9 @@ (vector 1 'two "three") (stencil-vector 30 'one 2.0 0+3i "four") (box 88) - "" '#() '#vu8() (make-fxvector 0) + "" '#() '#vu8() (make-fxvector 0) (make-flvector 0) (string->immutable-string "") (vector->immutable-vector '#()) - (bytevector->immutable-bytevector '#vu8()) - (fxvector->immutable-fxvector (make-fxvector 0)))) + (bytevector->immutable-bytevector '#vu8()))) (define (same-vfasl-content? v) (andmap (lambda (a b) (or (eqv? a b) @@ -4698,7 +4697,7 @@ (#2%display 1)))) ) -(unless (memq (machine-type) '(arm32le tarm32le arm64le tarm64le ; timestamp counter tends to be priviledged on Arm +(unless (memq (machine-type) '(arm32le tarm32le arm64le tarm64le arm64osx tarm64osx ; timestamp counter tends to be priviledged on Arm pb)) ; doesn't increment for pb (mat $read-time-stamp-counter @@ -4926,21 +4925,22 @@ (mat fasl-immutable (begin (define immutable-objs (list (vector->immutable-vector '#(1 2 3)) - (fxvector->immutable-fxvector '#vfx(1 2 3)) (string->immutable-string "abc") (bytevector->immutable-bytevector #vu8(1 2 3)) - (box-immutable 1))) + (box-immutable 1) + ;; Not immutable, but we want to test strip: + (fxvector 1 2 3) + (flvector 1.5 2.5 3.5) + (stencil-vector 6 'a 'b))) (define immutable-zero-objs (list (vector->immutable-vector '#()) - (fxvector->immutable-fxvector '#vfx()) (string->immutable-string "") (bytevector->immutable-bytevector #vu8()) (box-immutable 1))) (define (immutable? l) (and (immutable-vector? (list-ref l 0)) - (immutable-fxvector? (list-ref l 1)) - (immutable-string? (list-ref l 2)) - (immutable-bytevector? (list-ref l 3)) - (immutable-box? (list-ref l 4)))) + (immutable-string? (list-ref l 1)) + (immutable-bytevector? (list-ref l 2)) + (immutable-box? (list-ref l 3)))) (define (round-trip l) (let-values ([(o get) (open-bytevector-output-port)]) (fasl-write l o) @@ -4976,7 +4976,6 @@ ;; Make sure `fasl-read` didn't mark "mutable" null values ;; as immutable: (mutable-vector? '#()) - (mutable-fxvector? '#vfx()) (mutable-string? "") (mutable-bytevector? '#vu8()) diff --git a/src/ChezScheme/mats/patch-compile-0-f-t-f b/src/ChezScheme/mats/patch-compile-0-f-t-f index a82bd035c9..d1b2d42d2e 100644 --- a/src/ChezScheme/mats/patch-compile-0-f-t-f +++ b/src/ChezScheme/mats/patch-compile-0-f-t-f @@ -1,7 +1,7 @@ -*** errors-compile-0-f-f-f 2020-06-03 12:04:45.000000000 -0600 ---- errors-compile-0-f-t-f 2020-06-03 11:23:43.000000000 -0600 +*** errors-compile-0-f-f-f 2020-11-23 06:11:33.000000000 -0700 +--- errors-compile-0-f-t-f 2020-11-23 05:33:39.000000000 -0700 *************** -*** 198,204 **** +*** 200,206 **** 3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable a". 3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable c". 3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable m". @@ -9,7 +9,7 @@ 3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable y". 3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable a". 3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable a". ---- 198,204 ---- +--- 200,206 ---- 3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable a". 3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable c". 3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable m". @@ -18,7 +18,7 @@ 3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable a". 3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable a". *************** -*** 217,223 **** +*** 219,225 **** 3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable b". 3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable a". 3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable g". @@ -26,7 +26,7 @@ 3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable f". 3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable c". 3.mo:Expected warning in mat cpvalid: "possible attempt to reference undefined variable x". ---- 217,223 ---- +--- 219,225 ---- 3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable b". 3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable a". 3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable g". @@ -35,30 +35,30 @@ 3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable c". 3.mo:Expected warning in mat cpvalid: "possible attempt to reference undefined variable x". *************** -*** 264,273 **** - 3.mo:Expected error in mat mrvs: "returned three values to single value return context". - 3.mo:Expected error in mat mrvs: "returned three values to single value return context". - 3.mo:Expected error in mat mrvs: "returned zero values to single value return context". +*** 266,275 **** + 3.mo:Expected error in mat mrvs: "returned 3 values to single value return context". + 3.mo:Expected error in mat mrvs: "returned 3 values to single value return context". + 3.mo:Expected error in mat mrvs: "returned 0 values to single value return context". ! 3.mo:Expected error in mat mrvs: "incorrect number of values received in multiple value context". -! 3.mo:Expected error in mat mrvs: "returned zero values to single value return context". +! 3.mo:Expected error in mat mrvs: "returned 0 values to single value return context". ! 3.mo:Expected error in mat mrvs: "incorrect number of values received in multiple value context". ! 3.mo:Expected error in mat mrvs: "incorrect number of values received in multiple value context". 3.mo:Expected error in mat mrvs: "variable $mrvs-foo is not bound". 3.mo:Expected error in mat mrvs: "attempt to apply non-procedure 17". - 3.mo:Expected error in mat mrvs: "returned two values to single value return context". ---- 264,273 ---- - 3.mo:Expected error in mat mrvs: "returned three values to single value return context". - 3.mo:Expected error in mat mrvs: "returned three values to single value return context". - 3.mo:Expected error in mat mrvs: "returned zero values to single value return context". + 3.mo:Expected error in mat mrvs: "returned 2 values to single value return context". +--- 266,275 ---- + 3.mo:Expected error in mat mrvs: "returned 3 values to single value return context". + 3.mo:Expected error in mat mrvs: "returned 3 values to single value return context". + 3.mo:Expected error in mat mrvs: "returned 0 values to single value return context". ! 3.mo:Expected error in mat mrvs: "incorrect argument count in call (call-with-values (lambda () 5 (values 2)) (lambda (x y) (+ x y)))". ! 3.mo:Expected error in mat mrvs: "incorrect argument count in call (call-with-values values (lambda (x) x))". ! 3.mo:Expected error in mat mrvs: "incorrect argument count in call (call-with-values values (lambda (x y) x))". ! 3.mo:Expected error in mat mrvs: "incorrect argument count in call (call-with-values f (lambda (x y) x))". 3.mo:Expected error in mat mrvs: "variable $mrvs-foo is not bound". 3.mo:Expected error in mat mrvs: "attempt to apply non-procedure 17". - 3.mo:Expected error in mat mrvs: "returned two values to single value return context". + 3.mo:Expected error in mat mrvs: "returned 2 values to single value return context". *************** -*** 4034,4040 **** +*** 4037,4043 **** misc.mo:Expected error in mat cpletrec: "foreign-procedure: no entry for "foo"". misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable q". misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable bar". @@ -66,7 +66,7 @@ misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable b". misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable b". misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable a". ---- 4034,4040 ---- +--- 4037,4043 ---- misc.mo:Expected error in mat cpletrec: "foreign-procedure: no entry for "foo"". misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable q". misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable bar". @@ -75,7 +75,7 @@ misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable b". misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable a". *************** -*** 7612,7619 **** +*** 7666,7673 **** 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu". 7.mo:Expected error in mat error: "a: hit me!". 7.mo:Expected error in mat error: "f: n is 0". @@ -84,7 +84,7 @@ record.mo:Expected error in mat record2: "invalid value 3 for foreign type double-float". record.mo:Expected error in mat record2: "3 is not of type #<record type fudge>". record.mo:Expected error in mat record2: "make-record-type: invalid field list ((immutable double-float a) . b)". ---- 7612,7619 ---- +--- 7666,7673 ---- 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu". 7.mo:Expected error in mat error: "a: hit me!". 7.mo:Expected error in mat error: "f: n is 0". @@ -94,7 +94,7 @@ record.mo:Expected error in mat record2: "3 is not of type #<record type fudge>". record.mo:Expected error in mat record2: "make-record-type: invalid field list ((immutable double-float a) . b)". *************** -*** 7621,7635 **** +*** 7675,7689 **** record.mo:Expected error in mat type-descriptor: "invalid syntax (type-descriptor 3)". record.mo:Expected error in mat type-descriptor: "type-descriptor: unrecognized record car". record.mo:Expected error in mat record3: "variable set-fudge-a! is not bound". @@ -110,7 +110,7 @@ record.mo:Expected error in mat record9: "record-reader: invalid input #f". record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge". record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge". ---- 7621,7635 ---- +--- 7675,7689 ---- record.mo:Expected error in mat type-descriptor: "invalid syntax (type-descriptor 3)". record.mo:Expected error in mat type-descriptor: "type-descriptor: unrecognized record car". record.mo:Expected error in mat record3: "variable set-fudge-a! is not bound". @@ -127,7 +127,7 @@ record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge". record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge". *************** -*** 7642,7667 **** +*** 7696,7721 **** record.mo:Expected error in mat record10: "read: unresolvable cycle constructing record of type #<record type bar> at char 3 of #<input port string>". record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>". record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>". @@ -154,7 +154,7 @@ record.mo:Expected error in mat foreign-data: "foreign-alloc: 0 is not a positive fixnum". record.mo:Expected error in mat foreign-data: "foreign-alloc: <int> is not a positive fixnum". record.mo:Expected error in mat foreign-data: "foreign-alloc: -5 is not a positive fixnum". ---- 7642,7667 ---- +--- 7696,7721 ---- record.mo:Expected error in mat record10: "read: unresolvable cycle constructing record of type #<record type bar> at char 3 of #<input port string>". record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>". record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>". @@ -182,7 +182,7 @@ record.mo:Expected error in mat foreign-data: "foreign-alloc: <int> is not a positive fixnum". record.mo:Expected error in mat foreign-data: "foreign-alloc: -5 is not a positive fixnum". *************** -*** 7792,7830 **** +*** 7846,7884 **** record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)". record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)". record.mo:Expected error in mat record23: "make-record-type: cannot extend sealed record type #<record type foo>". @@ -222,7 +222,7 @@ record.mo:Expected error in mat record?: "record?: 4 is not a record type descriptor". record.mo:Expected error in mat record?: "record?: a is not a record type descriptor". record.mo:Expected error in mat record?: "record?: #(1) is not a record type descriptor". ---- 7792,7830 ---- +--- 7846,7884 ---- record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)". record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)". record.mo:Expected error in mat record23: "make-record-type: cannot extend sealed record type #<record type foo>". @@ -263,7 +263,7 @@ record.mo:Expected error in mat record?: "record?: a is not a record type descriptor". record.mo:Expected error in mat record?: "record?: #(1) is not a record type descriptor". *************** -*** 7839,7895 **** +*** 7893,7949 **** record.mo:Expected error in mat r6rs-records-procedural: "make-record-constructor-descriptor: invalid protocol flimflam". record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure not-a-procedure". record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure spam". @@ -321,7 +321,7 @@ record.mo:Expected error in mat r6rs-records-syntactic: "define-record-type: incompatible record type cpoint - different parent". record.mo:Expected error in mat r6rs-records-syntactic: "define-record-type: incompatible record type cpoint - different parent". record.mo:Expected error in mat r6rs-records-syntactic: "cannot extend define-record-type parent fratrat". ---- 7839,7895 ---- +--- 7893,7949 ---- record.mo:Expected error in mat r6rs-records-procedural: "make-record-constructor-descriptor: invalid protocol flimflam". record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure not-a-procedure". record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure spam". diff --git a/src/ChezScheme/mats/patch-compile-0-t-f-f b/src/ChezScheme/mats/patch-compile-0-t-f-f index adef5d4399..4a1b92c34b 100644 --- a/src/ChezScheme/mats/patch-compile-0-t-f-f +++ b/src/ChezScheme/mats/patch-compile-0-t-f-f @@ -1,5 +1,5 @@ -*** errors-compile-0-f-f-f 2020-08-04 20:40:20.000000000 -0600 ---- errors-compile-0-t-f-f 2020-08-04 20:09:15.000000000 -0600 +*** errors-compile-0-f-f-f 2020-11-23 06:11:33.000000000 -0700 +--- errors-compile-0-t-f-f 2020-11-23 05:42:16.000000000 -0700 *************** *** 168,174 **** 3.mo:Expected error in mat case-lambda: "incorrect number of arguments 2 to #<procedure foo>". @@ -19,30 +19,30 @@ 3.mo:Expected error in mat letrec: "attempt to assign undefined variable b". *************** *** 266,277 **** - 3.mo:Expected error in mat mrvs: "returned three values to single value return context". - 3.mo:Expected error in mat mrvs: "returned three values to single value return context". - 3.mo:Expected error in mat mrvs: "returned zero values to single value return context". + 3.mo:Expected error in mat mrvs: "returned 3 values to single value return context". + 3.mo:Expected error in mat mrvs: "returned 3 values to single value return context". + 3.mo:Expected error in mat mrvs: "returned 0 values to single value return context". ! 3.mo:Expected error in mat mrvs: "incorrect number of values received in multiple value context". -! 3.mo:Expected error in mat mrvs: "returned zero values to single value return context". +! 3.mo:Expected error in mat mrvs: "returned 0 values to single value return context". ! 3.mo:Expected error in mat mrvs: "incorrect number of values received in multiple value context". ! 3.mo:Expected error in mat mrvs: "incorrect number of values received in multiple value context". 3.mo:Expected error in mat mrvs: "variable $mrvs-foo is not bound". ! 3.mo:Expected error in mat mrvs: "attempt to apply non-procedure 17". - 3.mo:Expected error in mat mrvs: "returned two values to single value return context". - 3.mo:Expected error in mat mrvs: "returned two values to single value return context". + 3.mo:Expected error in mat mrvs: "returned 2 values to single value return context". + 3.mo:Expected error in mat mrvs: "returned 2 values to single value return context". 3.mo:Expected error in mat mrvs: "cdr: a is not a pair". --- 266,277 ---- - 3.mo:Expected error in mat mrvs: "returned three values to single value return context". - 3.mo:Expected error in mat mrvs: "returned three values to single value return context". - 3.mo:Expected error in mat mrvs: "returned zero values to single value return context". + 3.mo:Expected error in mat mrvs: "returned 3 values to single value return context". + 3.mo:Expected error in mat mrvs: "returned 3 values to single value return context". + 3.mo:Expected error in mat mrvs: "returned 0 values to single value return context". ! 3.mo:Expected error in mat mrvs: "incorrect number of arguments 1 to #<procedure>". ! 3.mo:Expected error in mat mrvs: "incorrect number of arguments 0 to #<procedure>". ! 3.mo:Expected error in mat mrvs: "incorrect number of arguments 0 to #<procedure>". ! 3.mo:Expected error in mat mrvs: "incorrect number of arguments 0 to #<procedure>". 3.mo:Expected error in mat mrvs: "variable $mrvs-foo is not bound". ! 3.mo:Expected error in mat mrvs: "call-with-values: 17 is not a procedure". - 3.mo:Expected error in mat mrvs: "returned two values to single value return context". - 3.mo:Expected error in mat mrvs: "returned two values to single value return context". + 3.mo:Expected error in mat mrvs: "returned 2 values to single value return context". + 3.mo:Expected error in mat mrvs: "returned 2 values to single value return context". 3.mo:Expected error in mat mrvs: "cdr: a is not a pair". *************** *** 308,315 **** @@ -3861,7 +3861,7 @@ misc.mo:Expected error in mat compiler3: "incorrect argument count in call (consumer 1 2)". misc.mo:Expected error in mat compiler3: "variable goto is not bound". *************** -*** 4059,4065 **** +*** 4060,4066 **** misc.mo:Expected error in mat $fasl-file-equal?: "$fasl-file-equal?: failed for probably-does-not-exist: no such file or directory". misc.mo:Expected error in mat $fasl-file-equal?: "$fasl-file-equal?: failed for probably-does-not-exist: no such file or directory". misc.mo:Expected error in mat $fasl-file-equal?: "$fasl-file-equal?: record comparison failed while comparing testfile-fatfib1.so and testfile-fatfib3.so within fasl entry 4". @@ -3869,7 +3869,7 @@ misc.mo:Expected error in mat cost-center: "with-cost-center: foo is not a cost center". misc.mo:Expected error in mat cost-center: "with-cost-center: bar is not a procedure". misc.mo:Expected error in mat cost-center: "cost-center-instruction-count: 5 is not a cost center". ---- 4059,4065 ---- +--- 4060,4066 ---- misc.mo:Expected error in mat $fasl-file-equal?: "$fasl-file-equal?: failed for probably-does-not-exist: no such file or directory". misc.mo:Expected error in mat $fasl-file-equal?: "$fasl-file-equal?: failed for probably-does-not-exist: no such file or directory". misc.mo:Expected error in mat $fasl-file-equal?: "$fasl-file-equal?: record comparison failed while comparing testfile-fatfib1.so and testfile-fatfib3.so within fasl entry 4". @@ -3878,7 +3878,7 @@ misc.mo:Expected error in mat cost-center: "with-cost-center: bar is not a procedure". misc.mo:Expected error in mat cost-center: "cost-center-instruction-count: 5 is not a cost center". *************** -*** 4113,4120 **** +*** 4114,4121 **** misc.mo:Expected error in mat apropos: "apropos: 3 is not a symbol or string". misc.mo:Expected error in mat apropos: "apropos: (hit me) is not a symbol or string". misc.mo:Expected error in mat apropos: "apropos-list: b is not an environment". @@ -3887,7 +3887,7 @@ misc.mo:Expected error in mat apropos: "variable $apropos-unbound1 is not bound". misc.mo:Expected error in mat apropos: "variable $apropos-unbound2 is not bound". misc.mo:Expected error in mat simplify-if: "textual-port?: a is not a port". ---- 4113,4120 ---- +--- 4114,4121 ---- misc.mo:Expected error in mat apropos: "apropos: 3 is not a symbol or string". misc.mo:Expected error in mat apropos: "apropos: (hit me) is not a symbol or string". misc.mo:Expected error in mat apropos: "apropos-list: b is not an environment". @@ -3897,7 +3897,7 @@ misc.mo:Expected error in mat apropos: "variable $apropos-unbound2 is not bound". misc.mo:Expected error in mat simplify-if: "textual-port?: a is not a port". *************** -*** 4129,4144 **** +*** 4130,4145 **** misc.mo:Expected error in mat pariah: "invalid syntax (pariah)". misc.mo:Expected error in mat pariah: "invalid syntax (pariah . 17)". misc.mo:Expected error in mat procedure-arity-mask: "procedure-arity-mask: 17 is not a procedure". @@ -3914,7 +3914,7 @@ misc.mo:Expected error in mat wrapper-procedure: "make-arity-wrapper-procedure: 1 is not a procedure". misc.mo:Expected error in mat wrapper-procedure: "make-arity-wrapper-procedure: not-a-procedure is not a procedure". misc.mo:Expected error in mat wrapper-procedure: "make-arity-wrapper-procedure: not-an-exact-integer is not an arity mask". ---- 4129,4144 ---- +--- 4130,4145 ---- misc.mo:Expected error in mat pariah: "invalid syntax (pariah)". misc.mo:Expected error in mat pariah: "invalid syntax (pariah . 17)". misc.mo:Expected error in mat procedure-arity-mask: "procedure-arity-mask: 17 is not a procedure". @@ -3932,7 +3932,7 @@ misc.mo:Expected error in mat wrapper-procedure: "make-arity-wrapper-procedure: not-a-procedure is not a procedure". misc.mo:Expected error in mat wrapper-procedure: "make-arity-wrapper-procedure: not-an-exact-integer is not an arity mask". *************** -*** 4148,4179 **** +*** 4149,4180 **** misc.mo:Expected error in mat wrapper-procedure: "wrapper-procedure-data: 1 is not a wrapper procedure". misc.mo:Expected error in mat wrapper-procedure: "wrapper-procedure-data: #<procedure> is not a wrapper procedure". misc.mo:Expected error in mat wrapper-procedure: "wrapper-procedure-data: #<procedure> is not a wrapper procedure". @@ -3965,7 +3965,7 @@ cp0.mo:Expected error in mat cp0-regression: "attempt to reference undefined variable x". cp0.mo:Expected error in mat cp0-regression: "incorrect argument count in call (g)". cp0.mo:Expected error in mat cp0-regression: "incorrect argument count in call (cont0 (quote x))". ---- 4148,4179 ---- +--- 4149,4180 ---- misc.mo:Expected error in mat wrapper-procedure: "wrapper-procedure-data: 1 is not a wrapper procedure". misc.mo:Expected error in mat wrapper-procedure: "wrapper-procedure-data: #<procedure> is not a wrapper procedure". misc.mo:Expected error in mat wrapper-procedure: "wrapper-procedure-data: #<procedure> is not a wrapper procedure". @@ -3999,7 +3999,7 @@ cp0.mo:Expected error in mat cp0-regression: "incorrect argument count in call (g)". cp0.mo:Expected error in mat cp0-regression: "incorrect argument count in call (cont0 (quote x))". *************** -*** 4187,4195 **** +*** 4188,4196 **** cp0.mo:Expected error in mat cp0-regression: "condition: #f is not a condition". cp0.mo:Expected error in mat cp0-regression: "apply: 0 is not a proper list". cp0.mo:Expected error in mat cp0-regression: "apply: 2 is not a proper list". @@ -4009,7 +4009,7 @@ cp0.mo:Expected error in mat expand-output: "expand-output: #t is not a textual output port or #f". cp0.mo:Expected error in mat expand-output: "expand-output: #<binary output port bytevector> is not a textual output port or #f". cp0.mo:Expected error in mat expand/optimize-output: "expand/optimize-output: #t is not a textual output port or #f". ---- 4187,4195 ---- +--- 4188,4196 ---- cp0.mo:Expected error in mat cp0-regression: "condition: #f is not a condition". cp0.mo:Expected error in mat cp0-regression: "apply: 0 is not a proper list". cp0.mo:Expected error in mat cp0-regression: "apply: 2 is not a proper list". @@ -4020,20 +4020,20 @@ cp0.mo:Expected error in mat expand-output: "expand-output: #<binary output port bytevector> is not a textual output port or #f". cp0.mo:Expected error in mat expand/optimize-output: "expand/optimize-output: #t is not a textual output port or #f". *************** -*** 4253,4261 **** - 5_6.mo:Expected error in mat list->fxvector: "list->fxvector: (1 2 . 3) is not a proper list". - 5_6.mo:Expected error in mat list->fxvector: "list->fxvector: (1 2 3 2 3 2 ...) is circular". - 5_6.mo:Expected error in mat fxvector->list: "fxvector->list: (a b c) is not an fxvector". +*** 4289,4297 **** + 5_6.mo:Expected error in mat list->flvector: "list->flvector: (1.0 2.0 . 3.0) is not a proper list". + 5_6.mo:Expected error in mat list->flvector: "list->flvector: (1.0 2.0 3.0 2.0 3.0 2.0 ...) is circular". + 5_6.mo:Expected error in mat flvector->list: "flvector->list: (a b c) is not an flvector". ! 5_6.mo:Expected error in mat vector-map: "incorrect argument count in call (vector-map)". ! 5_6.mo:Expected error in mat vector-map: "incorrect argument count in call (vector-map (quote #()))". ! 5_6.mo:Expected error in mat vector-map: "incorrect argument count in call (vector-map +)". 5_6.mo:Expected error in mat vector-map: "vector-map: #() is not a procedure". 5_6.mo:Expected error in mat vector-map: "vector-map: #() is not a procedure". 5_6.mo:Expected error in mat vector-map: "vector-map: #() is not a procedure". ---- 4253,4261 ---- - 5_6.mo:Expected error in mat list->fxvector: "list->fxvector: (1 2 . 3) is not a proper list". - 5_6.mo:Expected error in mat list->fxvector: "list->fxvector: (1 2 3 2 3 2 ...) is circular". - 5_6.mo:Expected error in mat fxvector->list: "fxvector->list: (a b c) is not an fxvector". +--- 4289,4297 ---- + 5_6.mo:Expected error in mat list->flvector: "list->flvector: (1.0 2.0 . 3.0) is not a proper list". + 5_6.mo:Expected error in mat list->flvector: "list->flvector: (1.0 2.0 3.0 2.0 3.0 2.0 ...) is circular". + 5_6.mo:Expected error in mat flvector->list: "flvector->list: (a b c) is not an flvector". ! 5_6.mo:Expected error in mat vector-map: "incorrect number of arguments 0 to #<procedure vector-map>". ! 5_6.mo:Expected error in mat vector-map: "incorrect number of arguments 1 to #<procedure vector-map>". ! 5_6.mo:Expected error in mat vector-map: "incorrect number of arguments 1 to #<procedure vector-map>". @@ -4041,7 +4041,7 @@ 5_6.mo:Expected error in mat vector-map: "vector-map: #() is not a procedure". 5_6.mo:Expected error in mat vector-map: "vector-map: #() is not a procedure". *************** -*** 4270,4278 **** +*** 4306,4314 **** 5_6.mo:Expected error in mat vector-map: "vector-map: lengths of input vectors #() and #(x) differ". 5_6.mo:Expected error in mat vector-map: "vector-map: lengths of input vectors #(y) and #() differ". 5_6.mo:Expected error in mat vector-map: "vector-map: lengths of input vectors #(y) and #() differ". @@ -4051,7 +4051,7 @@ 5_6.mo:Expected error in mat vector-for-each: "vector-for-each: #() is not a procedure". 5_6.mo:Expected error in mat vector-for-each: "vector-for-each: #() is not a procedure". 5_6.mo:Expected error in mat vector-for-each: "vector-for-each: #() is not a procedure". ---- 4270,4278 ---- +--- 4306,4314 ---- 5_6.mo:Expected error in mat vector-map: "vector-map: lengths of input vectors #() and #(x) differ". 5_6.mo:Expected error in mat vector-map: "vector-map: lengths of input vectors #(y) and #() differ". 5_6.mo:Expected error in mat vector-map: "vector-map: lengths of input vectors #(y) and #() differ". @@ -4062,7 +4062,7 @@ 5_6.mo:Expected error in mat vector-for-each: "vector-for-each: #() is not a procedure". 5_6.mo:Expected error in mat vector-for-each: "vector-for-each: #() is not a procedure". *************** -*** 4287,4304 **** +*** 4323,4340 **** 5_6.mo:Expected error in mat vector-for-each: "vector-for-each: lengths of input vectors #() and #(x) differ". 5_6.mo:Expected error in mat vector-for-each: "vector-for-each: lengths of input vectors #(y) and #() differ". 5_6.mo:Expected error in mat vector-for-each: "vector-for-each: lengths of input vectors #(y) and #() differ". @@ -4081,7 +4081,7 @@ 5_6.mo:Expected error in mat vector-sort!: "vector-sort!: 3 is not a mutable vector". 5_6.mo:Expected error in mat vector-sort!: "vector-sort!: (1 2 3) is not a mutable vector". 5_6.mo:Expected error in mat vector-sort!: "vector-sort!: #(a b c) is not a procedure". ---- 4287,4304 ---- +--- 4323,4340 ---- 5_6.mo:Expected error in mat vector-for-each: "vector-for-each: lengths of input vectors #() and #(x) differ". 5_6.mo:Expected error in mat vector-for-each: "vector-for-each: lengths of input vectors #(y) and #() differ". 5_6.mo:Expected error in mat vector-for-each: "vector-for-each: lengths of input vectors #(y) and #() differ". @@ -4101,20 +4101,20 @@ 5_6.mo:Expected error in mat vector-sort!: "vector-sort!: (1 2 3) is not a mutable vector". 5_6.mo:Expected error in mat vector-sort!: "vector-sort!: #(a b c) is not a procedure". *************** -*** 4309,4317 **** +*** 4343,4351 **** + 5_6.mo:Expected error in mat vector->immutable-vector: "vector-set-fixnum!: #(1 2 3) is not a mutable vector". + 5_6.mo:Expected error in mat vector->immutable-vector: "vector-fill!: #(1 2 3) is not a mutable vector". 5_6.mo:Expected error in mat vector->immutable-vector: "vector-sort!: #(1 2 3) is not a mutable vector". - 5_6.mo:Expected error in mat fxvector->immutable-fxvector: "fxvector-set!: #vfx(1 2 3) is not a mutable fxvector". - 5_6.mo:Expected error in mat fxvector->immutable-fxvector: "fxvector-fill!: #vfx(1 2 3) is not a mutable fxvector". ! 5_6.mo:Expected error in mat vector-cas!: "incorrect argument count in call (vector-cas! vec1)". ! 5_6.mo:Expected error in mat vector-cas!: "incorrect argument count in call (vector-cas! vec1 1)". ! 5_6.mo:Expected error in mat vector-cas!: "incorrect argument count in call (vector-cas! vec1 1 2)". 5_6.mo:Expected error in mat vector-cas!: "vector-cas!: 1 is not a mutable vector". 5_6.mo:Expected error in mat vector-cas!: "vector-cas!: #(4 5 3) is not a mutable vector". 5_6.mo:Expected error in mat vector-cas!: "vector-cas!: #(4 5 3) is not a valid index for #(4 5 3)". ---- 4309,4317 ---- +--- 4343,4351 ---- + 5_6.mo:Expected error in mat vector->immutable-vector: "vector-set-fixnum!: #(1 2 3) is not a mutable vector". + 5_6.mo:Expected error in mat vector->immutable-vector: "vector-fill!: #(1 2 3) is not a mutable vector". 5_6.mo:Expected error in mat vector->immutable-vector: "vector-sort!: #(1 2 3) is not a mutable vector". - 5_6.mo:Expected error in mat fxvector->immutable-fxvector: "fxvector-set!: #vfx(1 2 3) is not a mutable fxvector". - 5_6.mo:Expected error in mat fxvector->immutable-fxvector: "fxvector-fill!: #vfx(1 2 3) is not a mutable fxvector". ! 5_6.mo:Expected error in mat vector-cas!: "incorrect number of arguments 1 to #<procedure vector-cas!>". ! 5_6.mo:Expected error in mat vector-cas!: "incorrect number of arguments 2 to #<procedure vector-cas!>". ! 5_6.mo:Expected error in mat vector-cas!: "incorrect number of arguments 3 to #<procedure vector-cas!>". @@ -4122,7 +4122,7 @@ 5_6.mo:Expected error in mat vector-cas!: "vector-cas!: #(4 5 3) is not a mutable vector". 5_6.mo:Expected error in mat vector-cas!: "vector-cas!: #(4 5 3) is not a valid index for #(4 5 3)". *************** -*** 4368,4375 **** +*** 4402,4409 **** 5_7.mo:Expected error in mat putprop-getprop: "getprop: 3 is not a symbol". 5_7.mo:Expected error in mat putprop-getprop: "putprop: "hi" is not a symbol". 5_7.mo:Expected error in mat putprop-getprop: "property-list: (a b c) is not a symbol". @@ -4131,7 +4131,7 @@ 5_8.mo:Expected error in mat box-cas!: "box-cas!: 1 is not a mutable box". 5_8.mo:Expected error in mat box-cas!: "box-cas!: #&1 is not a mutable box". 6.mo:Expected error in mat port-operations: "open-input-file: failed for nonexistent file: no such file or directory". ---- 4368,4375 ---- +--- 4402,4409 ---- 5_7.mo:Expected error in mat putprop-getprop: "getprop: 3 is not a symbol". 5_7.mo:Expected error in mat putprop-getprop: "putprop: "hi" is not a symbol". 5_7.mo:Expected error in mat putprop-getprop: "property-list: (a b c) is not a symbol". @@ -4141,7 +4141,7 @@ 5_8.mo:Expected error in mat box-cas!: "box-cas!: #&1 is not a mutable box". 6.mo:Expected error in mat port-operations: "open-input-file: failed for nonexistent file: no such file or directory". *************** -*** 4407,4428 **** +*** 4441,4462 **** 6.mo:Expected error in mat port-operations: "clear-output-port: not permitted on closed port #<output port testfile.ss>". 6.mo:Expected error in mat port-operations: "current-output-port: a is not a textual output port". 6.mo:Expected error in mat port-operations: "current-input-port: a is not a textual input port". @@ -4164,7 +4164,7 @@ 6.mo:Expected error in mat port-operations1: "open-input-output-file: furball is not a string". 6.mo:Expected error in mat port-operations1: "open-input-output-file: failed for /probably/not/a/good/path: no such file or directory". 6.mo:Expected error in mat port-operations1: "open-input-output-file: invalid option compressed". ---- 4407,4428 ---- +--- 4441,4462 ---- 6.mo:Expected error in mat port-operations: "clear-output-port: not permitted on closed port #<output port testfile.ss>". 6.mo:Expected error in mat port-operations: "current-output-port: a is not a textual output port". 6.mo:Expected error in mat port-operations: "current-input-port: a is not a textual input port". @@ -4188,7 +4188,7 @@ 6.mo:Expected error in mat port-operations1: "open-input-output-file: failed for /probably/not/a/good/path: no such file or directory". 6.mo:Expected error in mat port-operations1: "open-input-output-file: invalid option compressed". *************** -*** 4431,4437 **** +*** 4465,4471 **** 6.mo:Expected error in mat port-operations1: "truncate-file: all-the-way is not a valid length". 6.mo:Expected error in mat port-operations1: "truncate-file: #<input port testfile.ss> is not an output port". 6.mo:Expected error in mat port-operations1: "truncate-file: animal-crackers is not an output port". @@ -4196,7 +4196,7 @@ 6.mo:Expected error in mat port-operations1: "truncate-file: not permitted on closed port #<input/output port testfile.ss>". 6.mo:Expected error in mat port-operations1: "get-output-string: #<input port string> is not a string output port". 6.mo:Expected error in mat port-operations1: "get-output-string: #<output port testfile.ss> is not a string output port". ---- 4431,4437 ---- +--- 4465,4471 ---- 6.mo:Expected error in mat port-operations1: "truncate-file: all-the-way is not a valid length". 6.mo:Expected error in mat port-operations1: "truncate-file: #<input port testfile.ss> is not an output port". 6.mo:Expected error in mat port-operations1: "truncate-file: animal-crackers is not an output port". @@ -4205,7 +4205,7 @@ 6.mo:Expected error in mat port-operations1: "get-output-string: #<input port string> is not a string output port". 6.mo:Expected error in mat port-operations1: "get-output-string: #<output port testfile.ss> is not a string output port". *************** -*** 4448,4455 **** +*** 4482,4489 **** 6.mo:Expected error in mat string-port-file-position: "file-position: -1 is not a valid position". 6.mo:Expected error in mat fresh-line: "fresh-line: 3 is not a textual output port". 6.mo:Expected error in mat fresh-line: "fresh-line: #<input port string> is not a textual output port". @@ -4214,7 +4214,7 @@ 6.mo:Expected error in mat pretty-print: "pretty-format: 3 is not a symbol". 6.mo:Expected error in mat pretty-print: "pretty-format: invalid format (bad 0 ... ... 0 format)". 6.mo:Expected error in mat fasl: "separate-eval: Warning in fasl-write: fasl file content is compressed internally; compressing the file (#<binary output port testfile.ss>) is redundant and can slow fasl writing and reading significantly ---- 4448,4455 ---- +--- 4482,4489 ---- 6.mo:Expected error in mat string-port-file-position: "file-position: -1 is not a valid position". 6.mo:Expected error in mat fresh-line: "fresh-line: 3 is not a textual output port". 6.mo:Expected error in mat fresh-line: "fresh-line: #<input port string> is not a textual output port". @@ -4224,7 +4224,7 @@ 6.mo:Expected error in mat pretty-print: "pretty-format: invalid format (bad 0 ... ... 0 format)". 6.mo:Expected error in mat fasl: "separate-eval: Warning in fasl-write: fasl file content is compressed internally; compressing the file (#<binary output port testfile.ss>) is redundant and can slow fasl writing and reading significantly *************** -*** 6939,6970 **** +*** 6973,7004 **** io.mo:Expected error in mat port-operations: "put-u8: not permitted on closed port #<binary output port testfile.ss>". io.mo:Expected error in mat port-operations: "put-bytevector: not permitted on closed port #<binary output port testfile.ss>". io.mo:Expected error in mat port-operations: "flush-output-port: not permitted on closed port #<binary output port testfile.ss>". @@ -4257,7 +4257,7 @@ io.mo:Expected error in mat port-operations1: "open-file-input/output-port: failed for /probably/not/a/good/path: no such file or directory". io.mo:Expected error in mat port-operations1: "invalid file option uncompressed". io.mo:Expected error in mat port-operations1: "invalid file option truncate". ---- 6939,6970 ---- +--- 6973,7004 ---- io.mo:Expected error in mat port-operations: "put-u8: not permitted on closed port #<binary output port testfile.ss>". io.mo:Expected error in mat port-operations: "put-bytevector: not permitted on closed port #<binary output port testfile.ss>". io.mo:Expected error in mat port-operations: "flush-output-port: not permitted on closed port #<binary output port testfile.ss>". @@ -4291,7 +4291,7 @@ io.mo:Expected error in mat port-operations1: "invalid file option uncompressed". io.mo:Expected error in mat port-operations1: "invalid file option truncate". *************** -*** 6975,6981 **** +*** 7009,7015 **** io.mo:Expected error in mat port-operations1: "set-port-length!: all-the-way is not a valid length". io.mo:Expected error in mat port-operations1: "truncate-port: #<binary input port testfile.ss> is not an output port". io.mo:Expected error in mat port-operations1: "truncate-port: animal-crackers is not an output port". @@ -4299,7 +4299,7 @@ io.mo:Expected error in mat port-operations1: "truncate-port: not permitted on closed port #<binary input/output port testfile.ss>". io.mo:Expected error in mat port-operations3: "file-port?: "not a port" is not a port". io.mo:Expected error in mat port-operations3: "port-file-descriptor: oops is not a port". ---- 6975,6981 ---- +--- 7009,7015 ---- io.mo:Expected error in mat port-operations1: "set-port-length!: all-the-way is not a valid length". io.mo:Expected error in mat port-operations1: "truncate-port: #<binary input port testfile.ss> is not an output port". io.mo:Expected error in mat port-operations1: "truncate-port: animal-crackers is not an output port". @@ -4308,7 +4308,7 @@ io.mo:Expected error in mat port-operations3: "file-port?: "not a port" is not a port". io.mo:Expected error in mat port-operations3: "port-file-descriptor: oops is not a port". *************** -*** 7158,7170 **** +*** 7192,7204 **** io.mo:Expected error in mat low-level-port-operations: "set-binary-port-output-size!: #vu8(1 2 3) is not a valid size for #<binary output port bytevector>". io.mo:Expected error in mat low-level-port-operations: "set-binary-port-output-size!: -1 is not a valid size for #<binary output port bytevector>". io.mo:Expected error in mat low-level-port-operations: "set-binary-port-output-size!: 6 is not a valid size for #<binary output port bytevector>". @@ -4322,7 +4322,7 @@ io.mo:Expected error in mat custom-port-buffer-size: "custom-port-buffer-size: shoe is not a positive fixnum". io.mo:Expected error in mat custom-port-buffer-size: "custom-port-buffer-size: 0 is not a positive fixnum". io.mo:Expected error in mat custom-port-buffer-size: "custom-port-buffer-size: -15 is not a positive fixnum". ---- 7158,7170 ---- +--- 7192,7204 ---- io.mo:Expected error in mat low-level-port-operations: "set-binary-port-output-size!: #vu8(1 2 3) is not a valid size for #<binary output port bytevector>". io.mo:Expected error in mat low-level-port-operations: "set-binary-port-output-size!: -1 is not a valid size for #<binary output port bytevector>". io.mo:Expected error in mat low-level-port-operations: "set-binary-port-output-size!: 6 is not a valid size for #<binary output port bytevector>". @@ -4337,7 +4337,7 @@ io.mo:Expected error in mat custom-port-buffer-size: "custom-port-buffer-size: 0 is not a positive fixnum". io.mo:Expected error in mat custom-port-buffer-size: "custom-port-buffer-size: -15 is not a positive fixnum". *************** -*** 7190,7205 **** +*** 7224,7239 **** io.mo:Expected error in mat compression: "port-file-compressed!: cannot compress input/output port #<binary input/output port testfile.ss>". io.mo:Expected error in mat compression: "port-file-compressed!: #<output port string> is not a file port". io.mo:Expected error in mat compression: "port-file-compressed!: cannot compress input/output port #<binary input/output port testfile.ss>". @@ -4354,7 +4354,7 @@ io.mo:Expected error in mat custom-binary-ports: "unget-u8: cannot unget 255 on #<binary input port foo>". io.mo:Expected error in mat custom-binary-ports: "put-u8: #<binary input port foo> is not a binary output port". io.mo:Expected error in mat custom-binary-ports: "port-length: #<binary input port foo> does not support operation". ---- 7190,7205 ---- +--- 7224,7239 ---- io.mo:Expected error in mat compression: "port-file-compressed!: cannot compress input/output port #<binary input/output port testfile.ss>". io.mo:Expected error in mat compression: "port-file-compressed!: #<output port string> is not a file port". io.mo:Expected error in mat compression: "port-file-compressed!: cannot compress input/output port #<binary input/output port testfile.ss>". @@ -4372,7 +4372,7 @@ io.mo:Expected error in mat custom-binary-ports: "put-u8: #<binary input port foo> is not a binary output port". io.mo:Expected error in mat custom-binary-ports: "port-length: #<binary input port foo> does not support operation". *************** -*** 7271,7286 **** +*** 7305,7320 **** io.mo:Expected error in mat current-ports: "console-output-port: #<input port string> is not a textual output port". io.mo:Expected error in mat current-ports: "console-error-port: #<input port string> is not a textual output port". io.mo:Expected error in mat current-transcoder: "current-transcoder: #<output port string> is not a transcoder". @@ -4389,7 +4389,7 @@ io.mo:Expected error in mat utf-16-codec: "utf-16-codec: invalid endianness #f". io.mo:Expected error in mat to-fold-or-not-to-fold: "get-datum: invalid character name #\newLine at char 0 of #<input port string>". io.mo:Expected error in mat to-fold-or-not-to-fold: "get-datum: invalid character name #\newLine at char 15 of #<input port string>". ---- 7271,7286 ---- +--- 7305,7320 ---- io.mo:Expected error in mat current-ports: "console-output-port: #<input port string> is not a textual output port". io.mo:Expected error in mat current-ports: "console-error-port: #<input port string> is not a textual output port". io.mo:Expected error in mat current-transcoder: "current-transcoder: #<output port string> is not a transcoder". @@ -4407,7 +4407,7 @@ io.mo:Expected error in mat to-fold-or-not-to-fold: "get-datum: invalid character name #\newLine at char 0 of #<input port string>". io.mo:Expected error in mat to-fold-or-not-to-fold: "get-datum: invalid character name #\newLine at char 15 of #<input port string>". *************** -*** 7452,7458 **** +*** 7486,7492 **** 7.mo:Expected error in mat eval-when: "invalid syntax visit-x". 7.mo:Expected error in mat eval-when: "invalid syntax revisit-x". 7.mo:Expected error in mat compile-whole-program: "compile-whole-program: failed for nosuchfile.wpo: no such file or directory". @@ -4415,7 +4415,7 @@ 7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception in environment: attempt to import invisible library (testfile-wpo-lib) 7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: library (testfile-wpo-a4) not found 7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: library (testfile-wpo-c4) not found ---- 7452,7458 ---- +--- 7486,7492 ---- 7.mo:Expected error in mat eval-when: "invalid syntax visit-x". 7.mo:Expected error in mat eval-when: "invalid syntax revisit-x". 7.mo:Expected error in mat compile-whole-program: "compile-whole-program: failed for nosuchfile.wpo: no such file or directory". @@ -4424,7 +4424,7 @@ 7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: library (testfile-wpo-a4) not found 7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: library (testfile-wpo-c4) not found *************** -*** 7518,7544 **** +*** 7552,7578 **** 7.mo:Expected error in mat concatenate-object-files: "separate-eval: Exception in verify-loadability: cannot find object file for library (testfile-cof1A) 7.mo:Expected error in mat concatenate-object-files: "separate-eval: Exception in verify-loadability: cannot find object file for library (testfile-cof1B) 7.mo:Expected error in mat top-level-value-functions: "top-level-bound?: "hello" is not a symbol". @@ -4452,7 +4452,7 @@ 7.mo:Expected error in mat top-level-value-functions: "define-top-level-value: hello is not an environment". 7.mo:Expected error in mat top-level-value-functions: "define-top-level-value: #<environment *scheme*> is not a symbol". 7.mo:Expected error in mat top-level-value-functions: "variable i-am-not-bound-i-hope is not bound". ---- 7518,7544 ---- +--- 7552,7578 ---- 7.mo:Expected error in mat concatenate-object-files: "separate-eval: Exception in verify-loadability: cannot find object file for library (testfile-cof1A) 7.mo:Expected error in mat concatenate-object-files: "separate-eval: Exception in verify-loadability: cannot find object file for library (testfile-cof1B) 7.mo:Expected error in mat top-level-value-functions: "top-level-bound?: "hello" is not a symbol". @@ -4481,7 +4481,7 @@ 7.mo:Expected error in mat top-level-value-functions: "define-top-level-value: #<environment *scheme*> is not a symbol". 7.mo:Expected error in mat top-level-value-functions: "variable i-am-not-bound-i-hope is not bound". *************** -*** 7853,7859 **** +*** 7899,7905 **** record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 1 to #<procedure>". record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 1 to #<procedure>". record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 3 to #<procedure>". @@ -4489,7 +4489,7 @@ record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 4 to #<procedure constructor>". record.mo:Expected error in mat r6rs-records-procedural: "make-record-constructor-descriptor: record constructor descriptor #<record constructor descriptor> is not for parent of record type #<record type grand-child>". record.mo:Expected error in mat r6rs-records-procedural: "make-record-type-descriptor: cannot extend sealed record type #<record type bar>". ---- 7853,7859 ---- +--- 7899,7905 ---- record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 1 to #<procedure>". record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 1 to #<procedure>". record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 3 to #<procedure>". @@ -4498,7 +4498,7 @@ record.mo:Expected error in mat r6rs-records-procedural: "make-record-constructor-descriptor: record constructor descriptor #<record constructor descriptor> is not for parent of record type #<record type grand-child>". record.mo:Expected error in mat r6rs-records-procedural: "make-record-type-descriptor: cannot extend sealed record type #<record type bar>". *************** -*** 7943,8057 **** +*** 7989,8103 **** hash.mo:Expected error in mat old-hash-table: "hash-table-for-each: ((a . b)) is not an eq hashtable". hash.mo:Expected error in mat old-hash-table: "incorrect number of arguments 2 to #<procedure>". hash.mo:Expected error in mat old-hash-table: "incorrect number of arguments 2 to #<procedure>". @@ -4614,7 +4614,7 @@ hash.mo:Expected error in mat hashtable-arguments: "hashtable-ephemeron?: (hash . table) is not a hashtable". hash.mo:Expected error in mat hash-return-value: "hashtable-ref: invalid hash-function #<procedure> return value "oops" for any". hash.mo:Expected error in mat hash-return-value: "hashtable-ref: invalid hash-function #<procedure> return value 3.5 for any". ---- 7943,8057 ---- +--- 7989,8103 ---- hash.mo:Expected error in mat old-hash-table: "hash-table-for-each: ((a . b)) is not an eq hashtable". hash.mo:Expected error in mat old-hash-table: "incorrect number of arguments 2 to #<procedure>". hash.mo:Expected error in mat old-hash-table: "incorrect number of arguments 2 to #<procedure>". @@ -4731,7 +4731,7 @@ hash.mo:Expected error in mat hash-return-value: "hashtable-ref: invalid hash-function #<procedure> return value "oops" for any". hash.mo:Expected error in mat hash-return-value: "hashtable-ref: invalid hash-function #<procedure> return value 3.5 for any". *************** -*** 8074,8196 **** +*** 8120,8242 **** hash.mo:Expected error in mat hash-return-value: "hashtable-delete!: invalid hash-function #<procedure> return value "oops" for any". hash.mo:Expected error in mat hash-return-value: "hashtable-delete!: invalid hash-function #<procedure> return value 3.5 for any". hash.mo:Expected error in mat hash-return-value: "hashtable-delete!: invalid hash-function #<procedure> return value 1+2i for any". @@ -4855,7 +4855,7 @@ hash.mo:Expected error in mat eqv-hashtable-arguments: "make-ephemeron-eqv-hashtable: invalid size argument -1". hash.mo:Expected error in mat eqv-hashtable-arguments: "make-ephemeron-eqv-hashtable: invalid size argument #t". hash.mo:Expected error in mat eqv-hashtable-arguments: "make-ephemeron-eqv-hashtable: invalid size argument #f". ---- 8074,8196 ---- +--- 8120,8242 ---- hash.mo:Expected error in mat hash-return-value: "hashtable-delete!: invalid hash-function #<procedure> return value "oops" for any". hash.mo:Expected error in mat hash-return-value: "hashtable-delete!: invalid hash-function #<procedure> return value 3.5 for any". hash.mo:Expected error in mat hash-return-value: "hashtable-delete!: invalid hash-function #<procedure> return value 1+2i for any". @@ -4980,10 +4980,26 @@ hash.mo:Expected error in mat eqv-hashtable-arguments: "make-ephemeron-eqv-hashtable: invalid size argument #t". hash.mo:Expected error in mat eqv-hashtable-arguments: "make-ephemeron-eqv-hashtable: invalid size argument #f". *************** -*** 8198,8213 **** +*** 8244,8275 **** hash.mo:Expected error in mat generic-hashtable: "hashtable-delete!: #<hashtable> is not mutable". hash.mo:Expected error in mat generic-hashtable: "hashtable-update!: #<hashtable> is not mutable". hash.mo:Expected error in mat generic-hashtable: "hashtable-update!: #<hashtable> is not mutable". +! hash.mo:Expected error in mat generic-hashtable-arguments: "incorrect argument count in call (make-weak-hashtable)". +! hash.mo:Expected error in mat generic-hashtable-arguments: "incorrect argument count in call (make-weak-hashtable equal-hash)". +! hash.mo:Expected error in mat generic-hashtable-arguments: "incorrect argument count in call (make-weak-hashtable equal-hash equal? 45 53)". + hash.mo:Expected error in mat generic-hashtable-arguments: "make-weak-hashtable: a is not a procedure". + hash.mo:Expected error in mat generic-hashtable-arguments: "make-weak-hashtable: a is not a procedure". + hash.mo:Expected error in mat generic-hashtable-arguments: "make-weak-hashtable: invalid size argument a". + hash.mo:Expected error in mat generic-hashtable-arguments: "make-weak-hashtable: invalid size argument -45". + hash.mo:Expected error in mat generic-hashtable-arguments: "make-weak-hashtable: invalid size argument 45.0". +! hash.mo:Expected error in mat generic-hashtable-arguments: "incorrect argument count in call (make-ephemeron-hashtable)". +! hash.mo:Expected error in mat generic-hashtable-arguments: "incorrect argument count in call (make-ephemeron-hashtable equal-hash)". +! hash.mo:Expected error in mat generic-hashtable-arguments: "incorrect argument count in call (make-ephemeron-hashtable equal-hash equal? 45 53)". + hash.mo:Expected error in mat generic-hashtable-arguments: "make-ephemeron-hashtable: a is not a procedure". + hash.mo:Expected error in mat generic-hashtable-arguments: "make-ephemeron-hashtable: a is not a procedure". + hash.mo:Expected error in mat generic-hashtable-arguments: "make-ephemeron-hashtable: invalid size argument a". + hash.mo:Expected error in mat generic-hashtable-arguments: "make-ephemeron-hashtable: invalid size argument -45". + hash.mo:Expected error in mat generic-hashtable-arguments: "make-ephemeron-hashtable: invalid size argument 45.0". ! hash.mo:Expected error in mat hash-functions: "incorrect argument count in call (equal-hash)". ! hash.mo:Expected error in mat hash-functions: "incorrect argument count in call (equal-hash 0 0)". ! hash.mo:Expected error in mat hash-functions: "incorrect argument count in call (symbol-hash)". @@ -4997,10 +5013,26 @@ hash.mo:Expected error in mat hash-functions: "string-ci-hash: hello is not a string". hash.mo:Expected error in mat fasl-other-hashtable: "fasl-write: invalid fasl object #<eqv hashtable>". hash.mo:Expected error in mat fasl-other-hashtable: "fasl-write: invalid fasl object #<hashtable>". ---- 8198,8213 ---- +--- 8244,8275 ---- hash.mo:Expected error in mat generic-hashtable: "hashtable-delete!: #<hashtable> is not mutable". hash.mo:Expected error in mat generic-hashtable: "hashtable-update!: #<hashtable> is not mutable". hash.mo:Expected error in mat generic-hashtable: "hashtable-update!: #<hashtable> is not mutable". +! hash.mo:Expected error in mat generic-hashtable-arguments: "incorrect number of arguments 0 to #<procedure make-weak-hashtable>". +! hash.mo:Expected error in mat generic-hashtable-arguments: "incorrect number of arguments 1 to #<procedure make-weak-hashtable>". +! hash.mo:Expected error in mat generic-hashtable-arguments: "incorrect number of arguments 4 to #<procedure make-weak-hashtable>". + hash.mo:Expected error in mat generic-hashtable-arguments: "make-weak-hashtable: a is not a procedure". + hash.mo:Expected error in mat generic-hashtable-arguments: "make-weak-hashtable: a is not a procedure". + hash.mo:Expected error in mat generic-hashtable-arguments: "make-weak-hashtable: invalid size argument a". + hash.mo:Expected error in mat generic-hashtable-arguments: "make-weak-hashtable: invalid size argument -45". + hash.mo:Expected error in mat generic-hashtable-arguments: "make-weak-hashtable: invalid size argument 45.0". +! hash.mo:Expected error in mat generic-hashtable-arguments: "incorrect number of arguments 0 to #<procedure make-ephemeron-hashtable>". +! hash.mo:Expected error in mat generic-hashtable-arguments: "incorrect number of arguments 1 to #<procedure make-ephemeron-hashtable>". +! hash.mo:Expected error in mat generic-hashtable-arguments: "incorrect number of arguments 4 to #<procedure make-ephemeron-hashtable>". + hash.mo:Expected error in mat generic-hashtable-arguments: "make-ephemeron-hashtable: a is not a procedure". + hash.mo:Expected error in mat generic-hashtable-arguments: "make-ephemeron-hashtable: a is not a procedure". + hash.mo:Expected error in mat generic-hashtable-arguments: "make-ephemeron-hashtable: invalid size argument a". + hash.mo:Expected error in mat generic-hashtable-arguments: "make-ephemeron-hashtable: invalid size argument -45". + hash.mo:Expected error in mat generic-hashtable-arguments: "make-ephemeron-hashtable: invalid size argument 45.0". ! hash.mo:Expected error in mat hash-functions: "incorrect number of arguments 0 to #<procedure equal-hash>". ! hash.mo:Expected error in mat hash-functions: "incorrect number of arguments 2 to #<procedure equal-hash>". ! hash.mo:Expected error in mat hash-functions: "incorrect number of arguments 0 to #<procedure symbol-hash>". @@ -5015,7 +5047,7 @@ hash.mo:Expected error in mat fasl-other-hashtable: "fasl-write: invalid fasl object #<eqv hashtable>". hash.mo:Expected error in mat fasl-other-hashtable: "fasl-write: invalid fasl object #<hashtable>". *************** -*** 8323,8330 **** +*** 8385,8392 **** 8.mo:Expected error in mat with-syntax: "invalid syntax a". 8.mo:Expected error in mat with-syntax: "duplicate pattern variable x in (x x)". 8.mo:Expected error in mat with-syntax: "duplicate pattern variable x in (x x)". @@ -5024,7 +5056,7 @@ 8.mo:Expected error in mat generate-temporaries: "generate-temporaries: improper list structure (a b . c)". 8.mo:Expected error in mat generate-temporaries: "generate-temporaries: cyclic list structure (a b c b c b ...)". 8.mo:Expected error in mat syntax->list: "syntax->list: invalid argument #<syntax a>". ---- 8323,8330 ---- +--- 8385,8392 ---- 8.mo:Expected error in mat with-syntax: "invalid syntax a". 8.mo:Expected error in mat with-syntax: "duplicate pattern variable x in (x x)". 8.mo:Expected error in mat with-syntax: "duplicate pattern variable x in (x x)". @@ -5034,7 +5066,7 @@ 8.mo:Expected error in mat generate-temporaries: "generate-temporaries: cyclic list structure (a b c b c b ...)". 8.mo:Expected error in mat syntax->list: "syntax->list: invalid argument #<syntax a>". *************** -*** 8941,8956 **** +*** 9003,9018 **** 8.mo:Expected error in mat rnrs-eval: "attempt to assign unbound identifier foo". 8.mo:Expected error in mat rnrs-eval: "invalid definition in immutable environment (define cons (quote #<procedure vector>))". 8.mo:Expected error in mat top-level-syntax-functions: "top-level-syntax: "hello" is not a symbol". @@ -5051,7 +5083,7 @@ 8.mo:Expected error in mat top-level-syntax-functions: "define-top-level-syntax: hello is not an environment". 8.mo:Expected error in mat top-level-syntax-functions: "define-top-level-syntax: #<environment *scheme*> is not a symbol". 8.mo:Expected error in mat top-level-syntax-functions: "define-top-level-syntax: cannot modify immutable environment #<environment *scheme*>". ---- 8941,8956 ---- +--- 9003,9018 ---- 8.mo:Expected error in mat rnrs-eval: "attempt to assign unbound identifier foo". 8.mo:Expected error in mat rnrs-eval: "invalid definition in immutable environment (define cons (quote #<procedure vector>))". 8.mo:Expected error in mat top-level-syntax-functions: "top-level-syntax: "hello" is not a symbol". @@ -5069,7 +5101,7 @@ 8.mo:Expected error in mat top-level-syntax-functions: "define-top-level-syntax: #<environment *scheme*> is not a symbol". 8.mo:Expected error in mat top-level-syntax-functions: "define-top-level-syntax: cannot modify immutable environment #<environment *scheme*>". *************** -*** 9047,9069 **** +*** 9109,9131 **** fx.mo:Expected error in mat fx=?: "fx=?: (a) is not a fixnum". fx.mo:Expected error in mat fx=?: "fx=?: <int> is not a fixnum". fx.mo:Expected error in mat fx=?: "fx=?: <-int> is not a fixnum". @@ -5093,7 +5125,7 @@ fx.mo:Expected error in mat $fxu<: "incorrect number of arguments 1 to #<procedure $fxu<>". fx.mo:Expected error in mat $fxu<: "incorrect number of arguments 3 to #<procedure $fxu<>". fx.mo:Expected error in mat $fxu<: "$fxu<: <-int> is not a fixnum". ---- 9047,9069 ---- +--- 9109,9131 ---- fx.mo:Expected error in mat fx=?: "fx=?: (a) is not a fixnum". fx.mo:Expected error in mat fx=?: "fx=?: <int> is not a fixnum". fx.mo:Expected error in mat fx=?: "fx=?: <-int> is not a fixnum". @@ -5118,9 +5150,9 @@ fx.mo:Expected error in mat $fxu<: "incorrect number of arguments 3 to #<procedure $fxu<>". fx.mo:Expected error in mat $fxu<: "$fxu<: <-int> is not a fixnum". *************** -*** 9095,9107 **** - fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum". - fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum". +*** 9167,9179 **** + fx.mo:Expected error in mat fx-/wraparound: "fx-: <-int> is not a fixnum". + fx.mo:Expected error in mat fx-/wraparound: "fx-: <-int> is not a fixnum". fx.mo:Expected error in mat fx*: "fx*: (a . b) is not a fixnum". ! fx.mo:Expected error in mat fx*: "fx*: fixnum overflow with arguments <int> and 2". fx.mo:Expected error in mat fx*: "fx*: <int> is not a fixnum". @@ -5132,9 +5164,9 @@ fx.mo:Expected error in mat r6rs:fx*: "fx*: <int> is not a fixnum". fx.mo:Expected error in mat r6rs:fx*: "fx*: <-int> is not a fixnum". fx.mo:Expected error in mat r6rs:fx*: "fx*: #f is not a fixnum". ---- 9095,9107 ---- - fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum". - fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum". +--- 9167,9179 ---- + fx.mo:Expected error in mat fx-/wraparound: "fx-: <-int> is not a fixnum". + fx.mo:Expected error in mat fx-/wraparound: "fx-: <-int> is not a fixnum". fx.mo:Expected error in mat fx*: "fx*: (a . b) is not a fixnum". ! fx.mo:Expected error in mat fx*: "fx*: fixnum overflow computing (fx* <int> 2)". fx.mo:Expected error in mat fx*: "fx*: <int> is not a fixnum". @@ -5147,7 +5179,7 @@ fx.mo:Expected error in mat r6rs:fx*: "fx*: <-int> is not a fixnum". fx.mo:Expected error in mat r6rs:fx*: "fx*: #f is not a fixnum". *************** -*** 9151,9163 **** +*** 9228,9240 **** fx.mo:Expected error in mat fx1+: "fx1+: <-int> is not a fixnum". fx.mo:Expected error in mat fx1+: "fx1+: <int> is not a fixnum". fx.mo:Expected error in mat fx1+: "fx1+: a is not a fixnum". @@ -5161,7 +5193,7 @@ fx.mo:Expected error in mat fxmax: "fxmax: a is not a fixnum". fx.mo:Expected error in mat fxmax: "fxmax: <int> is not a fixnum". fx.mo:Expected error in mat fxmax: "fxmax: <-int> is not a fixnum". ---- 9151,9163 ---- +--- 9228,9240 ---- fx.mo:Expected error in mat fx1+: "fx1+: <-int> is not a fixnum". fx.mo:Expected error in mat fx1+: "fx1+: <int> is not a fixnum". fx.mo:Expected error in mat fx1+: "fx1+: a is not a fixnum". @@ -5176,7 +5208,7 @@ fx.mo:Expected error in mat fxmax: "fxmax: <int> is not a fixnum". fx.mo:Expected error in mat fxmax: "fxmax: <-int> is not a fixnum". *************** -*** 9255,9264 **** +*** 9340,9349 **** fx.mo:Expected error in mat fxarithmetic-shift: "fxarithmetic-shift: fixnum overflow with arguments <int> and 10". fx.mo:Expected error in mat fxarithmetic-shift: "fxarithmetic-shift: fixnum overflow with arguments -4097 and <int>". fx.mo:Expected error in mat fxarithmetic-shift: "fxarithmetic-shift: fixnum overflow with arguments <-int> and 1". @@ -5187,7 +5219,7 @@ fx.mo:Expected error in mat fxbit-field: "fxbit-field: 35.0 is not a fixnum". fx.mo:Expected error in mat fxbit-field: "fxbit-field: 5.0 is not a valid start index". fx.mo:Expected error in mat fxbit-field: "fxbit-field: 8.0 is not a valid end index". ---- 9255,9264 ---- +--- 9340,9349 ---- fx.mo:Expected error in mat fxarithmetic-shift: "fxarithmetic-shift: fixnum overflow with arguments <int> and 10". fx.mo:Expected error in mat fxarithmetic-shift: "fxarithmetic-shift: fixnum overflow with arguments -4097 and <int>". fx.mo:Expected error in mat fxarithmetic-shift: "fxarithmetic-shift: fixnum overflow with arguments <-int> and 1". @@ -5199,7 +5231,7 @@ fx.mo:Expected error in mat fxbit-field: "fxbit-field: 5.0 is not a valid start index". fx.mo:Expected error in mat fxbit-field: "fxbit-field: 8.0 is not a valid end index". *************** -*** 9272,9305 **** +*** 9357,9390 **** fx.mo:Expected error in mat fxbit-field: "fxbit-field: <int> is not a valid end index". fx.mo:Expected error in mat fxbit-field: "fxbit-field: <int> is not a valid start index". fx.mo:Expected error in mat fxbit-field: "fxbit-field: <int> is not a valid end index". @@ -5234,7 +5266,7 @@ fx.mo:Expected error in mat fxif: "fxif: a is not a fixnum". fx.mo:Expected error in mat fxif: "fxif: 3.4 is not a fixnum". fx.mo:Expected error in mat fxif: "fxif: (a) is not a fixnum". ---- 9272,9305 ---- +--- 9357,9390 ---- fx.mo:Expected error in mat fxbit-field: "fxbit-field: <int> is not a valid end index". fx.mo:Expected error in mat fxbit-field: "fxbit-field: <int> is not a valid start index". fx.mo:Expected error in mat fxbit-field: "fxbit-field: <int> is not a valid end index". @@ -5270,7 +5302,7 @@ fx.mo:Expected error in mat fxif: "fxif: 3.4 is not a fixnum". fx.mo:Expected error in mat fxif: "fxif: (a) is not a fixnum". *************** -*** 9309,9352 **** +*** 9394,9437 **** fx.mo:Expected error in mat fxif: "fxif: <-int> is not a fixnum". fx.mo:Expected error in mat fxif: "fxif: <-int> is not a fixnum". fx.mo:Expected error in mat fxif: "fxif: <-int> is not a fixnum". @@ -5315,7 +5347,7 @@ fx.mo:Expected error in mat fxcopy-bit: "fxcopy-bit: 3.4 is not a fixnum". fx.mo:Expected error in mat fxcopy-bit: "fxcopy-bit: "3" is not a fixnum". fx.mo:Expected error in mat fxcopy-bit: "fxcopy-bit: <int> is not a fixnum". ---- 9309,9352 ---- +--- 9394,9437 ---- fx.mo:Expected error in mat fxif: "fxif: <-int> is not a fixnum". fx.mo:Expected error in mat fxif: "fxif: <-int> is not a fixnum". fx.mo:Expected error in mat fxif: "fxif: <-int> is not a fixnum". @@ -5361,7 +5393,7 @@ fx.mo:Expected error in mat fxcopy-bit: "fxcopy-bit: "3" is not a fixnum". fx.mo:Expected error in mat fxcopy-bit: "fxcopy-bit: <int> is not a fixnum". *************** -*** 9355,9365 **** +*** 9440,9450 **** fx.mo:Expected error in mat fxcopy-bit: "fxcopy-bit: invalid bit index -1". fx.mo:Expected error in mat fxcopy-bit: "fxcopy-bit: invalid bit index <int>". fx.mo:Expected error in mat fxcopy-bit: "fxcopy-bit: invalid bit index <int>". @@ -5373,7 +5405,7 @@ fx.mo:Expected error in mat fxcopy-bit-field: "fxcopy-bit-field: "3" is not a fixnum". fx.mo:Expected error in mat fxcopy-bit-field: "fxcopy-bit-field: 3.4 is not a valid start index". fx.mo:Expected error in mat fxcopy-bit-field: "fxcopy-bit-field: 3/4 is not a valid end index". ---- 9355,9365 ---- +--- 9440,9450 ---- fx.mo:Expected error in mat fxcopy-bit: "fxcopy-bit: invalid bit index -1". fx.mo:Expected error in mat fxcopy-bit: "fxcopy-bit: invalid bit index <int>". fx.mo:Expected error in mat fxcopy-bit: "fxcopy-bit: invalid bit index <int>". @@ -5386,7 +5418,7 @@ fx.mo:Expected error in mat fxcopy-bit-field: "fxcopy-bit-field: 3.4 is not a valid start index". fx.mo:Expected error in mat fxcopy-bit-field: "fxcopy-bit-field: 3/4 is not a valid end index". *************** -*** 9419,9428 **** +*** 9504,9513 **** fx.mo:Expected error in mat fxdiv0-and-mod0: "fxmod0: (a) is not a fixnum". fx.mo:Expected error in mat fxdiv0-and-mod0: "fxmod0: undefined for 0". fx.mo:Expected error in mat fxdiv0-and-mod0: "fxmod0: undefined for 0". @@ -5397,7 +5429,7 @@ fx.mo:Expected error in mat fx+/carry: "fx+/carry: 1.0 is not a fixnum". fx.mo:Expected error in mat fx+/carry: "fx+/carry: 2.0 is not a fixnum". fx.mo:Expected error in mat fx+/carry: "fx+/carry: 3.0 is not a fixnum". ---- 9419,9428 ---- +--- 9504,9513 ---- fx.mo:Expected error in mat fxdiv0-and-mod0: "fxmod0: (a) is not a fixnum". fx.mo:Expected error in mat fxdiv0-and-mod0: "fxmod0: undefined for 0". fx.mo:Expected error in mat fxdiv0-and-mod0: "fxmod0: undefined for 0". @@ -5409,7 +5441,7 @@ fx.mo:Expected error in mat fx+/carry: "fx+/carry: 2.0 is not a fixnum". fx.mo:Expected error in mat fx+/carry: "fx+/carry: 3.0 is not a fixnum". *************** -*** 9438,9447 **** +*** 9523,9532 **** fx.mo:Expected error in mat fx+/carry: "fx+/carry: <-int> is not a fixnum". fx.mo:Expected error in mat fx+/carry: "fx+/carry: <-int> is not a fixnum". fx.mo:Expected error in mat fx+/carry: "fx+/carry: <-int> is not a fixnum". @@ -5420,7 +5452,7 @@ fx.mo:Expected error in mat fx-/carry: "fx-/carry: 1.0 is not a fixnum". fx.mo:Expected error in mat fx-/carry: "fx-/carry: 2.0 is not a fixnum". fx.mo:Expected error in mat fx-/carry: "fx-/carry: 3.0 is not a fixnum". ---- 9438,9447 ---- +--- 9523,9532 ---- fx.mo:Expected error in mat fx+/carry: "fx+/carry: <-int> is not a fixnum". fx.mo:Expected error in mat fx+/carry: "fx+/carry: <-int> is not a fixnum". fx.mo:Expected error in mat fx+/carry: "fx+/carry: <-int> is not a fixnum". @@ -5432,7 +5464,7 @@ fx.mo:Expected error in mat fx-/carry: "fx-/carry: 2.0 is not a fixnum". fx.mo:Expected error in mat fx-/carry: "fx-/carry: 3.0 is not a fixnum". *************** -*** 9457,9466 **** +*** 9542,9551 **** fx.mo:Expected error in mat fx-/carry: "fx-/carry: <-int> is not a fixnum". fx.mo:Expected error in mat fx-/carry: "fx-/carry: <-int> is not a fixnum". fx.mo:Expected error in mat fx-/carry: "fx-/carry: <-int> is not a fixnum". @@ -5443,7 +5475,7 @@ fx.mo:Expected error in mat fx*/carry: "fx*/carry: 1.0 is not a fixnum". fx.mo:Expected error in mat fx*/carry: "fx*/carry: 2.0 is not a fixnum". fx.mo:Expected error in mat fx*/carry: "fx*/carry: 3.0 is not a fixnum". ---- 9457,9466 ---- +--- 9542,9551 ---- fx.mo:Expected error in mat fx-/carry: "fx-/carry: <-int> is not a fixnum". fx.mo:Expected error in mat fx-/carry: "fx-/carry: <-int> is not a fixnum". fx.mo:Expected error in mat fx-/carry: "fx-/carry: <-int> is not a fixnum". @@ -5455,7 +5487,7 @@ fx.mo:Expected error in mat fx*/carry: "fx*/carry: 2.0 is not a fixnum". fx.mo:Expected error in mat fx*/carry: "fx*/carry: 3.0 is not a fixnum". *************** -*** 9476,9486 **** +*** 9561,9571 **** fx.mo:Expected error in mat fx*/carry: "fx*/carry: <-int> is not a fixnum". fx.mo:Expected error in mat fx*/carry: "fx*/carry: <-int> is not a fixnum". fx.mo:Expected error in mat fx*/carry: "fx*/carry: <-int> is not a fixnum". @@ -5467,7 +5499,7 @@ fx.mo:Expected error in mat fxrotate-bit-field: "fxrotate-bit-field: a is not a fixnum". fx.mo:Expected error in mat fxrotate-bit-field: "fxrotate-bit-field: invalid start index 0.0". fx.mo:Expected error in mat fxrotate-bit-field: "fxrotate-bit-field: invalid end index 2.0". ---- 9476,9486 ---- +--- 9561,9571 ---- fx.mo:Expected error in mat fx*/carry: "fx*/carry: <-int> is not a fixnum". fx.mo:Expected error in mat fx*/carry: "fx*/carry: <-int> is not a fixnum". fx.mo:Expected error in mat fx*/carry: "fx*/carry: <-int> is not a fixnum". @@ -5480,7 +5512,7 @@ fx.mo:Expected error in mat fxrotate-bit-field: "fxrotate-bit-field: invalid start index 0.0". fx.mo:Expected error in mat fxrotate-bit-field: "fxrotate-bit-field: invalid end index 2.0". *************** -*** 9503,9512 **** +*** 9588,9597 **** fx.mo:Expected error in mat fxrotate-bit-field: "fxrotate-bit-field: invalid end index <int>". fx.mo:Expected error in mat fxrotate-bit-field: "fxrotate-bit-field: invalid end index <int>". fx.mo:Expected error in mat fxrotate-bit-field: "fxrotate-bit-field: count 1 is greater than difference between end index 5 and start index 5". @@ -5491,7 +5523,7 @@ fx.mo:Expected error in mat fxreverse-bit-field: "fxreverse-bit-field: a is not a fixnum". fx.mo:Expected error in mat fxreverse-bit-field: "fxreverse-bit-field: invalid start index 0.0". fx.mo:Expected error in mat fxreverse-bit-field: "fxreverse-bit-field: invalid end index 2.0". ---- 9503,9512 ---- +--- 9588,9597 ---- fx.mo:Expected error in mat fxrotate-bit-field: "fxrotate-bit-field: invalid end index <int>". fx.mo:Expected error in mat fxrotate-bit-field: "fxrotate-bit-field: invalid end index <int>". fx.mo:Expected error in mat fxrotate-bit-field: "fxrotate-bit-field: count 1 is greater than difference between end index 5 and start index 5". @@ -5503,7 +5535,7 @@ fx.mo:Expected error in mat fxreverse-bit-field: "fxreverse-bit-field: invalid start index 0.0". fx.mo:Expected error in mat fxreverse-bit-field: "fxreverse-bit-field: invalid end index 2.0". *************** -*** 9522,9539 **** +*** 9607,9624 **** fx.mo:Expected error in mat fxreverse-bit-field: "fxreverse-bit-field: invalid end index <int>". fx.mo:Expected error in mat fxreverse-bit-field: "fxreverse-bit-field: invalid end index <-int>". fx.mo:Expected error in mat fxreverse-bit-field: "fxreverse-bit-field: start index 7 is greater than end index 5". @@ -5522,7 +5554,7 @@ fl.mo:Expected error in mat fl=: "fl=: (a) is not a flonum". fl.mo:Expected error in mat fl=: "fl=: a is not a flonum". fl.mo:Expected error in mat fl=: "fl=: a is not a flonum". ---- 9522,9539 ---- +--- 9607,9624 ---- fx.mo:Expected error in mat fxreverse-bit-field: "fxreverse-bit-field: invalid end index <int>". fx.mo:Expected error in mat fxreverse-bit-field: "fxreverse-bit-field: invalid end index <-int>". fx.mo:Expected error in mat fxreverse-bit-field: "fxreverse-bit-field: start index 7 is greater than end index 5". @@ -5542,7 +5574,7 @@ fl.mo:Expected error in mat fl=: "fl=: a is not a flonum". fl.mo:Expected error in mat fl=: "fl=: a is not a flonum". *************** -*** 9541,9547 **** +*** 9626,9632 **** fl.mo:Expected error in mat fl=: "fl=: 3 is not a flonum". fl.mo:Expected error in mat fl=: "fl=: 7/2 is not a flonum". fl.mo:Expected error in mat fl=: "fl=: 7/2 is not a flonum". @@ -5550,7 +5582,7 @@ fl.mo:Expected error in mat fl<: "fl<: (a) is not a flonum". fl.mo:Expected error in mat fl<: "fl<: a is not a flonum". fl.mo:Expected error in mat fl<: "fl<: a is not a flonum". ---- 9541,9547 ---- +--- 9626,9632 ---- fl.mo:Expected error in mat fl=: "fl=: 3 is not a flonum". fl.mo:Expected error in mat fl=: "fl=: 7/2 is not a flonum". fl.mo:Expected error in mat fl=: "fl=: 7/2 is not a flonum". @@ -5559,7 +5591,7 @@ fl.mo:Expected error in mat fl<: "fl<: a is not a flonum". fl.mo:Expected error in mat fl<: "fl<: a is not a flonum". *************** -*** 9549,9555 **** +*** 9634,9640 **** fl.mo:Expected error in mat fl<: "fl<: 3 is not a flonum". fl.mo:Expected error in mat fl<: "fl<: 7/2 is not a flonum". fl.mo:Expected error in mat fl<: "fl<: 7/2 is not a flonum". @@ -5567,7 +5599,7 @@ fl.mo:Expected error in mat fl>: "fl>: (a) is not a flonum". fl.mo:Expected error in mat fl>: "fl>: a is not a flonum". fl.mo:Expected error in mat fl>: "fl>: a is not a flonum". ---- 9549,9555 ---- +--- 9634,9640 ---- fl.mo:Expected error in mat fl<: "fl<: 3 is not a flonum". fl.mo:Expected error in mat fl<: "fl<: 7/2 is not a flonum". fl.mo:Expected error in mat fl<: "fl<: 7/2 is not a flonum". @@ -5576,7 +5608,7 @@ fl.mo:Expected error in mat fl>: "fl>: a is not a flonum". fl.mo:Expected error in mat fl>: "fl>: a is not a flonum". *************** -*** 9557,9563 **** +*** 9642,9648 **** fl.mo:Expected error in mat fl>: "fl>: 3 is not a flonum". fl.mo:Expected error in mat fl>: "fl>: 7/2 is not a flonum". fl.mo:Expected error in mat fl>: "fl>: 7/2 is not a flonum". @@ -5584,7 +5616,7 @@ fl.mo:Expected error in mat fl<=: "fl<=: (a) is not a flonum". fl.mo:Expected error in mat fl<=: "fl<=: a is not a flonum". fl.mo:Expected error in mat fl<=: "fl<=: a is not a flonum". ---- 9557,9563 ---- +--- 9642,9648 ---- fl.mo:Expected error in mat fl>: "fl>: 3 is not a flonum". fl.mo:Expected error in mat fl>: "fl>: 7/2 is not a flonum". fl.mo:Expected error in mat fl>: "fl>: 7/2 is not a flonum". @@ -5593,7 +5625,7 @@ fl.mo:Expected error in mat fl<=: "fl<=: a is not a flonum". fl.mo:Expected error in mat fl<=: "fl<=: a is not a flonum". *************** -*** 9565,9571 **** +*** 9650,9656 **** fl.mo:Expected error in mat fl<=: "fl<=: 3 is not a flonum". fl.mo:Expected error in mat fl<=: "fl<=: 7/2 is not a flonum". fl.mo:Expected error in mat fl<=: "fl<=: 7/2 is not a flonum". @@ -5601,7 +5633,7 @@ fl.mo:Expected error in mat fl>=: "fl>=: (a) is not a flonum". fl.mo:Expected error in mat fl>=: "fl>=: a is not a flonum". fl.mo:Expected error in mat fl>=: "fl>=: a is not a flonum". ---- 9565,9571 ---- +--- 9650,9656 ---- fl.mo:Expected error in mat fl<=: "fl<=: 3 is not a flonum". fl.mo:Expected error in mat fl<=: "fl<=: 7/2 is not a flonum". fl.mo:Expected error in mat fl<=: "fl<=: 7/2 is not a flonum". @@ -5610,7 +5642,7 @@ fl.mo:Expected error in mat fl>=: "fl>=: a is not a flonum". fl.mo:Expected error in mat fl>=: "fl>=: a is not a flonum". *************** -*** 9573,9612 **** +*** 9658,9697 **** fl.mo:Expected error in mat fl>=: "fl>=: 3 is not a flonum". fl.mo:Expected error in mat fl>=: "fl>=: 7/2 is not a flonum". fl.mo:Expected error in mat fl>=: "fl>=: 7/2 is not a flonum". @@ -5651,7 +5683,7 @@ fl.mo:Expected error in mat fl>=?: "fl>=?: a is not a flonum". fl.mo:Expected error in mat fl>=?: "fl>=?: a is not a flonum". fl.mo:Expected error in mat fl>=?: "fl>=?: 3 is not a flonum". ---- 9573,9612 ---- +--- 9658,9697 ---- fl.mo:Expected error in mat fl>=: "fl>=: 3 is not a flonum". fl.mo:Expected error in mat fl>=: "fl>=: 7/2 is not a flonum". fl.mo:Expected error in mat fl>=: "fl>=: 7/2 is not a flonum". @@ -5693,7 +5725,7 @@ fl.mo:Expected error in mat fl>=?: "fl>=?: a is not a flonum". fl.mo:Expected error in mat fl>=?: "fl>=?: 3 is not a flonum". *************** -*** 9616,9622 **** +*** 9701,9707 **** fl.mo:Expected error in mat fl+: "fl+: (a . b) is not a flonum". fl.mo:Expected error in mat fl+: "fl+: 1 is not a flonum". fl.mo:Expected error in mat fl+: "fl+: 2/3 is not a flonum". @@ -5701,7 +5733,7 @@ fl.mo:Expected error in mat fl-: "fl-: (a . b) is not a flonum". fl.mo:Expected error in mat fl-: "fl-: 1 is not a flonum". fl.mo:Expected error in mat fl-: "fl-: a is not a flonum". ---- 9616,9622 ---- +--- 9701,9707 ---- fl.mo:Expected error in mat fl+: "fl+: (a . b) is not a flonum". fl.mo:Expected error in mat fl+: "fl+: 1 is not a flonum". fl.mo:Expected error in mat fl+: "fl+: 2/3 is not a flonum". @@ -5710,7 +5742,7 @@ fl.mo:Expected error in mat fl-: "fl-: 1 is not a flonum". fl.mo:Expected error in mat fl-: "fl-: a is not a flonum". *************** -*** 9626,9715 **** +*** 9711,9800 **** fl.mo:Expected error in mat fl*: "fl*: (a . b) is not a flonum". fl.mo:Expected error in mat fl*: "fl*: 1 is not a flonum". fl.mo:Expected error in mat fl*: "fl*: 2/3 is not a flonum". @@ -5801,7 +5833,7 @@ fl.mo:Expected error in mat flsingle: "flsingle: a is not a flonum". fl.mo:Expected error in mat flsingle: "flsingle: 3 is not a flonum". fl.mo:Expected error in mat flsingle: "flsingle: 2.0+1.0i is not a flonum". ---- 9626,9715 ---- +--- 9711,9800 ---- fl.mo:Expected error in mat fl*: "fl*: (a . b) is not a flonum". fl.mo:Expected error in mat fl*: "fl*: 1 is not a flonum". fl.mo:Expected error in mat fl*: "fl*: 2/3 is not a flonum". @@ -5893,7 +5925,7 @@ fl.mo:Expected error in mat flsingle: "flsingle: 3 is not a flonum". fl.mo:Expected error in mat flsingle: "flsingle: 2.0+1.0i is not a flonum". *************** -*** 9728,9763 **** +*** 9813,9848 **** fl.mo:Expected error in mat flinfinite?: "flinfinite?: 3 is not a flonum". fl.mo:Expected error in mat flinfinite?: "flinfinite?: 3/4 is not a flonum". fl.mo:Expected error in mat flinfinite?: "flinfinite?: hi is not a flonum". @@ -5930,7 +5962,7 @@ fl.mo:Expected error in mat fleven?: "fleven?: a is not a flonum". fl.mo:Expected error in mat fleven?: "fleven?: 3 is not a flonum". fl.mo:Expected error in mat fleven?: "fleven?: 3.2 is not an integer". ---- 9728,9763 ---- +--- 9813,9848 ---- fl.mo:Expected error in mat flinfinite?: "flinfinite?: 3 is not a flonum". fl.mo:Expected error in mat flinfinite?: "flinfinite?: 3/4 is not a flonum". fl.mo:Expected error in mat flinfinite?: "flinfinite?: hi is not a flonum". @@ -5968,7 +6000,7 @@ fl.mo:Expected error in mat fleven?: "fleven?: 3 is not a flonum". fl.mo:Expected error in mat fleven?: "fleven?: 3.2 is not an integer". *************** -*** 9765,9772 **** +*** 9850,9857 **** fl.mo:Expected error in mat fleven?: "fleven?: 1+1i is not a flonum". fl.mo:Expected error in mat fleven?: "fleven?: +inf.0 is not an integer". fl.mo:Expected error in mat fleven?: "fleven?: +nan.0 is not an integer". @@ -5977,7 +6009,7 @@ fl.mo:Expected error in mat flodd?: "flodd?: a is not a flonum". fl.mo:Expected error in mat flodd?: "flodd?: 3 is not a flonum". fl.mo:Expected error in mat flodd?: "flodd?: 3.2 is not an integer". ---- 9765,9772 ---- +--- 9850,9857 ---- fl.mo:Expected error in mat fleven?: "fleven?: 1+1i is not a flonum". fl.mo:Expected error in mat fleven?: "fleven?: +inf.0 is not an integer". fl.mo:Expected error in mat fleven?: "fleven?: +nan.0 is not an integer". @@ -5987,7 +6019,7 @@ fl.mo:Expected error in mat flodd?: "flodd?: 3 is not a flonum". fl.mo:Expected error in mat flodd?: "flodd?: 3.2 is not an integer". *************** -*** 9774,9780 **** +*** 9859,9865 **** fl.mo:Expected error in mat flodd?: "flodd?: 3+1i is not a flonum". fl.mo:Expected error in mat flodd?: "flodd?: +inf.0 is not an integer". fl.mo:Expected error in mat flodd?: "flodd?: +nan.0 is not an integer". @@ -5995,7 +6027,7 @@ fl.mo:Expected error in mat flmin: "flmin: a is not a flonum". fl.mo:Expected error in mat flmin: "flmin: a is not a flonum". fl.mo:Expected error in mat flmin: "flmin: a is not a flonum". ---- 9774,9780 ---- +--- 9859,9865 ---- fl.mo:Expected error in mat flodd?: "flodd?: 3+1i is not a flonum". fl.mo:Expected error in mat flodd?: "flodd?: +inf.0 is not an integer". fl.mo:Expected error in mat flodd?: "flodd?: +nan.0 is not an integer". @@ -6004,7 +6036,7 @@ fl.mo:Expected error in mat flmin: "flmin: a is not a flonum". fl.mo:Expected error in mat flmin: "flmin: a is not a flonum". *************** -*** 9782,9788 **** +*** 9867,9873 **** fl.mo:Expected error in mat flmin: "flmin: a is not a flonum". fl.mo:Expected error in mat flmin: "flmin: 0.0+1.0i is not a flonum". fl.mo:Expected error in mat flmin: "flmin: 0+1i is not a flonum". @@ -6012,7 +6044,7 @@ fl.mo:Expected error in mat flmax: "flmax: a is not a flonum". fl.mo:Expected error in mat flmax: "flmax: a is not a flonum". fl.mo:Expected error in mat flmax: "flmax: 3 is not a flonum". ---- 9782,9788 ---- +--- 9867,9873 ---- fl.mo:Expected error in mat flmin: "flmin: a is not a flonum". fl.mo:Expected error in mat flmin: "flmin: 0.0+1.0i is not a flonum". fl.mo:Expected error in mat flmin: "flmin: 0+1i is not a flonum". @@ -6021,7 +6053,7 @@ fl.mo:Expected error in mat flmax: "flmax: a is not a flonum". fl.mo:Expected error in mat flmax: "flmax: 3 is not a flonum". *************** -*** 9790,9803 **** +*** 9875,9888 **** fl.mo:Expected error in mat flmax: "flmax: a is not a flonum". fl.mo:Expected error in mat flmax: "flmax: 0.0+1.0i is not a flonum". fl.mo:Expected error in mat flmax: "flmax: 0+1i is not a flonum". @@ -6036,7 +6068,7 @@ fl.mo:Expected error in mat fldenominator: "fldenominator: a is not a flonum". fl.mo:Expected error in mat fldenominator: "fldenominator: 3 is not a flonum". fl.mo:Expected error in mat fldenominator: "fldenominator: 0+1i is not a flonum". ---- 9790,9803 ---- +--- 9875,9888 ---- fl.mo:Expected error in mat flmax: "flmax: a is not a flonum". fl.mo:Expected error in mat flmax: "flmax: 0.0+1.0i is not a flonum". fl.mo:Expected error in mat flmax: "flmax: 0+1i is not a flonum". @@ -6052,7 +6084,7 @@ fl.mo:Expected error in mat fldenominator: "fldenominator: 3 is not a flonum". fl.mo:Expected error in mat fldenominator: "fldenominator: 0+1i is not a flonum". *************** -*** 9843,9849 **** +*** 9928,9934 **** cfl.mo:Expected error in mat cfl-: "cfl-: a is not a cflonum". cfl.mo:Expected error in mat cfl-: "cfl-: a is not a cflonum". cfl.mo:Expected error in mat cfl-: "cfl-: a is not a cflonum". @@ -6060,7 +6092,7 @@ cfl.mo:Expected error in mat cfl-: "cfl-: a is not a cflonum". cfl.mo:Expected error in mat cfl-: "cfl-: a is not a cflonum". cfl.mo:Expected error in mat cfl-: "cfl-: a is not a cflonum". ---- 9843,9849 ---- +--- 9928,9934 ---- cfl.mo:Expected error in mat cfl-: "cfl-: a is not a cflonum". cfl.mo:Expected error in mat cfl-: "cfl-: a is not a cflonum". cfl.mo:Expected error in mat cfl-: "cfl-: a is not a cflonum". @@ -6069,7 +6101,7 @@ cfl.mo:Expected error in mat cfl-: "cfl-: a is not a cflonum". cfl.mo:Expected error in mat cfl-: "cfl-: a is not a cflonum". *************** -*** 9853,9866 **** +*** 9938,9951 **** cfl.mo:Expected error in mat cfl/: "cfl/: a is not a cflonum". cfl.mo:Expected error in mat cfl/: "cfl/: a is not a cflonum". cfl.mo:Expected error in mat cfl/: "cfl/: a is not a cflonum". @@ -6084,7 +6116,7 @@ foreign.mo:Expected error in mat load-shared-object: "load-shared-object: invalid path 3". foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: no entry for "i do not exist"". foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: no entry for "i do not exist"". ---- 9853,9866 ---- +--- 9938,9951 ---- cfl.mo:Expected error in mat cfl/: "cfl/: a is not a cflonum". cfl.mo:Expected error in mat cfl/: "cfl/: a is not a cflonum". cfl.mo:Expected error in mat cfl/: "cfl/: a is not a cflonum". @@ -6100,7 +6132,7 @@ foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: no entry for "i do not exist"". foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: no entry for "i do not exist"". *************** -*** 9895,9902 **** +*** 9980,9987 **** foreign.mo:Expected error in mat foreign-procedure: "id: invalid foreign-procedure argument foo". foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle abcde". foreign.mo:Expected error in mat foreign-procedure: "float_id: invalid foreign-procedure argument 0". @@ -6109,7 +6141,7 @@ foreign.mo:Expected error in mat foreign-sizeof: "foreign-sizeof: invalid foreign type specifier i-am-not-a-type". foreign.mo:Expected error in mat foreign-sizeof: "foreign-sizeof: invalid foreign type specifier 1". foreign.mo:Expected error in mat foreign-bytevectors: "u8*->u8*: invalid foreign-procedure argument "hello"". ---- 9895,9902 ---- +--- 9980,9987 ---- foreign.mo:Expected error in mat foreign-procedure: "id: invalid foreign-procedure argument foo". foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle abcde". foreign.mo:Expected error in mat foreign-procedure: "float_id: invalid foreign-procedure argument 0". @@ -6119,7 +6151,7 @@ foreign.mo:Expected error in mat foreign-sizeof: "foreign-sizeof: invalid foreign type specifier 1". foreign.mo:Expected error in mat foreign-bytevectors: "u8*->u8*: invalid foreign-procedure argument "hello"". *************** -*** 10395,10407 **** +*** 10480,10492 **** unix.mo:Expected error in mat file-operations: "file-access-time: failed for "testlink": no such file or directory". unix.mo:Expected error in mat file-operations: "file-change-time: failed for "testlink": no such file or directory". unix.mo:Expected error in mat file-operations: "file-modification-time: failed for "testlink": no such file or directory". @@ -6133,7 +6165,7 @@ windows.mo:Expected error in mat registry: "get-registry: pooh is not a string". windows.mo:Expected error in mat registry: "put-registry!: 3 is not a string". windows.mo:Expected error in mat registry: "put-registry!: 3 is not a string". ---- 10395,10407 ---- +--- 10480,10492 ---- unix.mo:Expected error in mat file-operations: "file-access-time: failed for "testlink": no such file or directory". unix.mo:Expected error in mat file-operations: "file-change-time: failed for "testlink": no such file or directory". unix.mo:Expected error in mat file-operations: "file-modification-time: failed for "testlink": no such file or directory". @@ -6148,7 +6180,7 @@ windows.mo:Expected error in mat registry: "put-registry!: 3 is not a string". windows.mo:Expected error in mat registry: "put-registry!: 3 is not a string". *************** -*** 10429,10500 **** +*** 10514,10585 **** ieee.mo:Expected error in mat flonum->fixnum: "flonum->fixnum: result for -inf.0 would be outside of fixnum range". ieee.mo:Expected error in mat flonum->fixnum: "flonum->fixnum: result for +nan.0 would be outside of fixnum range". ieee.mo:Expected error in mat fllp: "fllp: 3 is not a flonum". @@ -6221,7 +6253,7 @@ date.mo:Expected error in mat time: "time>=?: 3 is not a time record". date.mo:Expected error in mat time: "time>=?: #<procedure car> is not a time record". date.mo:Expected error in mat time: "time>=?: types of <time> and <time> differ". ---- 10429,10500 ---- +--- 10514,10585 ---- ieee.mo:Expected error in mat flonum->fixnum: "flonum->fixnum: result for -inf.0 would be outside of fixnum range". ieee.mo:Expected error in mat flonum->fixnum: "flonum->fixnum: result for +nan.0 would be outside of fixnum range". ieee.mo:Expected error in mat fllp: "fllp: 3 is not a flonum". @@ -6295,7 +6327,7 @@ date.mo:Expected error in mat time: "time>=?: #<procedure car> is not a time record". date.mo:Expected error in mat time: "time>=?: types of <time> and <time> differ". *************** -*** 10502,10515 **** +*** 10587,10600 **** date.mo:Expected error in mat time: "add-duration: <time> does not have type time-duration". date.mo:Expected error in mat time: "subtract-duration: <time> does not have type time-duration". date.mo:Expected error in mat time: "copy-time: <date> is not a time record". @@ -6310,7 +6342,7 @@ date.mo:Expected error in mat date: "make-date: invalid nanosecond -1". date.mo:Expected error in mat date: "make-date: invalid nanosecond <int>". date.mo:Expected error in mat date: "make-date: invalid nanosecond zero". ---- 10502,10515 ---- +--- 10587,10600 ---- date.mo:Expected error in mat time: "add-duration: <time> does not have type time-duration". date.mo:Expected error in mat time: "subtract-duration: <time> does not have type time-duration". date.mo:Expected error in mat time: "copy-time: <date> is not a time record". @@ -6326,7 +6358,7 @@ date.mo:Expected error in mat date: "make-date: invalid nanosecond <int>". date.mo:Expected error in mat date: "make-date: invalid nanosecond zero". *************** -*** 10535,10595 **** +*** 10620,10680 **** date.mo:Expected error in mat date: "make-date: invalid time-zone offset 90000". date.mo:Expected error in mat date: "make-date: invalid time-zone offset est". date.mo:Expected error in mat date: "make-date: invalid time-zone offset "est"". @@ -6388,7 +6420,7 @@ date.mo:Expected error in mat date: "current-date: invalid time-zone offset -90000". date.mo:Expected error in mat date: "current-date: invalid time-zone offset 90000". date.mo:Expected error in mat conversions/sleep: "date->time-utc: <time> is not a date record". ---- 10535,10595 ---- +--- 10620,10680 ---- date.mo:Expected error in mat date: "make-date: invalid time-zone offset 90000". date.mo:Expected error in mat date: "make-date: invalid time-zone offset est". date.mo:Expected error in mat date: "make-date: invalid time-zone offset "est"". diff --git a/src/ChezScheme/mats/patch-compile-2-f-t-f b/src/ChezScheme/mats/patch-compile-2-f-t-f index 6bd4b2fa3b..b34e8046a3 100644 --- a/src/ChezScheme/mats/patch-compile-2-f-t-f +++ b/src/ChezScheme/mats/patch-compile-2-f-t-f @@ -36,27 +36,27 @@ 3.mo:Expected warning in mat cpvalid: "possible attempt to reference undefined variable x". *************** *** 191,200 **** - 3.mo:Expected error in mat mrvs: "returned three values to single value return context". - 3.mo:Expected error in mat mrvs: "returned three values to single value return context". - 3.mo:Expected error in mat mrvs: "returned zero values to single value return context". + 3.mo:Expected error in mat mrvs: "returned 3 values to single value return context". + 3.mo:Expected error in mat mrvs: "returned 3 values to single value return context". + 3.mo:Expected error in mat mrvs: "returned 0 values to single value return context". ! 3.mo:Expected error in mat mrvs: "incorrect number of values received in multiple value context". -! 3.mo:Expected error in mat mrvs: "returned zero values to single value return context". +! 3.mo:Expected error in mat mrvs: "returned 0 values to single value return context". ! 3.mo:Expected error in mat mrvs: "incorrect number of values received in multiple value context". ! 3.mo:Expected error in mat mrvs: "incorrect number of values received in multiple value context". 3.mo:Expected error in mat mrvs: "variable $mrvs-foo is not bound". 3.mo:Expected error in mat mrvs: "attempt to apply non-procedure 17". - 3.mo:Expected error in mat mrvs: "returned two values to single value return context". + 3.mo:Expected error in mat mrvs: "returned 2 values to single value return context". --- 191,200 ---- - 3.mo:Expected error in mat mrvs: "returned three values to single value return context". - 3.mo:Expected error in mat mrvs: "returned three values to single value return context". - 3.mo:Expected error in mat mrvs: "returned zero values to single value return context". + 3.mo:Expected error in mat mrvs: "returned 3 values to single value return context". + 3.mo:Expected error in mat mrvs: "returned 3 values to single value return context". + 3.mo:Expected error in mat mrvs: "returned 0 values to single value return context". ! 3.mo:Expected error in mat mrvs: "incorrect argument count in call (call-with-values (lambda () 5 (values 2)) (lambda (x y) (+ x y)))". ! 3.mo:Expected error in mat mrvs: "incorrect argument count in call (call-with-values values (lambda (x) x))". ! 3.mo:Expected error in mat mrvs: "incorrect argument count in call (call-with-values values (lambda (x y) x))". ! 3.mo:Expected error in mat mrvs: "incorrect argument count in call (call-with-values f (lambda (x y) x))". 3.mo:Expected error in mat mrvs: "variable $mrvs-foo is not bound". 3.mo:Expected error in mat mrvs: "attempt to apply non-procedure 17". - 3.mo:Expected error in mat mrvs: "returned two values to single value return context". + 3.mo:Expected error in mat mrvs: "returned 2 values to single value return context". *************** *** 3645,3651 **** misc.mo:Expected error in mat cpletrec: "foreign-procedure: no entry for "foo"". diff --git a/src/ChezScheme/mats/patch-compile-2-t-f-f b/src/ChezScheme/mats/patch-compile-2-t-f-f index f951012ca0..b378e42bed 100644 --- a/src/ChezScheme/mats/patch-compile-2-t-f-f +++ b/src/ChezScheme/mats/patch-compile-2-t-f-f @@ -19,30 +19,30 @@ 3.mo:Expected error in mat letrec: "attempt to assign undefined variable b". *************** *** 191,202 **** - 3.mo:Expected error in mat mrvs: "returned three values to single value return context". - 3.mo:Expected error in mat mrvs: "returned three values to single value return context". - 3.mo:Expected error in mat mrvs: "returned zero values to single value return context". + 3.mo:Expected error in mat mrvs: "returned 3 values to single value return context". + 3.mo:Expected error in mat mrvs: "returned 3 values to single value return context". + 3.mo:Expected error in mat mrvs: "returned 0 values to single value return context". ! 3.mo:Expected error in mat mrvs: "incorrect number of values received in multiple value context". -! 3.mo:Expected error in mat mrvs: "returned zero values to single value return context". +! 3.mo:Expected error in mat mrvs: "returned 0 values to single value return context". ! 3.mo:Expected error in mat mrvs: "incorrect number of values received in multiple value context". ! 3.mo:Expected error in mat mrvs: "incorrect number of values received in multiple value context". 3.mo:Expected error in mat mrvs: "variable $mrvs-foo is not bound". ! 3.mo:Expected error in mat mrvs: "attempt to apply non-procedure 17". - 3.mo:Expected error in mat mrvs: "returned two values to single value return context". - 3.mo:Expected error in mat mrvs: "returned two values to single value return context". + 3.mo:Expected error in mat mrvs: "returned 2 values to single value return context". + 3.mo:Expected error in mat mrvs: "returned 2 values to single value return context". 3.mo:Expected error in mat mrvs: "cdr: a is not a pair". --- 191,202 ---- - 3.mo:Expected error in mat mrvs: "returned three values to single value return context". - 3.mo:Expected error in mat mrvs: "returned three values to single value return context". - 3.mo:Expected error in mat mrvs: "returned zero values to single value return context". + 3.mo:Expected error in mat mrvs: "returned 3 values to single value return context". + 3.mo:Expected error in mat mrvs: "returned 3 values to single value return context". + 3.mo:Expected error in mat mrvs: "returned 0 values to single value return context". ! 3.mo:Expected error in mat mrvs: "incorrect number of arguments to #<procedure>". ! 3.mo:Expected error in mat mrvs: "incorrect number of arguments to #<procedure>". ! 3.mo:Expected error in mat mrvs: "incorrect number of arguments to #<procedure>". ! 3.mo:Expected error in mat mrvs: "incorrect number of arguments to #<procedure>". 3.mo:Expected error in mat mrvs: "variable $mrvs-foo is not bound". ! 3.mo:Expected error in mat mrvs: "call-with-values: 17 is not a procedure". - 3.mo:Expected error in mat mrvs: "returned two values to single value return context". - 3.mo:Expected error in mat mrvs: "returned two values to single value return context". + 3.mo:Expected error in mat mrvs: "returned 2 values to single value return context". + 3.mo:Expected error in mat mrvs: "returned 2 values to single value return context". 3.mo:Expected error in mat mrvs: "cdr: a is not a pair". *************** *** 233,240 **** diff --git a/src/ChezScheme/mats/patch-interpret-0-f-f-f b/src/ChezScheme/mats/patch-interpret-0-f-f-f index ac8073f455..886fe6888e 100644 --- a/src/ChezScheme/mats/patch-interpret-0-f-f-f +++ b/src/ChezScheme/mats/patch-interpret-0-f-f-f @@ -1,5 +1,5 @@ -*** errors-compile-0-f-f-f 2020-03-11 22:32:59.000000000 -0600 ---- errors-interpret-0-f-f-f 2020-03-11 22:14:11.000000000 -0600 +*** errors-compile-0-f-f-f 2020-11-23 06:11:33.000000000 -0700 +--- errors-interpret-0-f-f-f 2020-11-23 05:51:54.000000000 -0700 *************** *** 18,25 **** primvars.mo:Expected error testing (environment (quote (chezscheme)) (quote (chezscheme)) (quote #f)): Exception in environment: invalid library reference #f @@ -20,7 +20,7 @@ primvars.mo:Expected error testing (expand 1.0+2.0i (quote #f)): Exception in sc-expand: #f is not an environment primvars.mo:Expected error testing (expand 1.0+2.0i (quote ((a . b))) 1.0+2.0i): Exception in sc-expand: ((a . b)) is not an environment *************** -*** 130,136 **** +*** 76,82 **** primvars.mo:Expected error in mat make-parameter: "make-parameter: 2 is not a procedure". primvars.mo:Expected error in mat make-parameter: "+: a is not a number". primvars.mo:Expected error in mat make-parameter: "incorrect number of arguments 1 to #<procedure>". @@ -28,7 +28,7 @@ primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: a is not a positive fixnum". primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: -1 is not a positive fixnum". primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: 0 is not a positive fixnum". ---- 130,136 ---- +--- 76,82 ---- primvars.mo:Expected error in mat make-parameter: "make-parameter: 2 is not a procedure". primvars.mo:Expected error in mat make-parameter: "+: a is not a number". primvars.mo:Expected error in mat make-parameter: "incorrect number of arguments 1 to #<procedure>". @@ -37,7 +37,7 @@ primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: -1 is not a positive fixnum". primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: 0 is not a positive fixnum". *************** -*** 157,227 **** +*** 103,173 **** primvars.mo:Expected error in mat print-radix: "print-radix: 1 is not between 2 and 36". primvars.mo:Expected error in mat timer-interrupt-handler: "timer-interrupt-handler: midnight is not a procedure". primvars.mo:Expected error in mat trace-output-port: "trace-output-port: #<input port string> is not a textual output port". @@ -109,7 +109,7 @@ 3.mo:Expected error in mat let: "incorrect argument count in call ((lambda (x . r) (eq? x (...))))". 3.mo:Expected error in mat letrec: "variable f is not bound". 3.mo:Expected error in mat letrec: "attempt to reference undefined variable a". ---- 157,227 ---- +--- 103,173 ---- primvars.mo:Expected error in mat print-radix: "print-radix: 1 is not between 2 and 36". primvars.mo:Expected error in mat timer-interrupt-handler: "timer-interrupt-handler: midnight is not a procedure". primvars.mo:Expected error in mat trace-output-port: "trace-output-port: #<input port string> is not a textual output port". @@ -182,34 +182,34 @@ 3.mo:Expected error in mat letrec: "variable f is not bound". 3.mo:Expected error in mat letrec: "attempt to reference undefined variable a". *************** -*** 320,331 **** - 3.mo:Expected error in mat mrvs: "returned three values to single value return context". - 3.mo:Expected error in mat mrvs: "returned three values to single value return context". - 3.mo:Expected error in mat mrvs: "returned zero values to single value return context". +*** 266,277 **** + 3.mo:Expected error in mat mrvs: "returned 3 values to single value return context". + 3.mo:Expected error in mat mrvs: "returned 3 values to single value return context". + 3.mo:Expected error in mat mrvs: "returned 0 values to single value return context". ! 3.mo:Expected error in mat mrvs: "incorrect number of values received in multiple value context". -! 3.mo:Expected error in mat mrvs: "returned zero values to single value return context". +! 3.mo:Expected error in mat mrvs: "returned 0 values to single value return context". ! 3.mo:Expected error in mat mrvs: "incorrect number of values received in multiple value context". ! 3.mo:Expected error in mat mrvs: "incorrect number of values received in multiple value context". 3.mo:Expected error in mat mrvs: "variable $mrvs-foo is not bound". ! 3.mo:Expected error in mat mrvs: "attempt to apply non-procedure 17". - 3.mo:Expected error in mat mrvs: "returned two values to single value return context". - 3.mo:Expected error in mat mrvs: "returned two values to single value return context". + 3.mo:Expected error in mat mrvs: "returned 2 values to single value return context". + 3.mo:Expected error in mat mrvs: "returned 2 values to single value return context". 3.mo:Expected error in mat mrvs: "cdr: a is not a pair". ---- 320,331 ---- - 3.mo:Expected error in mat mrvs: "returned three values to single value return context". - 3.mo:Expected error in mat mrvs: "returned three values to single value return context". - 3.mo:Expected error in mat mrvs: "returned zero values to single value return context". +--- 266,277 ---- + 3.mo:Expected error in mat mrvs: "returned 3 values to single value return context". + 3.mo:Expected error in mat mrvs: "returned 3 values to single value return context". + 3.mo:Expected error in mat mrvs: "returned 0 values to single value return context". ! 3.mo:Expected error in mat mrvs: "incorrect number of arguments 1 to #<procedure>". ! 3.mo:Expected error in mat mrvs: "incorrect number of arguments 0 to #<procedure>". ! 3.mo:Expected error in mat mrvs: "incorrect number of arguments 0 to #<procedure>". ! 3.mo:Expected error in mat mrvs: "incorrect number of arguments 0 to #<procedure>". 3.mo:Expected error in mat mrvs: "variable $mrvs-foo is not bound". ! 3.mo:Expected error in mat mrvs: "call-with-values: 17 is not a procedure". - 3.mo:Expected error in mat mrvs: "returned two values to single value return context". - 3.mo:Expected error in mat mrvs: "returned two values to single value return context". + 3.mo:Expected error in mat mrvs: "returned 2 values to single value return context". + 3.mo:Expected error in mat mrvs: "returned 2 values to single value return context". 3.mo:Expected error in mat mrvs: "cdr: a is not a pair". *************** -*** 7462,7468 **** +*** 7466,7472 **** 7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for testfile-mc-1a.ss: no such file or directory 7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: file "testfile-mc-1a.ss" not found in source directories 7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for ./testfile-mc-3a.ss: no such file or directory @@ -217,7 +217,7 @@ 7.mo:Expected error in mat eval: "interpret: 7 is not an environment". 7.mo:Expected error in mat eval: "compile: 7 is not an environment". 7.mo:Expected error in mat expand: "sc-expand: 7 is not an environment". ---- 7462,7468 ---- +--- 7466,7472 ---- 7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for testfile-mc-1a.ss: no such file or directory 7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: file "testfile-mc-1a.ss" not found in source directories 7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for ./testfile-mc-3a.ss: no such file or directory @@ -226,7 +226,7 @@ 7.mo:Expected error in mat eval: "compile: 7 is not an environment". 7.mo:Expected error in mat expand: "sc-expand: 7 is not an environment". *************** -*** 7841,7847 **** +*** 7857,7863 **** record.mo:Expected error in mat record25: "invalid value #\9 for foreign type uptr". record.mo:Expected error in mat record25: "invalid value 10 for foreign type float". record.mo:Expected error in mat record25: "invalid value 11.0+0.0i for foreign type double". @@ -234,7 +234,7 @@ record.mo:Expected error in mat record25: "invalid value 12.0 for foreign type long-long". record.mo:Expected error in mat record25: "invalid value 13.0 for foreign type unsigned-long-long". record.mo:Expected error in mat record25: "invalid value 3.0 for foreign type int". ---- 7841,7847 ---- +--- 7857,7863 ---- record.mo:Expected error in mat record25: "invalid value #\9 for foreign type uptr". record.mo:Expected error in mat record25: "invalid value 10 for foreign type float". record.mo:Expected error in mat record25: "invalid value 11.0+0.0i for foreign type double". @@ -243,7 +243,7 @@ record.mo:Expected error in mat record25: "invalid value 13.0 for foreign type unsigned-long-long". record.mo:Expected error in mat record25: "invalid value 3.0 for foreign type int". *************** -*** 7883,7889 **** +*** 7899,7905 **** record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 1 to #<procedure>". record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 1 to #<procedure>". record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 3 to #<procedure>". @@ -251,7 +251,7 @@ record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 4 to #<procedure constructor>". record.mo:Expected error in mat r6rs-records-procedural: "make-record-constructor-descriptor: record constructor descriptor #<record constructor descriptor> is not for parent of record type #<record type grand-child>". record.mo:Expected error in mat r6rs-records-procedural: "make-record-type-descriptor: cannot extend sealed record type #<record type bar>". ---- 7883,7889 ---- +--- 7899,7905 ---- record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 1 to #<procedure>". record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 1 to #<procedure>". record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 3 to #<procedure>". @@ -260,9 +260,9 @@ record.mo:Expected error in mat r6rs-records-procedural: "make-record-constructor-descriptor: record constructor descriptor #<record constructor descriptor> is not for parent of record type #<record type grand-child>". record.mo:Expected error in mat r6rs-records-procedural: "make-record-type-descriptor: cannot extend sealed record type #<record type bar>". *************** -*** 9127,9139 **** - fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum". - fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum". +*** 9167,9179 **** + fx.mo:Expected error in mat fx-/wraparound: "fx-: <-int> is not a fixnum". + fx.mo:Expected error in mat fx-/wraparound: "fx-: <-int> is not a fixnum". fx.mo:Expected error in mat fx*: "fx*: (a . b) is not a fixnum". ! fx.mo:Expected error in mat fx*: "fx*: fixnum overflow with arguments <int> and 2". fx.mo:Expected error in mat fx*: "fx*: <int> is not a fixnum". @@ -274,9 +274,9 @@ fx.mo:Expected error in mat r6rs:fx*: "fx*: <int> is not a fixnum". fx.mo:Expected error in mat r6rs:fx*: "fx*: <-int> is not a fixnum". fx.mo:Expected error in mat r6rs:fx*: "fx*: #f is not a fixnum". ---- 9127,9139 ---- - fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum". - fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum". +--- 9167,9179 ---- + fx.mo:Expected error in mat fx-/wraparound: "fx-: <-int> is not a fixnum". + fx.mo:Expected error in mat fx-/wraparound: "fx-: <-int> is not a fixnum". fx.mo:Expected error in mat fx*: "fx*: (a . b) is not a fixnum". ! fx.mo:Expected error in mat fx*: "fx*: fixnum overflow computing (fx* <int> 2)". fx.mo:Expected error in mat fx*: "fx*: <int> is not a fixnum". @@ -289,7 +289,7 @@ fx.mo:Expected error in mat r6rs:fx*: "fx*: <-int> is not a fixnum". fx.mo:Expected error in mat r6rs:fx*: "fx*: #f is not a fixnum". *************** -*** 9894,9918 **** +*** 9953,9977 **** foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo". foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo". foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo". @@ -315,7 +315,7 @@ foreign.mo:Expected error in mat foreign-procedure: "invalid foreign-procedure argument type specifier booleen". foreign.mo:Expected error in mat foreign-procedure: "invalid foreign-procedure argument type specifier integer-34". foreign.mo:Expected error in mat foreign-procedure: "invalid foreign-procedure result type specifier chare". ---- 9894,9918 ---- +--- 9953,9977 ---- foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo". foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo". foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo". @@ -342,7 +342,7 @@ foreign.mo:Expected error in mat foreign-procedure: "invalid foreign-procedure argument type specifier integer-34". foreign.mo:Expected error in mat foreign-procedure: "invalid foreign-procedure result type specifier chare". *************** -*** 9925,9956 **** +*** 9984,10015 **** foreign.mo:Expected error in mat foreign-sizeof: "incorrect argument count in call (foreign-sizeof (quote int) (quote int))". foreign.mo:Expected error in mat foreign-sizeof: "foreign-sizeof: invalid foreign type specifier i-am-not-a-type". foreign.mo:Expected error in mat foreign-sizeof: "foreign-sizeof: invalid foreign type specifier 1". @@ -375,7 +375,7 @@ foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>". foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>". foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>". ---- 9925,9956 ---- +--- 9984,10015 ---- foreign.mo:Expected error in mat foreign-sizeof: "incorrect argument count in call (foreign-sizeof (quote int) (quote int))". foreign.mo:Expected error in mat foreign-sizeof: "foreign-sizeof: invalid foreign type specifier i-am-not-a-type". foreign.mo:Expected error in mat foreign-sizeof: "foreign-sizeof: invalid foreign type specifier 1". @@ -409,7 +409,7 @@ foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>". foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>". *************** -*** 9958,9983 **** +*** 10017,10042 **** foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>". foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>". foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>". @@ -436,7 +436,7 @@ foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>". foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>". foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>". ---- 9958,9983 ---- +--- 10017,10042 ---- foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>". foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>". foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>". @@ -464,7 +464,7 @@ foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>". foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>". *************** -*** 9988,10022 **** +*** 10048,10082 **** foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>". foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>". foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>". @@ -500,7 +500,7 @@ foreign.mo:Expected error in mat foreign-C-types: "foreign-callable: invalid return value (73 74) from #<procedure>". foreign.mo:Expected error in mat foreign-C-types: "foreign-callable: invalid return value (73 74) from #<procedure>". foreign.mo:Expected error in mat foreign-C-types: "foreign-callable: invalid return value (73 74) from #<procedure>". ---- 9988,10022 ---- +--- 10048,10082 ---- foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>". foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>". foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>". @@ -537,7 +537,7 @@ foreign.mo:Expected error in mat foreign-C-types: "foreign-callable: invalid return value (73 74) from #<procedure>". foreign.mo:Expected error in mat foreign-C-types: "foreign-callable: invalid return value (73 74) from #<procedure>". *************** -*** 10623,10632 **** +*** 10683,10692 **** exceptions.mo:Expected error in mat assert: "failed assertion (memq (quote b) (quote (1 2 a 3 4)))". exceptions.mo:Expected error in mat assert: "failed assertion (q ...)". exceptions.mo:Expected error in mat assert: "failed assertion (andmap symbol? (syntax (x ...)))". @@ -548,7 +548,7 @@ oop.mo:Expected error in mat oop: "m1: not applicable to 17". oop.mo:Expected error in mat oop: "variable <a>-x1 is not bound". oop.mo:Expected error in mat oop: "variable <a>-x1-set! is not bound". ---- 10623,10632 ---- +--- 10683,10692 ---- exceptions.mo:Expected error in mat assert: "failed assertion (memq (quote b) (quote (1 2 a 3 4)))". exceptions.mo:Expected error in mat assert: "failed assertion (q ...)". exceptions.mo:Expected error in mat assert: "failed assertion (andmap symbol? (syntax (x ...)))". diff --git a/src/ChezScheme/mats/patch-interpret-0-f-t-f b/src/ChezScheme/mats/patch-interpret-0-f-t-f index 2eae3d95fc..7d0b20bfc3 100644 --- a/src/ChezScheme/mats/patch-interpret-0-f-t-f +++ b/src/ChezScheme/mats/patch-interpret-0-f-t-f @@ -1,5 +1,5 @@ -*** errors-compile-0-f-t-f 2020-06-03 11:23:43.000000000 -0600 ---- errors-interpret-0-f-t-f 2020-06-03 15:11:49.000000000 -0600 +*** errors-compile-0-f-t-f 2020-11-23 05:33:39.000000000 -0700 +--- errors-interpret-0-f-t-f 2020-11-23 06:01:59.000000000 -0700 *************** *** 18,25 **** primvars.mo:Expected error testing (environment (quote (chezscheme)) (quote (chezscheme)) (quote #f)): Exception in environment: invalid library reference #f @@ -20,7 +20,7 @@ primvars.mo:Expected error testing (expand 1.0+2.0i (quote #f)): Exception in sc-expand: #f is not an environment primvars.mo:Expected error testing (expand 1.0+2.0i (quote ((a . b))) 1.0+2.0i): Exception in sc-expand: ((a . b)) is not an environment *************** -*** 74,80 **** +*** 76,82 **** primvars.mo:Expected error in mat make-parameter: "make-parameter: 2 is not a procedure". primvars.mo:Expected error in mat make-parameter: "+: a is not a number". primvars.mo:Expected error in mat make-parameter: "incorrect number of arguments 1 to #<procedure>". @@ -28,7 +28,7 @@ primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: a is not a positive fixnum". primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: -1 is not a positive fixnum". primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: 0 is not a positive fixnum". ---- 74,80 ---- +--- 76,82 ---- primvars.mo:Expected error in mat make-parameter: "make-parameter: 2 is not a procedure". primvars.mo:Expected error in mat make-parameter: "+: a is not a number". primvars.mo:Expected error in mat make-parameter: "incorrect number of arguments 1 to #<procedure>". @@ -37,7 +37,7 @@ primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: -1 is not a positive fixnum". primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: 0 is not a positive fixnum". *************** -*** 101,171 **** +*** 103,173 **** primvars.mo:Expected error in mat print-radix: "print-radix: 1 is not between 2 and 36". primvars.mo:Expected error in mat timer-interrupt-handler: "timer-interrupt-handler: midnight is not a procedure". primvars.mo:Expected error in mat trace-output-port: "trace-output-port: #<input port string> is not a textual output port". @@ -109,7 +109,7 @@ 3.mo:Expected error in mat let: "incorrect argument count in call ((lambda (x . r) (eq? x (...))))". 3.mo:Expected error in mat letrec: "variable f is not bound". 3.mo:Expected error in mat letrec: "attempt to reference undefined variable a". ---- 101,171 ---- +--- 103,173 ---- primvars.mo:Expected error in mat print-radix: "print-radix: 1 is not between 2 and 36". primvars.mo:Expected error in mat timer-interrupt-handler: "timer-interrupt-handler: midnight is not a procedure". primvars.mo:Expected error in mat trace-output-port: "trace-output-port: #<input port string> is not a textual output port". @@ -182,7 +182,7 @@ 3.mo:Expected error in mat letrec: "variable f is not bound". 3.mo:Expected error in mat letrec: "attempt to reference undefined variable a". *************** -*** 7424,7430 **** +*** 7466,7472 **** 7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for testfile-mc-1a.ss: no such file or directory 7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: file "testfile-mc-1a.ss" not found in source directories 7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for ./testfile-mc-3a.ss: no such file or directory @@ -190,7 +190,7 @@ 7.mo:Expected error in mat eval: "interpret: 7 is not an environment". 7.mo:Expected error in mat eval: "compile: 7 is not an environment". 7.mo:Expected error in mat expand: "sc-expand: 7 is not an environment". ---- 7424,7430 ---- +--- 7466,7472 ---- 7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for testfile-mc-1a.ss: no such file or directory 7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: file "testfile-mc-1a.ss" not found in source directories 7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for ./testfile-mc-3a.ss: no such file or directory @@ -199,7 +199,7 @@ 7.mo:Expected error in mat eval: "compile: 7 is not an environment". 7.mo:Expected error in mat expand: "sc-expand: 7 is not an environment". *************** -*** 7612,7619 **** +*** 7666,7673 **** 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu". 7.mo:Expected error in mat error: "a: hit me!". 7.mo:Expected error in mat error: "f: n is 0". @@ -208,7 +208,7 @@ record.mo:Expected error in mat record2: "invalid value 3 for foreign type double-float". record.mo:Expected error in mat record2: "3 is not of type #<record type fudge>". record.mo:Expected error in mat record2: "make-record-type: invalid field list ((immutable double-float a) . b)". ---- 7612,7619 ---- +--- 7666,7673 ---- 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu". 7.mo:Expected error in mat error: "a: hit me!". 7.mo:Expected error in mat error: "f: n is 0". @@ -218,7 +218,7 @@ record.mo:Expected error in mat record2: "3 is not of type #<record type fudge>". record.mo:Expected error in mat record2: "make-record-type: invalid field list ((immutable double-float a) . b)". *************** -*** 7621,7635 **** +*** 7675,7689 **** record.mo:Expected error in mat type-descriptor: "invalid syntax (type-descriptor 3)". record.mo:Expected error in mat type-descriptor: "type-descriptor: unrecognized record car". record.mo:Expected error in mat record3: "variable set-fudge-a! is not bound". @@ -234,7 +234,7 @@ record.mo:Expected error in mat record9: "record-reader: invalid input #f". record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge". record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge". ---- 7621,7635 ---- +--- 7675,7689 ---- record.mo:Expected error in mat type-descriptor: "invalid syntax (type-descriptor 3)". record.mo:Expected error in mat type-descriptor: "type-descriptor: unrecognized record car". record.mo:Expected error in mat record3: "variable set-fudge-a! is not bound". @@ -251,7 +251,7 @@ record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge". record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge". *************** -*** 7642,7667 **** +*** 7696,7721 **** record.mo:Expected error in mat record10: "read: unresolvable cycle constructing record of type #<record type bar> at char 3 of #<input port string>". record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>". record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>". @@ -278,7 +278,7 @@ record.mo:Expected error in mat foreign-data: "foreign-alloc: 0 is not a positive fixnum". record.mo:Expected error in mat foreign-data: "foreign-alloc: <int> is not a positive fixnum". record.mo:Expected error in mat foreign-data: "foreign-alloc: -5 is not a positive fixnum". ---- 7642,7667 ---- +--- 7696,7721 ---- record.mo:Expected error in mat record10: "read: unresolvable cycle constructing record of type #<record type bar> at char 3 of #<input port string>". record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>". record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>". @@ -306,7 +306,7 @@ record.mo:Expected error in mat foreign-data: "foreign-alloc: <int> is not a positive fixnum". record.mo:Expected error in mat foreign-data: "foreign-alloc: -5 is not a positive fixnum". *************** -*** 7792,7830 **** +*** 7846,7884 **** record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)". record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)". record.mo:Expected error in mat record23: "make-record-type: cannot extend sealed record type #<record type foo>". @@ -346,7 +346,7 @@ record.mo:Expected error in mat record?: "record?: 4 is not a record type descriptor". record.mo:Expected error in mat record?: "record?: a is not a record type descriptor". record.mo:Expected error in mat record?: "record?: #(1) is not a record type descriptor". ---- 7792,7830 ---- +--- 7846,7884 ---- record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)". record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)". record.mo:Expected error in mat record23: "make-record-type: cannot extend sealed record type #<record type foo>". @@ -387,7 +387,7 @@ record.mo:Expected error in mat record?: "record?: a is not a record type descriptor". record.mo:Expected error in mat record?: "record?: #(1) is not a record type descriptor". *************** -*** 7839,7895 **** +*** 7893,7949 **** record.mo:Expected error in mat r6rs-records-procedural: "make-record-constructor-descriptor: invalid protocol flimflam". record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure not-a-procedure". record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure spam". @@ -445,7 +445,7 @@ record.mo:Expected error in mat r6rs-records-syntactic: "define-record-type: incompatible record type cpoint - different parent". record.mo:Expected error in mat r6rs-records-syntactic: "define-record-type: incompatible record type cpoint - different parent". record.mo:Expected error in mat r6rs-records-syntactic: "cannot extend define-record-type parent fratrat". ---- 7839,7895 ---- +--- 7893,7949 ---- record.mo:Expected error in mat r6rs-records-procedural: "make-record-constructor-descriptor: invalid protocol flimflam". record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure not-a-procedure". record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure spam". @@ -504,9 +504,9 @@ record.mo:Expected error in mat r6rs-records-syntactic: "define-record-type: incompatible record type cpoint - different parent". record.mo:Expected error in mat r6rs-records-syntactic: "cannot extend define-record-type parent fratrat". *************** -*** 9089,9101 **** - fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum". - fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum". +*** 9167,9179 **** + fx.mo:Expected error in mat fx-/wraparound: "fx-: <-int> is not a fixnum". + fx.mo:Expected error in mat fx-/wraparound: "fx-: <-int> is not a fixnum". fx.mo:Expected error in mat fx*: "fx*: (a . b) is not a fixnum". ! fx.mo:Expected error in mat fx*: "fx*: fixnum overflow with arguments <int> and 2". fx.mo:Expected error in mat fx*: "fx*: <int> is not a fixnum". @@ -518,9 +518,9 @@ fx.mo:Expected error in mat r6rs:fx*: "fx*: <int> is not a fixnum". fx.mo:Expected error in mat r6rs:fx*: "fx*: <-int> is not a fixnum". fx.mo:Expected error in mat r6rs:fx*: "fx*: #f is not a fixnum". ---- 9089,9101 ---- - fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum". - fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum". +--- 9167,9179 ---- + fx.mo:Expected error in mat fx-/wraparound: "fx-: <-int> is not a fixnum". + fx.mo:Expected error in mat fx-/wraparound: "fx-: <-int> is not a fixnum". fx.mo:Expected error in mat fx*: "fx*: (a . b) is not a fixnum". ! fx.mo:Expected error in mat fx*: "fx*: fixnum overflow computing (fx* <int> 2)". fx.mo:Expected error in mat fx*: "fx*: <int> is not a fixnum". @@ -533,7 +533,7 @@ fx.mo:Expected error in mat r6rs:fx*: "fx*: <-int> is not a fixnum". fx.mo:Expected error in mat r6rs:fx*: "fx*: #f is not a fixnum". *************** -*** 10585,10594 **** +*** 10683,10692 **** exceptions.mo:Expected error in mat assert: "failed assertion (memq (quote b) (quote (1 2 a 3 4)))". exceptions.mo:Expected error in mat assert: "failed assertion (q ...)". exceptions.mo:Expected error in mat assert: "failed assertion (andmap symbol? (syntax (x ...)))". @@ -544,7 +544,7 @@ oop.mo:Expected error in mat oop: "m1: not applicable to 17". oop.mo:Expected error in mat oop: "variable <a>-x1 is not bound". oop.mo:Expected error in mat oop: "variable <a>-x1-set! is not bound". ---- 10585,10594 ---- +--- 10683,10692 ---- exceptions.mo:Expected error in mat assert: "failed assertion (memq (quote b) (quote (1 2 a 3 4)))". exceptions.mo:Expected error in mat assert: "failed assertion (q ...)". exceptions.mo:Expected error in mat assert: "failed assertion (andmap symbol? (syntax (x ...)))". diff --git a/src/ChezScheme/mats/patch-interpret-2-f-f-f b/src/ChezScheme/mats/patch-interpret-2-f-f-f index 508883ff79..fdd7ea379a 100644 --- a/src/ChezScheme/mats/patch-interpret-2-f-f-f +++ b/src/ChezScheme/mats/patch-interpret-2-f-f-f @@ -170,30 +170,30 @@ 3.mo:Expected error in mat letrec: "attempt to reference undefined variable a". *************** *** 191,202 **** - 3.mo:Expected error in mat mrvs: "returned three values to single value return context". - 3.mo:Expected error in mat mrvs: "returned three values to single value return context". - 3.mo:Expected error in mat mrvs: "returned zero values to single value return context". + 3.mo:Expected error in mat mrvs: "returned 3 values to single value return context". + 3.mo:Expected error in mat mrvs: "returned 3 values to single value return context". + 3.mo:Expected error in mat mrvs: "returned 0 values to single value return context". ! 3.mo:Expected error in mat mrvs: "incorrect number of values received in multiple value context". -! 3.mo:Expected error in mat mrvs: "returned zero values to single value return context". +! 3.mo:Expected error in mat mrvs: "returned 0 values to single value return context". ! 3.mo:Expected error in mat mrvs: "incorrect number of values received in multiple value context". ! 3.mo:Expected error in mat mrvs: "incorrect number of values received in multiple value context". 3.mo:Expected error in mat mrvs: "variable $mrvs-foo is not bound". ! 3.mo:Expected error in mat mrvs: "attempt to apply non-procedure 17". - 3.mo:Expected error in mat mrvs: "returned two values to single value return context". - 3.mo:Expected error in mat mrvs: "returned two values to single value return context". + 3.mo:Expected error in mat mrvs: "returned 2 values to single value return context". + 3.mo:Expected error in mat mrvs: "returned 2 values to single value return context". 3.mo:Expected error in mat mrvs: "cdr: a is not a pair". --- 197,208 ---- - 3.mo:Expected error in mat mrvs: "returned three values to single value return context". - 3.mo:Expected error in mat mrvs: "returned three values to single value return context". - 3.mo:Expected error in mat mrvs: "returned zero values to single value return context". + 3.mo:Expected error in mat mrvs: "returned 3 values to single value return context". + 3.mo:Expected error in mat mrvs: "returned 3 values to single value return context". + 3.mo:Expected error in mat mrvs: "returned 0 values to single value return context". ! 3.mo:Expected error in mat mrvs: "incorrect number of arguments to #<procedure>". ! 3.mo:Expected error in mat mrvs: "incorrect number of arguments to #<procedure>". ! 3.mo:Expected error in mat mrvs: "incorrect number of arguments to #<procedure>". ! 3.mo:Expected error in mat mrvs: "incorrect number of arguments to #<procedure>". 3.mo:Expected error in mat mrvs: "variable $mrvs-foo is not bound". ! 3.mo:Expected error in mat mrvs: "call-with-values: 17 is not a procedure". - 3.mo:Expected error in mat mrvs: "returned two values to single value return context". - 3.mo:Expected error in mat mrvs: "returned two values to single value return context". + 3.mo:Expected error in mat mrvs: "returned 2 values to single value return context". + 3.mo:Expected error in mat mrvs: "returned 2 values to single value return context". 3.mo:Expected error in mat mrvs: "cdr: a is not a pair". *************** *** 4004,4019 **** diff --git a/src/ChezScheme/mats/primvars.ms b/src/ChezScheme/mats/primvars.ms index fa2bd042a5..f51d6ef35d 100644 --- a/src/ChezScheme/mats/primvars.ms +++ b/src/ChezScheme/mats/primvars.ms @@ -395,6 +395,7 @@ [(environment) *env '((a . b)) #f] [(eq-hashtable) *eq-hashtable *symbol-hashtable #f] [(exact-integer) (- (most-negative-fixnum) 1) 2.0 1/2 #f] + [(exact-uinteger) (+ (most-positive-fixnum) 1) -10 2.0 1/2 #f] [(exception-state) (current-exception-state) 0 #f] [(eof/char) #\a 0 #f] [(eof/u8) 0 -1 (expt 2 8) "a" #f] @@ -404,6 +405,7 @@ [(flonum) 0.0 0 0.0+1.0i 'a #f] [(ftype-pointer) *ftype-pointer 0 *time #f] [(fxvector) '#vfx(0) "a" #f] + [(flvector) '#vfl(0.0) "a" #f] [(gensym) *genny 'sym #f] [(guardian) (make-guardian) values "oops" #f] [(hashtable) *eq-hashtable '((a . b)) #f] diff --git a/src/ChezScheme/mats/record.ms b/src/ChezScheme/mats/record.ms index c6acf9e8c9..739af5ccc1 100644 --- a/src/ChezScheme/mats/record.ms +++ b/src/ChezScheme/mats/record.ms @@ -5362,9 +5362,8 @@ r))) (#2%pretty-print ($record->vector - (let ([r (let ([r (#3%$record crtd 2 7 1)]) - (#2%pretty-print (#2%list 'parent ($record->vector r))) - r)]) + (let ([r (#3%$record crtd 2 7 1)]) + (#2%pretty-print (#2%list 'parent ($record->vector r))) (#2%pretty-print (#2%list 'child ($record->vector r))) r))))))) (equivalent-expansion? ; optimize-level 3 expansion of above @@ -5403,9 +5402,8 @@ r))) (#3%pretty-print ($record->vector - (let ([r (let ([r (#3%$record crtd 2 7 1)]) - (#3%pretty-print (#3%list 'parent ($record->vector r))) - r)]) + (let ([r (#3%$record crtd 2 7 1)]) + (#3%pretty-print (#3%list 'parent ($record->vector r))) (#3%pretty-print (#3%list 'child ($record->vector r))) r))))))) (equal? @@ -5504,18 +5502,15 @@ r))) (#2%pretty-print ($record->vector - (let ([r (let ([r (#3%$record crtd 2 7 1)]) - (#2%pretty-print (#2%list 'parent ($record->vector r))) - r)]) + (let ([r (#3%$record crtd 2 7 1)]) + (#2%pretty-print (#2%list 'parent ($record->vector r))) (#2%pretty-print (#2%list 'child ($record->vector r))) r))) (#2%pretty-print ($record->vector - (let ([r (let ([r (let ([r (#3%$record gcrtd 2 10 4 3)]) - (#2%pretty-print (#2%list 'parent ($record->vector r))) - r)]) - (#2%pretty-print (#2%list 'child ($record->vector r))) - r)]) + (let ([r (#3%$record gcrtd 2 10 4 3)]) + (#2%pretty-print (#2%list 'parent ($record->vector r))) + (#2%pretty-print (#2%list 'child ($record->vector r))) (#2%pretty-print (#2%list 'grand-child ($record->vector r))) r)))))))) (equivalent-expansion? ; optimize-level 3 expansion of above @@ -5566,18 +5561,15 @@ r))) (#3%pretty-print ($record->vector - (let ([r (let ([r (#3%$record crtd 2 7 1)]) - (#3%pretty-print (#3%list 'parent ($record->vector r))) - r)]) + (let ([r (#3%$record crtd 2 7 1)]) + (#3%pretty-print (#3%list 'parent ($record->vector r))) (#3%pretty-print (#3%list 'child ($record->vector r))) r))) (#3%pretty-print ($record->vector - (let ([r (let ([r (let ([r (#3%$record gcrtd 2 10 4 3)]) - (#3%pretty-print (#3%list 'parent ($record->vector r))) - r)]) - (#3%pretty-print (#3%list 'child ($record->vector r))) - r)]) + (let ([r (#3%$record gcrtd 2 10 4 3)]) + (#3%pretty-print (#3%list 'parent ($record->vector r))) + (#3%pretty-print (#3%list 'child ($record->vector r))) (#3%pretty-print (#3%list 'grand-child ($record->vector r))) r)))))))) (error? ; given prcd is not for parent rtd @@ -7602,12 +7594,15 @@ (#3%$record-oops 'moi g63 ',record-type-descriptor?)) (#3%$object-set! 'scheme-object g63 ,fixnum? g64))) - (#2%equal? - (#2%map - (lambda (x) (if (#2%$record? x) ($record->vector x) x)) - (let ([x ($make-cpoint 3 4 ($color->rgb 'red))]) - (#2%list x ($cpoint-rgb x) ($make-point -8 -15)))) - '(#4($cpoint 3 4 (rgb . red)) (rgb . red) #3($point -8 -15))))) + (let ([x ($make-cpoint 3 4 ($color->rgb 'red))]) + (#2%equal? + (let ([g0 ($cpoint-rgb x)] + [g1 ($make-point -8 -15)]) + (#2%list + (if (#2%$record? x) ($record->vector x) x) + (if (#2%$record? g0) ($record->vector g0) g0) + (if (#2%$record? g1) ($record->vector g1) g1))) + '(#4($cpoint 3 4 (rgb . red)) (rgb . red) #3($point -8 -15)))))) (equivalent-expansion? ; optimize-level 3 expansion of above (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) (expand/optimize @@ -7648,12 +7643,15 @@ (set! $cpoint-rgb-set! (lambda (g99 g100) (#3%$object-set! 'scheme-object g99 ,fixnum? g100))) - (#3%equal? - (#3%map - (lambda (x) (if (#3%$record? x) ($record->vector x) x)) - (let ([x ($make-cpoint 3 4 ($color->rgb 'red))]) - (#3%list x ($cpoint-rgb x) ($make-point -8 -15)))) - '(#4($cpoint 3 4 (rgb . red)) (rgb . red) #3($point -8 -15))))) + (let ([x ($make-cpoint 3 4 ($color->rgb 'red))]) + (#3%equal? + (let ([g0 ($cpoint-rgb x)] + [g1 ($make-point -8 -15)]) + (#3%list + (if (#3%$record? x) ($record->vector x) x) + (if (#3%$record? g0) ($record->vector g0) g0) + (if (#3%$record? g1) ($record->vector g1) g1))) + '(#4($cpoint 3 4 (rgb . red)) (rgb . red) #3($point -8 -15)))))) (begin ; test global define-record-type (define ($color->rgb c) (cons 'rgb c)) @@ -7740,12 +7738,15 @@ (#3%$record-oops 'moi g147 ',record-type-descriptor?)) (#3%$object-set! 'scheme-object g147 ,fixnum? g148))) - (#2%equal? - (#2%map - (lambda (x) (if (#2%$record? x) ($record->vector x) x)) - (let ([x ($make-cpoint 3 4 'red)]) - (#2%list x ($cpoint-rgb x) ($make-point -8 -15)))) - '(#4($cpoint 3 4 (rgb . red)) (rgb . red) #3($point -8 -15))))) + (let ([x ($make-cpoint 3 4 'red)]) + (#2%equal? + (let ([g0 ($cpoint-rgb x)] + [g1 ($make-point -8 -15)]) + (#2%list + (if (#2%$record? x) ($record->vector x) x) + (if (#2%$record? g0) ($record->vector g0) g0) + (if (#2%$record? g1) ($record->vector g1) g1))) + '(#4($cpoint 3 4 (rgb . red)) (rgb . red) #3($point -8 -15)))))) (equivalent-expansion? ; optimize-level 3 expansion of above (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) (expand/optimize @@ -7796,12 +7797,15 @@ (set! $cpoint-rgb-set! (lambda (g123 g124) (#3%$object-set! 'scheme-object g123 ,fixnum? g124))) - (#3%equal? - (#3%map - (lambda (x) (if (#3%$record? x) ($record->vector x) x)) - (let ([x ($make-cpoint 3 4 'red)]) - (#3%list x ($cpoint-rgb x) ($make-point -8 -15)))) - '(#4($cpoint 3 4 (rgb . red)) (rgb . red) #3($point -8 -15))))) + (let ([x ($make-cpoint 3 4 'red)]) + (#3%equal? + (let ([g0 ($cpoint-rgb x)] + [g1 ($make-point -8 -15)]) + (#3%list + (if (#3%$record? x) ($record->vector x) x) + (if (#3%$record? g0) ($record->vector g0) g0) + (if (#3%$record? g1) ($record->vector g1) g1))) + '(#4($cpoint 3 4 (rgb . red)) (rgb . red) #3($point -8 -15)))))) (error? ; can't handle define-record-type parent (let () (define-record-type fratrat) @@ -9187,3 +9191,31 @@ (#2%display 4) 1))))) ) + +(mat cp0-$record-ref + (equivalent-expansion? + (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) + (expand/optimize + '(let () + (define A (make-record-type-descriptor* 'A #f #f #f #f 2 0)) + (define x ((record-constructor A) (begin (display A) 1) (begin (display 0 +) 2))) + (+ (#3%$record-ref x 0) (#3%$record-ref x 1))))) + '(let ([a (#2%make-record-type-descriptor* 'A #f #f #f #f 2 0)]) + (#2%display 0) + (#2%display a) + 3)) + ) + +(mat cp0-record? + (equivalent-expansion? + (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) + (expand/optimize + '(let () + (define A (make-record-type-descriptor* 'A #f #f #f #f 2 0)) + (define-record B (a b)) + (record? ((record-constructor A) 1 2) (record-type-descriptor B))))) + '(begin + (#2%make-record-type-descriptor* 'A #f #f #f #f 2 0) + #f)) +) diff --git a/src/ChezScheme/mats/root-experr-compile-0-f-f-f b/src/ChezScheme/mats/root-experr-compile-0-f-f-f index 62a1738006..35b7e117cc 100644 --- a/src/ChezScheme/mats/root-experr-compile-0-f-f-f +++ b/src/ChezScheme/mats/root-experr-compile-0-f-f-f @@ -262,18 +262,18 @@ primvars.mo:Expected error in mat trace-output-port: "trace-output-port: #<input 3.mo:Expected error in mat define-values: "duplicate variable in define-values left-hand side (x . x)". 3.mo:Expected error in mat define-values: "define-values: incorrect number of values from rhs (values)". 3.mo:Expected error in mat define-values: "duplicate variable in define-values left-hand side ($dv-foo2-x . $dv-foo2-x)". -3.mo:Expected error in mat mrvs: "returned zero values to single value return context". -3.mo:Expected error in mat mrvs: "returned three values to single value return context". -3.mo:Expected error in mat mrvs: "returned three values to single value return context". -3.mo:Expected error in mat mrvs: "returned zero values to single value return context". +3.mo:Expected error in mat mrvs: "returned 0 values to single value return context". +3.mo:Expected error in mat mrvs: "returned 3 values to single value return context". +3.mo:Expected error in mat mrvs: "returned 3 values to single value return context". +3.mo:Expected error in mat mrvs: "returned 0 values to single value return context". 3.mo:Expected error in mat mrvs: "incorrect number of values received in multiple value context". -3.mo:Expected error in mat mrvs: "returned zero values to single value return context". +3.mo:Expected error in mat mrvs: "returned 0 values to single value return context". 3.mo:Expected error in mat mrvs: "incorrect number of values received in multiple value context". 3.mo:Expected error in mat mrvs: "incorrect number of values received in multiple value context". 3.mo:Expected error in mat mrvs: "variable $mrvs-foo is not bound". 3.mo:Expected error in mat mrvs: "attempt to apply non-procedure 17". -3.mo:Expected error in mat mrvs: "returned two values to single value return context". -3.mo:Expected error in mat mrvs: "returned two values to single value return context". +3.mo:Expected error in mat mrvs: "returned 2 values to single value return context". +3.mo:Expected error in mat mrvs: "returned 2 values to single value return context". 3.mo:Expected error in mat mrvs: "cdr: a is not a pair". 3.mo:Expected error in mat let-values: "invalid syntax (let-values)". 3.mo:Expected error in mat let-values: "invalid syntax (let-values ((x)))". @@ -4234,11 +4234,11 @@ cp0.mo:Expected error in mat expand/optimize-output: "expand/optimize-output: #< 5_6.mo:Expected error in mat fxvector-set!: "fxvector-set!: -1 is not a valid index for #vfx(3 4 5)". 5_6.mo:Expected error in mat fxvector-set!: "fxvector-set!: a is not a valid index for #vfx(3 4 5)". 5_6.mo:Expected error in mat fxvector-set!: "fxvector-set!: d is not a fixnum". -5_6.mo:Expected error in mat fxvector-set!: "fxvector-set!: (3 4 5) is not a mutable fxvector". +5_6.mo:Expected error in mat fxvector-set!: "fxvector-set!: (3 4 5) is not an fxvector". 5_6.mo:Expected error in mat fxvector-set!: "fxvector-set!: <-int> is not a fixnum". 5_6.mo:Expected error in mat fxvector-set!: "fxvector-set!: <int> is not a fixnum". -5_6.mo:Expected error in mat fxvector-set!: "fxvector-set!: (3 4 5) is not a mutable fxvector". -5_6.mo:Expected error in mat fxvector-set!: "fxvector-set!: #(3 4) is not a mutable fxvector". +5_6.mo:Expected error in mat fxvector-set!: "fxvector-set!: (3 4 5) is not an fxvector". +5_6.mo:Expected error in mat fxvector-set!: "fxvector-set!: #(3 4) is not an fxvector". 5_6.mo:Expected error in mat fxvector-set!: "fxvector-set!: 3 is not a valid index for #vfx(3 4 5)". 5_6.mo:Expected error in mat fxvector-set!: "fxvector-set!: -3 is not a valid index for #vfx(3 4 5)". 5_6.mo:Expected error in mat fxvector-set!: "fxvector-set!: <int> is not a valid index for #vfx(3 4 5)". @@ -4249,11 +4249,46 @@ cp0.mo:Expected error in mat expand/optimize-output: "expand/optimize-output: #< 5_6.mo:Expected error in mat fxvector-set!: "fxvector-set!: a is not a fixnum". 5_6.mo:Expected error in mat fxvector-copy: "fxvector-copy: (a b c) is not an fxvector". 5_6.mo:Expected error in mat fxvector-fill!: "fxvector-fill!: a is not a fixnum". -5_6.mo:Expected error in mat fxvector-fill!: "fxvector-fill!: #(1) is not a mutable fxvector". +5_6.mo:Expected error in mat fxvector-fill!: "fxvector-fill!: #(1) is not a fxvector". 5_6.mo:Expected error in mat list->fxvector: "list->fxvector: #(a b c) is not a proper list". 5_6.mo:Expected error in mat list->fxvector: "list->fxvector: (1 2 . 3) is not a proper list". 5_6.mo:Expected error in mat list->fxvector: "list->fxvector: (1 2 3 2 3 2 ...) is circular". 5_6.mo:Expected error in mat fxvector->list: "fxvector->list: (a b c) is not an fxvector". +5_6.mo:Expected error in mat flvector: "flvector: 1 is not a flonum". +5_6.mo:Expected error in mat flvector: "flvector: a is not a flonum". +5_6.mo:Expected error in mat flvector: "flvector: a is not a flonum". +5_6.mo:Expected error in mat make-flvector: "make-flvector: a is not a flonum". +5_6.mo:Expected error in mat make-flvector: "make-flvector: 1 is not a flonum". +5_6.mo:Expected error in mat make-flvector: "make-flvector: a is not a flonum". +5_6.mo:Expected error in mat flvector-length: "flvector-length: (a b c) is not an flvector". +5_6.mo:Expected error in mat flvector-ref: "flvector-ref: 3 is not a valid index for #vfl(3.0 4.0 5.0)". +5_6.mo:Expected error in mat flvector-ref: "flvector-ref: -1 is not a valid index for #vfl(3.0 4.0 5.0)". +5_6.mo:Expected error in mat flvector-ref: "flvector-ref: a is not a valid index for #vfl(3.0 4.0 5.0)". +5_6.mo:Expected error in mat flvector-ref: "flvector-ref: #(3.0 4.0 5.0) is not an flvector". +5_6.mo:Expected error in mat flvector-ref: "flvector-ref: (3.0 4.0 5.0) is not an flvector". +5_6.mo:Expected error in mat flvector-set!: "flvector-set!: 3 is not a valid index for #vfl(3.0 4.0 5.0)". +5_6.mo:Expected error in mat flvector-set!: "flvector-set!: -1 is not a valid index for #vfl(3.0 4.0 5.0)". +5_6.mo:Expected error in mat flvector-set!: "flvector-set!: a is not a valid index for #vfl(3.0 4.0 5.0)". +5_6.mo:Expected error in mat flvector-set!: "flvector-set!: d is not a flonum". +5_6.mo:Expected error in mat flvector-set!: "flvector-set!: (3.0 4.0 5.0) is not an flvector". +5_6.mo:Expected error in mat flvector-set!: "flvector-set!: 1 is not a flonum". +5_6.mo:Expected error in mat flvector-set!: "flvector-set!: a is not a flonum". +5_6.mo:Expected error in mat flvector-set!: "flvector-set!: (3.0 4.0 5.0) is not an flvector". +5_6.mo:Expected error in mat flvector-set!: "flvector-set!: #(3.0 4.0) is not an flvector". +5_6.mo:Expected error in mat flvector-set!: "flvector-set!: 3 is not a valid index for #vfl(3.0 4.0 5.0)". +5_6.mo:Expected error in mat flvector-set!: "flvector-set!: -3 is not a valid index for #vfl(3.0 4.0 5.0)". +5_6.mo:Expected error in mat flvector-set!: "flvector-set!: <int> is not a valid index for #vfl(3.0 4.0 5.0)". +5_6.mo:Expected error in mat flvector-set!: "flvector-set!: <-int> is not a valid index for #vfl(3.0 4.0 5.0)". +5_6.mo:Expected error in mat flvector-set!: "flvector-set!: a is not a valid index for #vfl(3.0 4.0 5.0)". +5_6.mo:Expected error in mat flvector-set!: "flvector-set!: 1 is not a flonum". +5_6.mo:Expected error in mat flvector-set!: "flvector-set!: a is not a flonum". +5_6.mo:Expected error in mat flvector-copy: "flvector-copy: (a b c) is not an flvector". +5_6.mo:Expected error in mat flvector-fill!: "flvector-fill!: a is not a flonum". +5_6.mo:Expected error in mat flvector-fill!: "flvector-fill!: #(1.0) is not a flvector". +5_6.mo:Expected error in mat list->flvector: "list->flvector: #(a b c) is not a proper list". +5_6.mo:Expected error in mat list->flvector: "list->flvector: (1.0 2.0 . 3.0) is not a proper list". +5_6.mo:Expected error in mat list->flvector: "list->flvector: (1.0 2.0 3.0 2.0 3.0 2.0 ...) is circular". +5_6.mo:Expected error in mat flvector->list: "flvector->list: (a b c) is not an flvector". 5_6.mo:Expected error in mat vector-map: "incorrect argument count in call (vector-map)". 5_6.mo:Expected error in mat vector-map: "incorrect argument count in call (vector-map (quote #()))". 5_6.mo:Expected error in mat vector-map: "incorrect argument count in call (vector-map +)". @@ -4308,8 +4343,6 @@ cp0.mo:Expected error in mat expand/optimize-output: "expand/optimize-output: #< 5_6.mo:Expected error in mat vector->immutable-vector: "vector-set-fixnum!: #(1 2 3) is not a mutable vector". 5_6.mo:Expected error in mat vector->immutable-vector: "vector-fill!: #(1 2 3) is not a mutable vector". 5_6.mo:Expected error in mat vector->immutable-vector: "vector-sort!: #(1 2 3) is not a mutable vector". -5_6.mo:Expected error in mat fxvector->immutable-fxvector: "fxvector-set!: #vfx(1 2 3) is not a mutable fxvector". -5_6.mo:Expected error in mat fxvector->immutable-fxvector: "fxvector-fill!: #vfx(1 2 3) is not a mutable fxvector". 5_6.mo:Expected error in mat vector-cas!: "incorrect argument count in call (vector-cas! vec1)". 5_6.mo:Expected error in mat vector-cas!: "incorrect argument count in call (vector-cas! vec1 1)". 5_6.mo:Expected error in mat vector-cas!: "incorrect argument count in call (vector-cas! vec1 1 2)". @@ -8211,6 +8244,22 @@ hash.mo:Expected error in mat generic-hashtable: "hashtable-clear!: #<hashtable> hash.mo:Expected error in mat generic-hashtable: "hashtable-delete!: #<hashtable> is not mutable". hash.mo:Expected error in mat generic-hashtable: "hashtable-update!: #<hashtable> is not mutable". hash.mo:Expected error in mat generic-hashtable: "hashtable-update!: #<hashtable> is not mutable". +hash.mo:Expected error in mat generic-hashtable-arguments: "incorrect argument count in call (make-weak-hashtable)". +hash.mo:Expected error in mat generic-hashtable-arguments: "incorrect argument count in call (make-weak-hashtable equal-hash)". +hash.mo:Expected error in mat generic-hashtable-arguments: "incorrect argument count in call (make-weak-hashtable equal-hash equal? 45 53)". +hash.mo:Expected error in mat generic-hashtable-arguments: "make-weak-hashtable: a is not a procedure". +hash.mo:Expected error in mat generic-hashtable-arguments: "make-weak-hashtable: a is not a procedure". +hash.mo:Expected error in mat generic-hashtable-arguments: "make-weak-hashtable: invalid size argument a". +hash.mo:Expected error in mat generic-hashtable-arguments: "make-weak-hashtable: invalid size argument -45". +hash.mo:Expected error in mat generic-hashtable-arguments: "make-weak-hashtable: invalid size argument 45.0". +hash.mo:Expected error in mat generic-hashtable-arguments: "incorrect argument count in call (make-ephemeron-hashtable)". +hash.mo:Expected error in mat generic-hashtable-arguments: "incorrect argument count in call (make-ephemeron-hashtable equal-hash)". +hash.mo:Expected error in mat generic-hashtable-arguments: "incorrect argument count in call (make-ephemeron-hashtable equal-hash equal? 45 53)". +hash.mo:Expected error in mat generic-hashtable-arguments: "make-ephemeron-hashtable: a is not a procedure". +hash.mo:Expected error in mat generic-hashtable-arguments: "make-ephemeron-hashtable: a is not a procedure". +hash.mo:Expected error in mat generic-hashtable-arguments: "make-ephemeron-hashtable: invalid size argument a". +hash.mo:Expected error in mat generic-hashtable-arguments: "make-ephemeron-hashtable: invalid size argument -45". +hash.mo:Expected error in mat generic-hashtable-arguments: "make-ephemeron-hashtable: invalid size argument 45.0". hash.mo:Expected error in mat hash-functions: "incorrect argument count in call (equal-hash)". hash.mo:Expected error in mat hash-functions: "incorrect argument count in call (equal-hash 0 0)". hash.mo:Expected error in mat hash-functions: "incorrect argument count in call (symbol-hash)". @@ -9095,6 +9144,11 @@ fx.mo:Expected error in mat r6rs:fx+: "fx+: <int> is not a fixnum". fx.mo:Expected error in mat r6rs:fx+: "fx+: <-int> is not a fixnum". fx.mo:Expected error in mat r6rs:fx+: "fx+: #f is not a fixnum". fx.mo:Expected error in mat r6rs:fx+: "fx+: #f is not a fixnum". +fx.mo:Expected error in mat fx+/wraparound: "fx+/wraparound: (a . b) is not a fixnum". +fx.mo:Expected error in mat fx+/wraparound: "fx+: <int> is not a fixnum". +fx.mo:Expected error in mat fx+/wraparound: "fx+: <int> is not a fixnum". +fx.mo:Expected error in mat fx+/wraparound: "fx+: <-int> is not a fixnum". +fx.mo:Expected error in mat fx+/wraparound: "fx+: <-int> is not a fixnum". fx.mo:Expected error in mat fx-: "fx-: (a . b) is not a fixnum". fx.mo:Expected error in mat fx-: "fx-: fixnum overflow with arguments <-int> and 1". fx.mo:Expected error in mat fx-: "fx-: <int> is not a fixnum". @@ -9107,6 +9161,11 @@ fx.mo:Expected error in mat r6rs:fx-: "fx-: <int> is not a fixnum". fx.mo:Expected error in mat r6rs:fx-: "fx-: <-int> is not a fixnum". fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum". fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum". +fx.mo:Expected error in mat fx-/wraparound: "fx-/wraparound: (a . b) is not a fixnum". +fx.mo:Expected error in mat fx-/wraparound: "fx-: <int> is not a fixnum". +fx.mo:Expected error in mat fx-/wraparound: "fx-: <int> is not a fixnum". +fx.mo:Expected error in mat fx-/wraparound: "fx-: <-int> is not a fixnum". +fx.mo:Expected error in mat fx-/wraparound: "fx-: <-int> is not a fixnum". fx.mo:Expected error in mat fx*: "fx*: (a . b) is not a fixnum". fx.mo:Expected error in mat fx*: "fx*: fixnum overflow with arguments <int> and 2". fx.mo:Expected error in mat fx*: "fx*: <int> is not a fixnum". @@ -9119,6 +9178,11 @@ fx.mo:Expected error in mat r6rs:fx*: "fx*: <int> is not a fixnum". fx.mo:Expected error in mat r6rs:fx*: "fx*: <-int> is not a fixnum". fx.mo:Expected error in mat r6rs:fx*: "fx*: #f is not a fixnum". fx.mo:Expected error in mat r6rs:fx*: "fx*: #f is not a fixnum". +fx.mo:Expected error in mat fx*/wraparound: "fx*/wraparound: (a . b) is not a fixnum". +fx.mo:Expected error in mat fx*/wraparound: "fx*: <int> is not a fixnum". +fx.mo:Expected error in mat fx*/wraparound: "fx*: <int> is not a fixnum". +fx.mo:Expected error in mat fx*/wraparound: "fx*: <-int> is not a fixnum". +fx.mo:Expected error in mat fx*/wraparound: "fx*: <-int> is not a fixnum". fx.mo:Expected error in mat fxquotient: "fxquotient: (a . b) is not a fixnum". fx.mo:Expected error in mat fxquotient: "fxquotient: attempt to divide by zero". fx.mo:Expected error in mat fxquotient: "fxquotient: <int> is not a fixnum". @@ -9239,6 +9303,14 @@ fx.mo:Expected error in mat fxarithmetic-shift-left: "fxarithmetic-shift-left: f fx.mo:Expected error in mat fxarithmetic-shift-left: "fxarithmetic-shift-left: fixnum overflow with arguments <int> and 10". fx.mo:Expected error in mat fxarithmetic-shift-left: "fxarithmetic-shift-left: fixnum overflow with arguments -4097 and <int>". fx.mo:Expected error in mat fxarithmetic-shift-left: "fxarithmetic-shift-left: fixnum overflow with arguments <-int> and 1". +fx.mo:Expected error in mat fsll/wraparound: "fxsll/wraparound: (a . b) is not a fixnum". +fx.mo:Expected error in mat fsll/wraparound: "fxsll/wraparound: invalid shift count -3". +fx.mo:Expected error in mat fsll/wraparound: "fxsll/wraparound: invalid shift count 1000". +fx.mo:Expected error in mat fsll/wraparound: "fxsll/wraparound: invalid shift count -1000". +fx.mo:Expected error in mat fsll/wraparound: "fxsll: <int> is not a fixnum". +fx.mo:Expected error in mat fsll/wraparound: "fxsll: <int> is not a fixnum". +fx.mo:Expected error in mat fsll/wraparound: "fxsll: <-int> is not a fixnum". +fx.mo:Expected error in mat fsll/wraparound: "fxsll: <-int> is not a fixnum". fx.mo:Expected error in mat fxsrl: "fxsrl: invalid shift count -1". fx.mo:Expected error in mat fxsrl: "fxsrl: invalid shift count <int>". fx.mo:Expected error in mat fxsrl: "fxsrl: a is not a fixnum". diff --git a/src/ChezScheme/mats/root-experr-compile-2-f-f-f b/src/ChezScheme/mats/root-experr-compile-2-f-f-f index 04b3c476ec..17de8fbe49 100644 --- a/src/ChezScheme/mats/root-experr-compile-2-f-f-f +++ b/src/ChezScheme/mats/root-experr-compile-2-f-f-f @@ -187,18 +187,18 @@ primvars.mo:Expected error in mat trace-output-port: "trace-output-port: #<input 3.mo:Expected error in mat define-values: "duplicate variable in define-values left-hand side (x . x)". 3.mo:Expected error in mat define-values: "define-values: incorrect number of values from rhs (values)". 3.mo:Expected error in mat define-values: "duplicate variable in define-values left-hand side ($dv-foo2-x . $dv-foo2-x)". -3.mo:Expected error in mat mrvs: "returned zero values to single value return context". -3.mo:Expected error in mat mrvs: "returned three values to single value return context". -3.mo:Expected error in mat mrvs: "returned three values to single value return context". -3.mo:Expected error in mat mrvs: "returned zero values to single value return context". +3.mo:Expected error in mat mrvs: "returned 0 values to single value return context". +3.mo:Expected error in mat mrvs: "returned 3 values to single value return context". +3.mo:Expected error in mat mrvs: "returned 3 values to single value return context". +3.mo:Expected error in mat mrvs: "returned 0 values to single value return context". 3.mo:Expected error in mat mrvs: "incorrect number of values received in multiple value context". -3.mo:Expected error in mat mrvs: "returned zero values to single value return context". +3.mo:Expected error in mat mrvs: "returned 0 values to single value return context". 3.mo:Expected error in mat mrvs: "incorrect number of values received in multiple value context". 3.mo:Expected error in mat mrvs: "incorrect number of values received in multiple value context". 3.mo:Expected error in mat mrvs: "variable $mrvs-foo is not bound". 3.mo:Expected error in mat mrvs: "attempt to apply non-procedure 17". -3.mo:Expected error in mat mrvs: "returned two values to single value return context". -3.mo:Expected error in mat mrvs: "returned two values to single value return context". +3.mo:Expected error in mat mrvs: "returned 2 values to single value return context". +3.mo:Expected error in mat mrvs: "returned 2 values to single value return context". 3.mo:Expected error in mat mrvs: "cdr: a is not a pair". 3.mo:Expected error in mat let-values: "invalid syntax (let-values)". 3.mo:Expected error in mat let-values: "invalid syntax (let-values ((x)))". diff --git a/src/ChezScheme/mats/thread.ms b/src/ChezScheme/mats/thread.ms index 3dd289679c..2eb9a52f44 100644 --- a/src/ChezScheme/mats/thread.ms +++ b/src/ChezScheme/mats/thread.ms @@ -932,7 +932,7 @@ (let ([thread-count 2] [iterations 10000]) (equal? (parameterize ([collect-trip-bytes (expt 2 15)] - [collect-generation-radix 1]) + [collect-generation-radix 2]) ; using 1 risks extreme slowness via major collections (let ([out '()] [out-mutex (make-mutex)] [out-condition (make-condition)] @@ -1438,7 +1438,9 @@ (if (odd? i) (let loop () (unless (ftype-lock! A (y) a) (printf "waiting\n") (loop))) (ftype-spin-lock! A (y) a)) + (memory-order-acquire) (ftype-set! A (x) a ((if (odd? n) + -) (ftype-ref A (x) a) 1.0)) + (memory-order-release) (ftype-unlock! A (y) a)))))) (let loop () (if (equal? (length ls) n) diff --git a/src/ChezScheme/rktboot/constant.rkt b/src/ChezScheme/rktboot/constant.rkt index 6d3edcc4af..45e7b183ee 100644 --- a/src/ChezScheme/rktboot/constant.rkt +++ b/src/ChezScheme/rktboot/constant.rkt @@ -86,7 +86,8 @@ prelex-was-flags-offset prelex-sticky-mask prelex-is-mask - scheme-version) + scheme-version + code-flag-lift-barrier) (provide record-ptr-offset) (define record-ptr-offset 1) diff --git a/src/ChezScheme/rktboot/make-boot.rkt b/src/ChezScheme/rktboot/make-boot.rkt index dc5240f296..3c559179c8 100644 --- a/src/ChezScheme/rktboot/make-boot.rkt +++ b/src/ChezScheme/rktboot/make-boot.rkt @@ -402,7 +402,6 @@ (eval `(mkgc-ocd.inc ,(path->string (build-path out-subdir "gc-ocd.inc")))) (eval `(mkgc-oce.inc ,(path->string (build-path out-subdir "gc-oce.inc")))) (eval `(mkgc-par.inc ,(path->string (build-path out-subdir "gc-par.inc")))) - (eval `(mkvfasl.inc ,(path->string (build-path out-subdir "vfasl.inc")))) (eval `(mkheapcheck.inc ,(path->string (build-path out-subdir "heapcheck.inc")))) (plumber-flush-all (current-plumber)))) diff --git a/src/ChezScheme/rktboot/r6rs-lang.rkt b/src/ChezScheme/rktboot/r6rs-lang.rkt index 89861e11f0..55161fb732 100644 --- a/src/ChezScheme/rktboot/r6rs-lang.rkt +++ b/src/ChezScheme/rktboot/r6rs-lang.rkt @@ -11,13 +11,13 @@ "gensym.rkt" "format.rkt" "syntax-mode.rkt" - "constant.rkt" "config.rkt" "rcd.rkt" (only-in "record.rkt" do-$make-record-type register-rtd-name! register-rtd-fields! + register-rtd-ancestors! s:struct-type? record-predicate record-accessor @@ -564,6 +564,7 @@ (install-protocol! struct:name name-protocol) (register-rtd-name! struct:name 'name) (register-rtd-fields! struct:name 'fields-vec) + (register-rtd-ancestors! struct:name super) (define make-name (name-protocol maker)) (define . getter) ... (define . setter) ...))))]))] @@ -798,18 +799,21 @@ (proc o) (get-output-bytes o)) -(define (fixnum-width) (or fixnum-bits 63)) +;; Note: fixnums here are compile-time fixnums, so "config.rkt" is not needed +(define 64-bit? (= (system-type 'word) 64)) + +(define (fixnum-width) (if (eq? 'racket (system-type 'vm)) + (if 64-bit? 63 31) + (if 64-bit? 61 30))) (define low-fixnum (- (expt 2 (sub1 (fixnum-width))))) (define high-fixnum (sub1 (expt 2 (sub1 (fixnum-width))))) +(define s:fixnum? fixnum?) + (define (most-positive-fixnum) high-fixnum) (define (most-negative-fixnum) low-fixnum) -(define (s:fixnum? x) - (and (fixnum? x) - (<= low-fixnum x high-fixnum))) - (define (make-compile-time-value v) v) (define optimize-level (make-parameter optimize-level-init)) diff --git a/src/ChezScheme/rktboot/record.rkt b/src/ChezScheme/rktboot/record.rkt index c88ed47556..d035382d80 100644 --- a/src/ChezScheme/rktboot/record.rkt +++ b/src/ChezScheme/rktboot/record.rkt @@ -11,6 +11,7 @@ (provide do-$make-record-type register-rtd-name! register-rtd-fields! + register-rtd-ancestors! s:struct-type? $make-record-type @@ -43,6 +44,22 @@ record-writer $object-ref) +;; Let there be records: this declaration is the root origin of +;; #!base-rtd. From this description, #!base-rtd gets fasled in a boot +;; file and loaded to define #!base-rtd on startup. The field offsets +;; below don't matter, since they're fixed up for the target plaform. +(define base-rtd-fields + (map vector-copy + '(#(fld ancestors #f scheme-object 9) + #(fld size #f scheme-object 17) + #(fld pm #f scheme-object 25) + #(fld mpm #f scheme-object 33) + #(fld name #f scheme-object 41) + #(fld flds #f scheme-object 49) + #(fld flags #f scheme-object 57) + #(fld uid #f scheme-object 65) + #(fld counts #f scheme-object 73)))) + (define (s:struct-type? v) (or (struct-type? v) (base-rtd? v))) @@ -83,6 +100,7 @@ (hash-set! rtd-extensions struct:name (apply (struct-type-make-constructor in-base-rtd) more))) (register-rtd-name! struct:name name) (register-rtd-fields! struct:name fields) + (register-rtd-ancestors! struct:name super) (when sealed? (hash-set! rtd-sealed?s struct:name #t)) (when (or opaque? (and super (hash-ref rtd-opaque?s super #f))) @@ -117,6 +135,20 @@ (define (register-rtd-name! struct:name name) (hash-set! rtd-names struct:name name)) +(define rtd-ancestors (make-weak-hasheq)) + +(define (register-rtd-ancestors! struct:name parent) + (unless (hash-ref rtd-ancestors struct:name #f) + (cond + [(not parent) + (hash-set! rtd-ancestors struct:name (vector #f))] + [(eq? parent struct:base-rtd-subtype) + (hash-set! rtd-ancestors struct:name (vector base-rtd #f))] + [else + (define p-vec (hash-ref rtd-ancestors parent)) + (define vec (make-vector (+ 1 (vector-length p-vec)) parent)) + (vector-copy! vec 1 p-vec) + (hash-set! rtd-ancestors struct:name vec)]))) (define rtd-fields (make-weak-hasheq)) @@ -244,18 +276,6 @@ (struct-type-info rtd)) (make-struct-field-mutator set i)))) -(define base-rtd-fields - (map vector-copy - '(#(fld parent #f scheme-object 9) - #(fld size #f scheme-object 17) - #(fld pm #f scheme-object 25) - #(fld mpm #f scheme-object 33) - #(fld name #f scheme-object 41) - #(fld flds #f scheme-object 49) - #(fld flags #f scheme-object 57) - #(fld uid #f scheme-object 65) - #(fld counts #f scheme-object 73)))) - ;; If `sym/i` is an integer, it *does* count parent fields (define (csv7:record-field-accessor/mutator rtd sym/i mut?) (define (lookup-field-by-name rtd sym) @@ -320,17 +340,22 @@ (if (base-rtd? rtd) null (hash-ref rtd-fields rtd)))))] - [(parent) + [(ancestors) (assert-accessor) (lambda (rtd) (cond - [(base-rtd? rtd) #f] + [(base-rtd? rtd) '#(#f)] [else + (define vec (hash-ref rtd-ancestors rtd)) (define-values (r-name init-cnt auto-cnt ref set immutables super skipped?) (struct-type-info rtd)) - (if (eq? super struct:base-rtd-subtype) - base-rtd - super)]))] + (define parent + (if (eq? super struct:base-rtd-subtype) + base-rtd + super)) + (unless (eq? parent (vector-ref vec 0)) + (error "ancestry sanity check failed" rtd vec parent)) + vec]))] [(size) (assert-accessor) (lambda (rtd) @@ -565,6 +590,15 @@ (case type [(unsigned-64) (integer-bytes->integer (real->floating-point-bytes v 8) #f)] + [(integer-64) + (integer-bytes->integer (real->floating-point-bytes v 8) #t)] + [(integer-32) + (define bstr (real->floating-point-bytes v 8)) + (case offset + [(6) (integer-bytes->integer bstr #t (system-big-endian?) 0 4)] + [(10) (integer-bytes->integer bstr #t (system-big-endian?) 4 8)] + [else + (error "unrecognized floating-point access" type offset)])] [else (error "unrecognized floating-point access" type offset)])] [else (unless (or (eq? type 'scheme-object) diff --git a/src/ChezScheme/rktboot/scheme-lang.rkt b/src/ChezScheme/rktboot/scheme-lang.rkt index 932ff97c75..17b34d5106 100644 --- a/src/ChezScheme/rktboot/scheme-lang.rkt +++ b/src/ChezScheme/rktboot/scheme-lang.rkt @@ -25,7 +25,10 @@ (only-in "r6rs-lang.rkt" make-record-constructor-descriptor set-car! - set-cdr!) + set-cdr! + fixnum-width + most-positive-fixnum + most-negative-fixnum) (submod "r6rs-lang.rkt" hash-pair) (for-syntax "scheme-struct.rkt" "rcd.rkt")) @@ -101,6 +104,7 @@ $compile-profile compile-profile $optimize-closures + $lift-closures $profile-block-data? run-cp0 generate-interrupt-trap @@ -110,6 +114,7 @@ debug-level scheme-version-number scheme-fork-version-number + native-endianness (rename-out [make-parameter $make-thread-parameter] [make-parameter make-thread-parameter] [cons make-binding] @@ -166,6 +171,7 @@ [bytes? bytevector?] [bytes-set! bytevector-u8-set!] [bytes-ref bytevector-u8-ref] + [bytes->immutable-bytes bytevector->immutable-bytevector] [bwp? bwp-object?] [number->string r6rs:number->string] [s:printf printf] @@ -175,6 +181,10 @@ [write-string display-string] [call/ec call/1cc] [s:string->symbol string->symbol]) + fx+/wraparound + fx-/wraparound + fx*/wraparound + fxsll/wraparound logbit? logbit1 logbit0 logtest (rename-out [logbit? fxlogbit?] [logbit1 fxlogbit1] @@ -261,7 +271,6 @@ immutable-string? immutable-vector? immutable-bytevector? - immutable-fxvector? immutable-box? require-nongenerative-clause generate-inspector-information @@ -324,7 +333,8 @@ priminfo-libraries $c-bufsiz $foreign-procedure - make-guardian) + make-guardian + $lambda/lift-barrier) (module+ callback (provide set-current-expand-set-callback!)) @@ -695,6 +705,7 @@ [(prelex-was-flags-offset) prelex-was-flags-offset] [(prelex-sticky-mask) prelex-sticky-mask] [(prelex-is-mask) prelex-is-mask] + [(code-flag-lift-barrier) code-flag-lift-barrier] [else (error 'constant "unknown: ~s" #'id)])])) (define $target-machine (make-parameter (string->symbol target-machine))) @@ -817,12 +828,31 @@ (if (and (v . fx< . 0) (amt . fx> . 0)) (bitwise-and (fxrshift v amt) - (- (fxlshift 1 (- fixnum-bits amt)) 1)) + (- (arithmetic-shift 1 (- (fixnum-width) amt)) 1)) (fxrshift v amt))) (define (fxbit-field fx1 fx2 fx3) (fxrshift (fxand fx1 (fxnot (fxlshift -1 fx3))) fx2)) +(define (wraparound v) + (cond + [(fixnum? v) + v] + [(zero? (bitwise-and v (add1 (most-positive-fixnum)))) + (bitwise-ior v (- -1 (most-positive-fixnum)))] + [else + (bitwise-and v (most-positive-fixnum))])) + +;; Re-implement wraparound so we can use Racket v7.9 and earlier: +(define (fx+/wraparound x y) + (wraparound (+ x y))) +(define (fx-/wraparound x y) + (wraparound (- x y))) +(define (fx*/wraparound x y) + (wraparound (* x y))) +(define (fxsll/wraparound x y) + (wraparound (arithmetic-shift x y))) + (define (bitwise-bit-count fx) (cond [(eqv? fx 0) 0] @@ -905,6 +935,7 @@ (define $compile-profile (make-parameter #f)) (define compile-profile $compile-profile) (define $optimize-closures (make-parameter #t)) +(define $lift-closures (make-parameter #t)) (define $profile-block-data? (make-parameter #f)) (define run-cp0 (make-parameter error)) (define generate-interrupt-trap (make-parameter #t)) @@ -929,6 +960,11 @@ (values maj min sub 0) (values maj min sub (bitwise-and 255 v)))) +(define (native-endianness) + (if (system-big-endian?) + 'big + 'little)) + (define (make-hashtable hash eql?) (cond [(eq? hash symbol-hash) @@ -1052,9 +1088,6 @@ (bytes? s) (immutable? s))) -(define (immutable-fxvector? s) - #f) - (define (immutable-box? s) (and any-immutable? (box? s) @@ -1258,3 +1291,7 @@ [() #f] [(v) (void)] [(v rep) (void)])) + +(define-syntax $lambda/lift-barrier + (syntax-rules () + [(_ fmls body ...) (lambda fmls body ...)])) diff --git a/src/ChezScheme/rktboot/scheme-readtable.rkt b/src/ChezScheme/rktboot/scheme-readtable.rkt index 476cbb9144..ead8eeb909 100644 --- a/src/ChezScheme/rktboot/scheme-readtable.rkt +++ b/src/ChezScheme/rktboot/scheme-readtable.rkt @@ -1,5 +1,6 @@ #lang racket/base (require racket/fixnum + racket/flonum racket/port "immediate.rkt" "gensym.rkt") @@ -136,9 +137,12 @@ (define l (read/recursive in)) (list->bytes l)] [(#\f) - (unless (eqv? #\x (read-char in)) (error 'hash-vee "not 8")) + (define t (read-char in)) + (unless (or (eqv? #\x t) (eqv? #\l t)) (error 'hash-vee "not x or l")) (define l (read/recursive in)) - (apply fxvector l)] + (if (eqv? #\x t) + (apply fxvector l) + (apply flvector l))] [else (error 'hash-vee "unexpected")])) (define (as-symbol c in src line col pos) diff --git a/src/ChezScheme/s/5_1.ss b/src/ChezScheme/s/5_1.ss index 4315602fc2..a630e595be 100644 --- a/src/ChezScheme/s/5_1.ss +++ b/src/ChezScheme/s/5_1.ss @@ -166,6 +166,14 @@ k (and (fx= (fxvector-ref x i) (fxvector-ref y i)) (f (fx1- i))))))] + [(flvector? x) + (and (flvector? y) + (fx= (flvector-length x) (flvector-length y)) + (let f ([i (fx- (flvector-length x) 1)]) + (if (fx< i 0) + k + (and ($fleqv? (flvector-ref x i) (flvector-ref y i)) + (f (fx1- i))))))] [(box? x) (and (box? y) (if (union-find ht x y) @@ -234,6 +242,14 @@ k (and (fx= (fxvector-ref x i) (fxvector-ref y i)) (f (fx1- i))))))] + [(flvector? x) + (and (flvector? y) + (fx= (flvector-length x) (flvector-length y)) + (let f ([i (fx- (flvector-length x) 1)]) + (if (fx< i 0) + k + (and ($fleqv? (flvector-ref x i) (flvector-ref y i)) + (f (fx1- i))))))] [(box? x) (and (box? y) (e? (unbox x) (unbox y) k))] [($record? x) (and ($record? y) @@ -303,6 +319,14 @@ k (and (fx= (fxvector-ref x i) (fxvector-ref y i)) (f (fx1- i))))))] + [(flvector? x) + (and (flvector? y) + (fx= (flvector-length x) (flvector-length y)) + (let f ([i (fx- (flvector-length x) 1)]) + (if (fx< i 0) + k + (and ($fleqv? (flvector-ref x i) (flvector-ref y i)) + (f (fx1- i))))))] [(box? x) (and (box? y) (if (fx<= k 0) diff --git a/src/ChezScheme/s/5_3.ss b/src/ChezScheme/s/5_3.ss index 04d8bc5681..35fe2e3462 100644 --- a/src/ChezScheme/s/5_3.ss +++ b/src/ChezScheme/s/5_3.ss @@ -1951,13 +1951,17 @@ [else (domain-error who y)]))) (set-who! remainder - (let ([f (lambda (x y) - (let ([r (- x (* (quotient x y) y))]) - ;;; filter out outrageous results - ;;; try (remainder 1e194 10.0) without this hack... - (if (if (negative? y) (> r y) (< r y)) - r - 0.0)))]) + (let* ([fmod (cflop2 "(cs)mod")] + [f (lambda (x y) + (cond + [(eqv? x 0) 0] + [else + (let ([r (fmod (real->flonum x) (real->flonum y))]) + (if (fl= r 0.0) + ;; Always return positive 0.0 --- not sure why, + ;; but Racket and other Schemes seem to agree + 0.0 + r))]))]) (lambda (x y) (type-case y [(fixnum?) @@ -2777,19 +2781,26 @@ (random-double s)] [(s x) (define (random-integer s x) - (modulo (let loop ([bits (integer-length x)]) - (cond - [(<= bits 0) 0] - [else (bitwise-ior (bitwise-arithmetic-shift-left (loop (- bits 24)) 24) - (random-int s #xFFFFFF))])) - x)) + (let ([bits (integer-length x)]) + (let loop ([shift 0]) + (cond + [(<= bits shift) 0] + [else + ;; Assuming that a `uptr` is at least 32 bits: + (bitwise-ior (loop (+ shift 32)) + (let ([n (bitwise-bit-field x shift (+ shift 32))]) + (if (zero? n) + 0 + (bitwise-arithmetic-shift-left + (random-int s n) + shift))))])))) (unless (is-pseudo-random-generator? s) ($oops who "not a pseudo-random generator ~s" s)) (cond [(fixnum? x) (unless (fxpositive? x) ($oops who "not a positive exact integer ~s" x)) (meta-cond [(<= (constant most-negative-fixnum) 4294967087 (constant most-positive-fixnum)) - (if (fx< x 4294967087) + (if (fx<= x 4294967087) (random-int s x) (random-integer s x))] [else diff --git a/src/ChezScheme/s/5_4.ss b/src/ChezScheme/s/5_4.ss index 1580505440..aa4ee42b35 100644 --- a/src/ChezScheme/s/5_4.ss +++ b/src/ChezScheme/s/5_4.ss @@ -59,7 +59,7 @@ (define (immutable! str) (cond - [(eqv? str "") ($tc-field 'null-immutable-string ($tc))] + [(eqv? str "") (string->immutable-string "")] [else ($string-set-immutable! str) str])) @@ -131,7 +131,7 @@ (lambda (v) (cond [(immutable-string? v) v] - [(eqv? v "") ($tc-field 'null-immutable-string ($tc))] + [(eqv? v "") (string->immutable-string "")] [else (unless (string? v) ($oops who "~s is not a string" v)) (let ([v2 (string-copy v)]) diff --git a/src/ChezScheme/s/5_6.ss b/src/ChezScheme/s/5_6.ss index 25bca39b35..f57de4292b 100644 --- a/src/ChezScheme/s/5_6.ss +++ b/src/ChezScheme/s/5_6.ss @@ -72,7 +72,7 @@ (lambda (v) (cond [(immutable-vector? v) v] - [(eqv? v '#()) ($tc-field 'null-immutable-vector ($tc))] + [(eqv? v '#()) (vector->immutable-vector '#())] [else (unless (vector? v) ($oops who "~s is not a vector" v)) (let ([v2 (vector-copy v)]) @@ -126,16 +126,44 @@ (constant fxvector-data-disp) n)) fxv2)))) -(set-who! fxvector->immutable-fxvector +(set! flvector->list (lambda (v) - (cond - [(immutable-fxvector? v) v] - [(eqv? v '#vfx()) ($tc-field 'null-immutable-fxvector ($tc))] - [else - (unless (fxvector? v) ($oops who "~s is not a fxvector" v)) - (let ([v2 (fxvector-copy v)]) - ($fxvector-set-immutable! v2) - v2)]))) + (unless (flvector? v) + ($oops 'flvector->list "~s is not an flvector" v)) + (let loop ([i (fx- (flvector-length v) 1)] [l '()]) + (if (fx> i 0) + (loop + (fx- i 2) + (list* (flvector-ref v (fx- i 1)) (flvector-ref v i) l)) + (if (fx= i 0) (cons (flvector-ref v 0) l) l))))) + +(set! list->flvector + (lambda (x) + (let ([v (make-flvector ($list-length x 'list->flvector))]) + (do ([ls x (cdr ls)] [i 0 (fx+ i 1)]) + ((null? ls) v) + (let ([n (car ls)]) + (unless (flonum? n) + ($oops 'list->flvector "~s is not a flonum" n)) + (flvector-set! v i n)))))) + +(set! flvector-copy + (lambda (flv1) + (unless (flvector? flv1) + ($oops 'flvector-copy "~s is not an flvector" flv1)) + (let ([n (flvector-length flv1)]) + (let ([flv2 (make-flvector n)]) + (if (fx<= n 10) + (let loop ([i (fx- n 1)]) + (cond + [(fx> i 0) + (flvector-set! flv2 i (flvector-ref flv1 i)) + (let ([i (fx- i 1)]) (flvector-set! flv2 i (flvector-ref flv1 i))) + (loop (fx- i 2))] + [(fx= i 0) (flvector-set! flv2 i (flvector-ref flv1 i))])) + ($byte-copy! flv1 (constant flvector-data-disp) flv2 + (constant flvector-data-disp) (fx* n (constant flonum-bytes)))) + flv2)))) (set! vector-map (case-lambda diff --git a/src/ChezScheme/s/7.ss b/src/ChezScheme/s/7.ss index b4777245c6..9c19a51230 100644 --- a/src/ChezScheme/s/7.ss +++ b/src/ChezScheme/s/7.ss @@ -1317,7 +1317,7 @@ (noncontinuable-interrupt))] [(ERROR_VALUES) (cnt) ($oops #f - "returned ~r values to single value return context" + "returned ~a values to single value return context" cnt)] [(ERROR_MVLET) (cnt) ($oops #f diff --git a/src/ChezScheme/s/Mf-arm64le b/src/ChezScheme/s/Mf-arm64le index 74195ef2ba..1c7ce88365 100644 --- a/src/ChezScheme/s/Mf-arm64le +++ b/src/ChezScheme/s/Mf-arm64le @@ -1,4 +1,4 @@ -# Mf-tarm64le +# Mf-arm64le # Copyright 1984-2017 Cisco Systems, Inc. # # Licensed under the Apache License, Version 2.0 (the "License"); diff --git a/src/ChezScheme/s/Mf-arm64osx b/src/ChezScheme/s/Mf-arm64osx new file mode 100644 index 0000000000..92a5257213 --- /dev/null +++ b/src/ChezScheme/s/Mf-arm64osx @@ -0,0 +1,21 @@ +# Mf-arm64osx +# Copyright 1984-2017 Cisco Systems, Inc. +# +# Licensed under the Apache License, Version 2.0 (the "License"); +# you may not use this file except in compliance with the License. +# You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. + +m ?= arm64osx +archincludes = arm64.ss + +include Mf-base + +machine.def: arm64.def diff --git a/src/ChezScheme/s/Mf-base b/src/ChezScheme/s/Mf-base index dfd08463f5..c42e9fe2f6 100644 --- a/src/ChezScheme/s/Mf-base +++ b/src/ChezScheme/s/Mf-base @@ -115,7 +115,6 @@ Cequates = ../boot/$m/equates.h Cgcocd = ../boot/$m/gc-ocd.inc Cgcoce = ../boot/$m/gc-oce.inc Cgcpar = ../boot/$m/gc-par.inc -Cvfasl = ../boot/$m/vfasl.inc Cheapcheck = ../boot/$m/heapcheck.inc Revision = ../boot/$m/revision @@ -128,7 +127,7 @@ patch = patch patchobj = patch.patch cpnanopass.patch cprep.patch cpcheck.patch\ cp0.patch cpvalid.patch cptypes.patch cpcommonize.patch cpletrec.patch\ reloc.patch\ - compile.patch fasl.patch syntax.patch env.patch\ + compile.patch fasl.patch vfasl.patch syntax.patch env.patch\ read.patch interpret.patch ftype.patch strip.patch\ ubify.patch @@ -151,7 +150,7 @@ basesrc =\ interpret.ss cprep.ss cpcheck.ss cp0.ss cpvalid.ss cptypes.ss cpcommonize.ss cpletrec.ss inspect.ss\ enum.ss io.ss read.ss primvars.ss syntax.ss costctr.ss expeditor.ss\ exceptions.ss pretty.ss env.ss\ - fasl.ss reloc.ss pdhtml.ss strip.ss ftype.ss back.ss + fasl.ss vfasl.ss reloc.ss pdhtml.ss strip.ss ftype.ss back.ss baseobj = ${basesrc:%.ss=%.$m} @@ -170,14 +169,14 @@ macroobj =\ allsrc =\ ${basesrc} ${compilersrc} cmacros.ss ${archincludes} setup.ss debug.ss priminfo.ss primdata.ss layout.ss\ base-lang.ss expand-lang.ss primref.ss types.ss io-types.ss fasl-helpers.ss hashtable-types.ss\ - np-languages.ss fxmap.ss + np-languages.ss fxmap.ss strip-types.ss # doit uses a different Scheme process to compile each target -doit: ${PetiteBoot} ${SchemeBoot} ${Cheader} ${Cequates} ${Cgcocd} ${Cgcoce} ${Cgcpar} ${Cvfasl} ${Cheapcheck} ${Revision} +doit: ${PetiteBoot} ${SchemeBoot} ${Cheader} ${Cequates} ${Cgcocd} ${Cgcoce} ${Cgcpar} ${Cheapcheck} ${Revision} # all uses a single Scheme process to compile all targets. this is typically # faster when most of the targets need to be recompiled. -all: bootall ${Cheader} ${Cequates} ${Cgcocd} ${Cgcoce} ${Cgcpar} ${Cvfasl} ${Cheapcheck} ${Revision} +all: bootall ${Cheader} ${Cequates} ${Cgcocd} ${Cgcoce} ${Cgcpar} ${Cheapcheck} ${Revision} # allx runs all up to three times and checks to see if the new boot file is the # same as the last, i.e., the system is properly bootstrapped. @@ -364,7 +363,7 @@ resetbootlinks: | ${Scheme} -q keepbootfiles: - for x in `echo scheme.boot petite.boot scheme.h equates.h gc-oce.inc gc-ocd.inc gc-par.inc vfasl.inc heapcheck.inc` ; do\ + for x in `echo scheme.boot petite.boot scheme.h equates.h gc-oce.inc gc-ocd.inc gc-par.inc heapcheck.inc` ; do\ if [ ! -h ../boot/$(m)/$$x ] ; then \ mv -f ../boot/$(m)/$$x ../../boot/$(m)/$$x ;\ elif [ "${upupupbootdir}" != "../../.." ] ; then \ @@ -388,7 +387,7 @@ ${SchemeBoot}: ${macroobj} ${patchfile} ${compilerobj} ' (map symbol->string (quote (${compilerobj}))))'\ | ${Scheme} -q ${macroobj} ${patchfile} -cmacros.so: cmacros.ss machine.def layout.ss +cmacros.so: cmacros.ss machine.def default.def layout.ss echo '(reset-handler abort)'\ '(base-exception-handler (lambda (c) (fresh-line) (display-condition c) (newline) (reset)))'\ '(keyboard-interrupt-handler (lambda () (display "interrupted---aborting\n") (reset)))'\ @@ -593,11 +592,15 @@ ${patch}: ${patchobj} ${asm} ${obj} mkheader.so: ${macroobj} nanopass.so base-lang.ss expand-lang.ss primref.ss types.ss io-types.ss fasl-helpers.ss hashtable-types.ss ${patchfile} primvars.so setup.so mkheader.so env.so: cmacros.so priminfo.so primref.ss setup.so: debug.ss +strip.so: strip-types.ss +vfasl.so: strip-types.ss -${patchobj}: ${macroobj} nanopass.so base-lang.ss expand-lang.ss primref.ss types.ss io-types.ss fasl-helpers.ss hashtable-types.ss env.ss +${patchobj}: ${macroobj} nanopass.so base-lang.ss expand-lang.ss primref.ss types.ss io-types.ss fasl-helpers.ss hashtable-types.ss strip-types.ss env.ss cpnanopass.$m cpnanopass.patch: nanopass.so np-languages.ss fxmap.ss ${archincludes} cptypes.$m: fxmap.ss 5_4.$m: ../unicode/unicode-char-cases.ss ../unicode/unicode-charinfo.ss +strip.$m: strip-types.ss +vfasl.$m: strip-types.ss ${Cheader}: mkheader.so ${macroobj} nanopass.so base-lang.ss expand-lang.ss primref.ss types.ss io-types.ss fasl-helpers.ss hashtable-types.ss (if [ -r ${Cheader} ]; then mv -f ${Cheader} ${Cheader}.bak; fi) @@ -644,15 +647,6 @@ ${Cgcpar}: mkgc.so ${macroobj} nanopass.so base-lang.ss expand-lang.ss primref.s then mv -f ${Cgcpar}.bak ${Cgcpar};\ else rm -f ${Cgcpar}.bak; fi) -${Cvfasl}: mkgc.so ${macroobj} nanopass.so base-lang.ss expand-lang.ss primref.ss types.ss io-types.ss fasl-helpers.ss hashtable-types.ss - (if [ -r ${Cvfasl} ]; then mv -f ${Cvfasl} ${Cvfasl}.bak; fi) - echo '(reset-handler abort)'\ - '(mkvfasl.inc "${Cvfasl}")' |\ - ${Scheme} -q ${macroobj} mkheader.so mkgc.so - (if `cmp -s ${Cvfasl} ${Cvfasl}.bak`;\ - then mv -f ${Cvfasl}.bak ${Cvfasl};\ - else rm -f ${Cvfasl}.bak; fi) - ${Cheapcheck}: mkgc.so ${macroobj} nanopass.so base-lang.ss expand-lang.ss primref.ss types.ss io-types.ss fasl-helpers.ss hashtable-types.ss (if [ -r ${Cheapcheck} ]; then mv -f ${Cheapcheck} ${Cheapcheck}.bak; fi) echo '(reset-handler abort)'\ @@ -685,10 +679,13 @@ reset: $(MAKE) reset-one FILE=gc-oce.inc $(MAKE) reset-one FILE=gc-ocd.inc $(MAKE) reset-one FILE=gc-par.inc - $(MAKE) reset-one FILE=vfasl.inc $(MAKE) reset-one FILE=heapcheck.inc .PHONY: reset-one reset-one: if [ -f ../boot/${m}/${FILE} ] ; then rm ../boot/${m}/${FILE} ; fi if [ ! -h ../boot/${m}/${FILE} ] ; then ln -s "${upupupbootdir}"/boot/${m}/${FILE} ../boot/${m}/${FILE} ; fi + +.PHONY: run +run: + env SCHEMEHEAPDIRS=../boot/$m/ ../bin/$m/scheme $(ARGS) diff --git a/src/ChezScheme/s/Mf-ppc32osx b/src/ChezScheme/s/Mf-ppc32osx new file mode 100644 index 0000000000..90e504a865 --- /dev/null +++ b/src/ChezScheme/s/Mf-ppc32osx @@ -0,0 +1,6 @@ +# Mf-ppc32osx + +m ?= ppc32osx +archincludes = ppc32.ss + +include Mf-base diff --git a/src/ChezScheme/s/Mf-tarm64osx b/src/ChezScheme/s/Mf-tarm64osx new file mode 100644 index 0000000000..09f0a2a416 --- /dev/null +++ b/src/ChezScheme/s/Mf-tarm64osx @@ -0,0 +1,18 @@ +# Mf-tarm64osx +# Copyright 1984-2017 Cisco Systems, Inc. +# +# Licensed under the Apache License, Version 2.0 (the "License"); +# you may not use this file except in compliance with the License. +# You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. + +m = tarm64osx + +include Mf-arm64osx diff --git a/src/ChezScheme/s/Mf-ti3osx b/src/ChezScheme/s/Mf-ti3osx index 20da12fdfe..a83bd3feb0 100644 --- a/src/ChezScheme/s/Mf-ti3osx +++ b/src/ChezScheme/s/Mf-ti3osx @@ -14,6 +14,5 @@ # limitations under the License. m = ti3osx -archincludes = x86.ss -include Mf-base +include Mf-i3osx diff --git a/src/ChezScheme/s/Mf-tppc32osx b/src/ChezScheme/s/Mf-tppc32osx new file mode 100644 index 0000000000..56b001c5d7 --- /dev/null +++ b/src/ChezScheme/s/Mf-tppc32osx @@ -0,0 +1,5 @@ +# Mf-tppc32osx + +m = tppc32osx + +include Mf-ppc32osx diff --git a/src/ChezScheme/s/arm32.ss b/src/ChezScheme/s/arm32.ss index 2498e5a5d4..fc719ac739 100644 --- a/src/ChezScheme/s/arm32.ss +++ b/src/ChezScheme/s/arm32.ss @@ -354,27 +354,27 @@ ; WARNING: do not assume that if x isn't the same as z then x is independent ; of z, since x might be an mref with z as it's base or index - (define-instruction value (- -/ovfl -/eq) + (define-instruction value (- -/ovfl -/eq -/pos) [(op (z ur) (x ur) (y funky12)) - `(set! ,(make-live-info) ,z (asm ,info ,(asm-sub (memq op '(-/ovfl -/eq))) ,x ,y))] + `(set! ,(make-live-info) ,z (asm ,info ,(asm-sub (not (eq? op '-))) ,x ,y))] [(op (z ur) (x funky12) (y ur)) - `(set! ,(make-live-info) ,z (asm ,info ,(asm-rsb (memq op '(-/ovfl -/eq))) ,y ,x))] + `(set! ,(make-live-info) ,z (asm ,info ,(asm-rsb (not (eq? op '-))) ,y ,x))] [(op (z ur) (x ur) (y negate-funky12)) - `(set! ,(make-live-info) ,z (asm ,info ,(asm-add (memq op '(-/ovfl -/eq))) ,x ,y))] + `(set! ,(make-live-info) ,z (asm ,info ,(asm-add (not (eq? op '-))) ,x ,y))] [(op (z ur) (x ur) (y ur)) - `(set! ,(make-live-info) ,z (asm ,info ,(asm-sub (memq op '(-/ovfl -/eq))) ,x ,y))]) + `(set! ,(make-live-info) ,z (asm ,info ,(asm-sub (not (eq? op '-))) ,x ,y))]) (define-instruction value (+ +/ovfl +/carry) [(op (z ur) (x ur) (y funky12)) - `(set! ,(make-live-info) ,z (asm ,info ,(asm-add (memq op '(+/ovfl +/carry))) ,x ,y))] + `(set! ,(make-live-info) ,z (asm ,info ,(asm-add (not (eq? op '+))) ,x ,y))] [(op (z ur) (x funky12) (y ur)) - `(set! ,(make-live-info) ,z (asm ,info ,(asm-add (memq op '(+/ovfl +/carry))) ,y ,x))] + `(set! ,(make-live-info) ,z (asm ,info ,(asm-add (not (eq? op '+))) ,y ,x))] [(op (z ur) (x ur) (y negate-funky12)) - `(set! ,(make-live-info) ,z (asm ,info ,(asm-sub (memq op '(+/ovfl +/carry))) ,x ,y))] + `(set! ,(make-live-info) ,z (asm ,info ,(asm-sub (not (eq? op '+))) ,x ,y))] [(op (z ur) (x negate-funky12) (y ur)) - `(set! ,(make-live-info) ,z (asm ,info ,(asm-sub (memq op '(+/ovfl +/carry))) ,y ,x))] + `(set! ,(make-live-info) ,z (asm ,info ,(asm-sub (not (eq? op '+))) ,y ,x))] [(op (z ur) (x ur) (y ur)) - `(set! ,(make-live-info) ,z (asm ,info ,(asm-add (memq op '(+/ovfl +/carry))) ,x ,y))]) + `(set! ,(make-live-info) ,z (asm ,info ,(asm-add (not (eq? op '+))) ,x ,y))]) (define-instruction value (*) ; no imm form available @@ -2295,6 +2295,7 @@ [(>=) (i? (r? bgt blt) (r? ble bge))] [(overflow) (i? bvc bvs)] [(multiply-overflow) (i? beq bne)] ; result of comparing sign bit of low word with all bits in high word: eq if no overflow, ne if oveflow + [(positive) (i? ble bgt)] [(carry) (i? bcc bcs)] [(fp<) (i? (r? ble bcs) (r? bgt bcc))] [(fp<=) (i? (r? blt bhi) (r? bge bls))] @@ -2770,7 +2771,7 @@ (safe-assert (reg-callee-save? %tc)) ; no need to save-restore (let* ([arg-type* (info-foreign-arg-type* info)] [conv* (info-foreign-conv* info)] - [varargs? (memq 'varargs conv*)] + [varargs? (ormap (lambda (conv) (and (pair? conv) (eq? (car conv) 'varargs))) conv*)] [result-type (info-foreign-result-type info)] [result-reg* (get-result-regs result-type varargs?)] [fill-result-here? (indirect-result-that-fits-in-registers? result-type)] @@ -3240,7 +3241,7 @@ (vector->list regvec))) (let* ([arg-type* (info-foreign-arg-type* info)] [conv* (info-foreign-conv* info)] - [varargs? (memq 'varargs conv*)] + [varargs? (ormap (lambda (conv) (and (pair? conv) (eq? (car conv) 'varargs))) conv*)] [result-type (info-foreign-result-type info)] [synthesize-first? (indirect-result-that-fits-in-registers? result-type)] [adjust-active? (if-feature pthreads (memq 'adjust-active conv*) #f)]) diff --git a/src/ChezScheme/s/arm64.ss b/src/ChezScheme/s/arm64.ss index b32e3dfb41..831df49e53 100644 --- a/src/ChezScheme/s/arm64.ss +++ b/src/ChezScheme/s/arm64.ss @@ -127,7 +127,7 @@ [(and (not (eq? x1 %zero)) (unsigned12? (- imm))) (let ([u (make-tmp 'u)]) (seq - (build-set! ,u (asm ,null-info ,(asm-sub #f) ,x1 (immediate ,imm))) + (build-set! ,u (asm ,null-info ,(asm-sub #f) ,x1 (immediate ,(- imm)))) (return x0 u 0 type)))] [else (let ([u (make-tmp 'u)]) @@ -236,23 +236,23 @@ ; WARNING: do not assume that if x isn't the same as z then x is independent ; of z, since x might be an mref with z as it's base or index - (define-instruction value (- -/ovfl -/eq) + (define-instruction value (- -/ovfl -/eq -/pos) [(op (z ur) (x ur) (y unsigned12)) - `(set! ,(make-live-info) ,z (asm ,info ,(asm-sub (memq op '(-/ovfl -/eq))) ,x ,y))] + `(set! ,(make-live-info) ,z (asm ,info ,(asm-sub (not (eq? op '-))) ,x ,y))] [(op (z ur) (x ur) (y neg-unsigned12)) - `(set! ,(make-live-info) ,z (asm ,info ,(asm-add (memq op '(-/ovfl -/eq))) ,x ,y))] + `(set! ,(make-live-info) ,z (asm ,info ,(asm-add (not (eq? op '-))) ,x ,y))] [(op (z ur) (x ur) (y ur)) - `(set! ,(make-live-info) ,z (asm ,info ,(asm-sub (memq op '(-/ovfl -/eq))) ,x ,y))]) + `(set! ,(make-live-info) ,z (asm ,info ,(asm-sub (not (eq? op '-))) ,x ,y))]) (define-instruction value (+ +/ovfl +/carry) [(op (z ur) (x ur) (y unsigned12)) - `(set! ,(make-live-info) ,z (asm ,info ,(asm-add (memq op '(+/ovfl +/carry))) ,x ,y))] + `(set! ,(make-live-info) ,z (asm ,info ,(asm-add (not (eq? op '+))) ,x ,y))] [(op (z ur) (x ur) (y neg-unsigned12)) - `(set! ,(make-live-info) ,z (asm ,info ,(asm-sub (memq op '(+/ovfl +/carry))) ,x ,y))] + `(set! ,(make-live-info) ,z (asm ,info ,(asm-sub (not (eq? op '+))) ,x ,y))] [(op (z ur) (x unsigned12) (y ur)) - `(set! ,(make-live-info) ,z (asm ,info ,(asm-add (memq op '(+/ovfl +/carry))) ,y ,x))] + `(set! ,(make-live-info) ,z (asm ,info ,(asm-add (not (eq? op '+))) ,y ,x))] [(op (z ur) (x ur) (y ur)) - `(set! ,(make-live-info) ,z (asm ,info ,(asm-add (memq op '(+/ovfl +/carry))) ,x ,y))]) + `(set! ,(make-live-info) ,z (asm ,info ,(asm-add (not (eq? op '+))) ,x ,y))]) (define-instruction value (*) ; no imm form available @@ -298,8 +298,10 @@ (define-instruction value popcount [(op (z ur) (x ur)) - (let ([u (make-tmp 'u 'fp)]) - `(set! ,(make-live-info) ,z (asm ,info ,asm-popcount ,x ,u)))]) + (let ([u (make-tmp 'u)]) + (seq + `(set! ,(make-live-info) ,u (asm ,null-info ,asm-kill)) + `(set! ,(make-live-info) ,z (asm ,info ,asm-popcount ,x ,u))))]) (define-instruction value (move) [(op (z mem) (x ur)) @@ -659,6 +661,10 @@ ;; NB: use sqrt or something like that? [(op) '()]) + (define-instruction effect (debug) + [(op) + `(asm ,info ,asm-debug)]) + (define-instruction effect (c-call) [(op (x ur)) (let ([ulr (make-precolored-unspillable 'ulr %lr)]) @@ -703,6 +709,7 @@ asm-fpop-2 asm-fpsqrt asm-c-simple-call asm-return asm-c-return asm-size asm-enter asm-foreign-call asm-foreign-callable + asm-debug asm-read-counter asm-inc-cc-counter signed9? unsigned12? aligned-offset? funkymask shifted16 @@ -936,6 +943,8 @@ (define-op mrs mrs-op) + (define-op und und-op) + (define-op fadd f-arith-op #b0010) ; selector is at bit 12 (define-op fsub f-arith-op #b0011) (define-op fmul f-arith-op #b0000) @@ -1254,7 +1263,7 @@ (lambda (op dest code*) (record-case dest [(label) (offset l) - (safe-assert (uncond-branch-disp? (+ offset 4))) + (safe-assert (uncond-branch-disp? offset)) (emit-code (op dest code*) [26 #b000101] [0 (fxand (fxsra (fx+ offset 4) 2) (fx- (fxsll 1 26) 1))])] @@ -1394,6 +1403,11 @@ [5 op2] [0 (ax-ea-reg-code dest)]))) + (define und-op + (lambda (op code*) + (emit-code (op code*) + [0 0]))) + ;; asm helpers (define-who ax-cond @@ -1550,9 +1564,10 @@ (define uncond-branch-disp? (lambda (x) - (and (fixnum? x) - (fx<= (- (expt 2 26)) x (- (expt 2 20) 1)) - (not (fxlogtest x #b11))))) + (let ([x (+ x 4)]) ; because `branch-always-label-op` adds 4 + (and (fixnum? x) + (fx<= (- (expt 2 27)) x (- (expt 2 27) 1)) + (not (fxlogtest x #b11)))))) (define asm-size (lambda (x) @@ -2050,6 +2065,10 @@ [else (loop (cddr regs) (two sp (cons 'reg (car regs)) (cons 'reg (cadr regs)) code*))])))) + (define asm-debug + (lambda (code*) + (emit und code*))) + (define asm-read-counter (lambda (op0 op1 crn crm op2) (lambda (code* dest) @@ -2261,6 +2280,7 @@ [(>) (i? (r? bge ble) (r? blt bgt))] [(>=) (i? (r? bgt blt) (r? ble bge))] [(overflow) (i? bvc bvs)] + [(positive) (i? ble bgt)] [(multiply-overflow) (i? beq bne)] ; result of comparing sign bit of low word with all bits in high word: eq if no overflow, ne if oveflow [(carry) (i? bcc bcs)] [(fp<) (i? (r? ble bcs) (r? bgt bcc))] @@ -2418,96 +2438,183 @@ (inline ,(make-info-kill*-live* fp-regs '()) ,%pop-fpmultiple))])))]) (save-and-restore-gp regs (save-and-restore-fp regs e)))))) + (define (extract-varargs-after-conv conv*) + (ormap (lambda (conv) + (and (pair? conv) (eq? (car conv) 'varargs) (cdr conv))) + conv*)) + (define-record-type cat - (nongenerative #{cat jqrttgvpydsbdo0l736l43udu-0}) + (nongenerative #{cat jqrttgvpydsbdo0l736l43udu-1}) (sealed #t) (fields place ; 'int, 'fp, or 'stack regs ; list of registers size ; size in bytes + pad ; extra trailing size (for 'stack place) in bytes indirect-bytes)) ; #f or extra bytes on stack for indirect - + + (define alignment-via-lookahead + (lambda (size types stack-align varargs-after k) + (constant-case machine-type-name + [(arm64osx tarm64osx) + (cond + [(eqv? 0 varargs-after) (k (align 8 size) 0 0)] + [else + ;; On Mac OS, a non-varargs stack argument does not have to use a + ;; multiple of 8, but we need to work out any padding that + ;; is needed to get alignment right for the next argument + ;; (and to end on 8-byte alignment). Currently, we're + ;; assuming max aignment of 8. + (let ([end-this-align (fxand #x7 (fx+ stack-align size))] + [next-align (cond + [(null? types) 8] + [else (nanopass-case (Ltype Type) (car types) + [(fp-double-float) 8] + [(fp-single-float) 4] + [(fp-ftd& ,ftd) (if (> ($ftd-size ftd) 16) + 8 + ($ftd-alignment ftd))] + [(fp-integer ,bits) (fxquotient bits 8)] + [(fp-unsigned ,bits) (fxquotient bits 8)] + [else 8])])]) + (cond + [(fx= 0 (fxand end-this-align (fx- next-align 1))) + (k size 0 end-this-align)] + [else + (k size (- next-align end-this-align) next-align)]))])] + [else + (k (align 8 size) 0 0)]))) + + (define rest-of + (lambda (regs n next-varargs-after) + (constant-case machine-type-name + [(arm64osx tarm64osx) + (cond + [(eqv? next-varargs-after 0) + ;; All the rest go on the stack + '()] + [else + (list-tail regs n)])] + [else + (list-tail regs n)]))) + (define categorize-arguments - (lambda (types) - (let loop ([types types] [int* (int-argument-regs)] [fp* (fp-argument-regs)]) - (if (null? types) - '() - (nanopass-case (Ltype Type) (car types) - [(fp-double-float) - (cond - [(null? fp*) - (cons (make-cat 'stack '() 8 #f) (loop (cdr types) int* '()))] - [else - (cons (make-cat 'fp (list (car fp*)) 8 #f) (loop (cdr types) int* (cdr fp*)))])] - [(fp-single-float) - (cond - [(null? fp*) - (cons (make-cat 'stack '() 8 #f) (loop (cdr types) int* '()))] - [else - (cons (make-cat 'fp (list (car fp*)) 8 #f) (loop (cdr types) int* (cdr fp*)))])] - [(fp-ftd& ,ftd) - (let* ([size ($ftd-size ftd)] - [members ($ftd->members ftd)] - [num-members (length members)] - [doubles? (and (fx= 8 ($ftd-alignment ftd)) - (fx<= num-members 4) - (andmap double-member? members))] - [floats? (and (fx= 4 ($ftd-alignment ftd)) - (fx<= num-members 4) - (andmap float-member? members))]) + (lambda (types varargs-after) + (let loop ([types types] [int* (int-argument-regs)] [fp* (fp-argument-regs)] + [varargs-after varargs-after] + ;; accumulate alignment from previous args so we can compute any + ;; needed padding and alignment after this next argument + [stack-align 0]) + (let ([next-varargs-after (and varargs-after (if (fx> varargs-after 0) (fx- varargs-after 1) 0))]) + (if (null? types) + '() + (nanopass-case (Ltype Type) (car types) + [(fp-double-float) + (cond + [(null? fp*) + (cons (make-cat 'stack '() 8 0 #f) (loop (cdr types) int* '() next-varargs-after 0))] + [else + (cons (make-cat 'fp (list (car fp*)) 8 0 #f) + (loop (cdr types) (rest-of int* 0 next-varargs-after) (rest-of fp* 1 next-varargs-after) + next-varargs-after + stack-align))])] + [(fp-single-float) (cond - [doubles? - ;; Sequence of up to 4 doubles that may fit in registers - (cond - [(fx>= (length fp*) num-members) - ;; Allocate each double to a register - (cons (make-cat 'fp (list-head fp* num-members) (fx* 8 num-members) #f) - (loop (cdr types) int* (list-tail fp* num-members)))] - [else - ;; Stop using fp registers, put on stack - (cons (make-cat 'stack '() size #f) - (loop (cdr types) int* '()))])] - [floats? - ;; Sequence of up to 4 floats that may fit in registers - (cond - [(fx>= (length fp*) num-members) - ;; Allocate each float to a register - (cons (make-cat 'fp (list-head fp* num-members) (fx* 8 num-members) #f) - (loop (cdr types) int* (list-tail fp* num-members)))] - [else - ;; Stop using fp registers, put on stack with aligned size - (cons (make-cat 'stack '() (align 8 size) #f) - (loop (cdr types) int* '()))])] - [(fx> size 16) - ;; Indirect; pointer goes in a register or on the stack - (cond - [(null? int*) - ;; Pointer on the stack - (cons (make-cat 'stack '() (constant ptr-bytes) (align 8 size)) - (loop (cdr types) '() fp*))] - [else - ;; Pointer in register - (cons (make-cat 'int (list (car int*)) 8 (align 8 size)) - (loop (cdr types) (cdr int*) fp*))])] + [(null? fp*) + (alignment-via-lookahead + 4 (cdr types) stack-align varargs-after + (lambda (bytes pad stack-align) + (cons (make-cat 'stack '() bytes pad #f) (loop (cdr types) int* '() next-varargs-after stack-align))))] [else - ;; Maybe put in integer registers - (let* ([size (align 8 size)] - [regs (fxquotient size 8)]) + (cons (make-cat 'fp (list (car fp*)) 8 0 #f) + (loop (cdr types) (rest-of int* 0 next-varargs-after)(rest-of fp* 1 next-varargs-after) + next-varargs-after + stack-align))])] + [(fp-ftd& ,ftd) + (let* ([size ($ftd-size ftd)] + [members ($ftd->members ftd)] + [num-members (length members)] + [doubles? (and (fx= 8 ($ftd-alignment ftd)) + (fx<= num-members 4) + (andmap double-member? members))] + [floats? (and (fx= 4 ($ftd-alignment ftd)) + (fx<= num-members 4) + (andmap float-member? members))]) + (cond + [doubles? + ;; Sequence of up to 4 doubles that may fit in registers (cond - [(fx<= regs (length int*)) - ;; Fits in registers - (cons (make-cat 'int (list-head int* regs) size #f) - (loop (cdr types) (list-tail int* regs) fp*))] + [(fx>= (length fp*) num-members) + ;; Allocate each double to a register + (cons (make-cat 'fp (list-head fp* num-members) (fx* 8 num-members) 0 #f) + (loop (cdr types) (rest-of int* 0 next-varargs-after) (rest-of fp* num-members next-varargs-after) + next-varargs-after + stack-align))] [else - ;; Stop using int registers, put on stack - (cons (make-cat 'stack '() size #f) - (loop (cdr types) '() fp*))]))]))] - [else - ;; integers, scheme-object, etc. - (cond - [(null? int*) - (cons (make-cat 'stack '() 8 #f) (loop (cdr types) '() fp*))] - [else - (cons (make-cat 'int (list (car int*)) 8 #f) (loop (cdr types) (cdr int*) fp*))])]))))) + ;; Stop using fp registers, put on stack + (cons (make-cat 'stack '() size 0 #f) + (loop (cdr types) int* '() next-varargs-after 0))])] + [floats? + ;; Sequence of up to 4 floats that may fit in registers + (cond + [(fx>= (length fp*) num-members) + ;; Allocate each float to a register + (cons (make-cat 'fp (list-head fp* num-members) (fx* 8 num-members) 0 #f) + (loop (cdr types) (rest-of int* 0 next-varargs-after) (rest-of fp* num-members next-varargs-after) + next-varargs-after + stack-align))] + [else + ;; Stop using fp registers, put on stack + (alignment-via-lookahead + size (cdr types) stack-align varargs-after + (lambda (size pad stack-align) + (cons (make-cat 'stack '() size pad #f) + (loop (cdr types) int* '() next-varargs-after stack-align))))])] + [(fx> size 16) + ;; Indirect; pointer goes in a register or on the stack + (cond + [(null? int*) + ;; Pointer on the stack + (cons (make-cat 'stack '() (constant ptr-bytes) 0 (align 8 size)) + (loop (cdr types) '() fp* next-varargs-after 0))] + [else + ;; Pointer in register + (cons (make-cat 'int (list (car int*)) 8 0 (align 8 size)) + (loop (cdr types) (rest-of int* 1 next-varargs-after) (rest-of fp* 0 next-varargs-after) + next-varargs-after + stack-align))])] + [else + ;; Maybe put in integer registers + (let* ([regs (fxquotient (align 8 size) 8)]) + (cond + [(fx<= regs (length int*)) + ;; Fits in registers + (cons (make-cat 'int (list-head int* regs) (align 8 size) 0 #f) + (loop (cdr types) (rest-of int* regs next-varargs-after) (rest-of fp* 0 next-varargs-after) + next-varargs-after + stack-align))] + [else + ;; Stop using int registers, put on stack + (alignment-via-lookahead + size (cdr types) stack-align varargs-after + (lambda (size pad stack-align) + (cons (make-cat 'stack '() size pad #f) + (loop (cdr types) '() fp* next-varargs-after stack-align))))]))]))] + [else + ;; integers, scheme-object, etc. + (cond + [(null? int*) + (let ([size (nanopass-case (Ltype Type) (car types) + [(fp-integer ,bits) (fxquotient bits 8)] + [(fp-unsigned ,bits) (fxquotient bits 8)] + [else 8])]) + (alignment-via-lookahead + size (cdr types) stack-align varargs-after + (lambda (size pad stack-align) + (cons (make-cat 'stack '() size pad #f) (loop (cdr types) '() fp* next-varargs-after stack-align)))))] + [else + (cons (make-cat 'int (list (car int*)) 8 0 #f) + (loop (cdr types) (rest-of int* 1 next-varargs-after) (rest-of fp* 0 next-varargs-after) + next-varargs-after stack-align))])])))))) (define get-registers (lambda (cats kind) @@ -2576,9 +2683,20 @@ (lambda (x) ; unboxed (%inline store-double->single ,(%mref ,%sp ,%zero ,offset fp) ,x)))] [load-int-stack - (lambda (offset) + (lambda (offset size) (lambda (rhs) ; requires rhs - `(set! ,(%mref ,%sp ,offset) ,rhs)))] + (let ([int-type (case size + [(1) 'unsigned-8] + [(2) 'unsigned-16] + [(4) 'unsigned-32] + [else #f])]) + (cond + [(not int-type) `(set! ,(%mref ,%sp ,offset) ,rhs)] + [else + (let ([tmp %argtmp]) + (%seq + (set! ,tmp ,rhs) + (inline ,(make-info-load int-type #f) ,%store ,%sp ,%zero (immediate ,offset) ,tmp)))]))))] [load-indirect-stack ;; used both for arguments passed on stack and argument passed as a pointer to deeper on the stack (lambda (offset from-offset size) @@ -2636,7 +2754,7 @@ isp (let ([cat (car cats)]) (if (eq? (cat-place cat) 'stack) - (loop (cdr cats) (fx+ isp (cat-size cat))) + (loop (cdr cats) (fx+ isp (cat-size cat) (cat-pad cat))) (loop (cdr cats) isp))))))] [compute-stack-indirect-space (lambda (cats) @@ -2664,7 +2782,7 @@ [else (loop types cats (cons (load-double-stack isp) locs) - (fx+ isp (cat-size cat)) ind-sp)])] + (fx+ isp (cat-size cat) (cat-pad cat)) ind-sp)])] [(fp-single-float) (cond [(eq? 'fp (cat-place cat)) @@ -2674,7 +2792,7 @@ [else (loop types cats (cons (load-single-stack isp) locs) - (fx+ isp (cat-size cat)) ind-sp)])] + (fx+ isp (cat-size cat) (cat-pad cat)) ind-sp)])] [(fp-ftd& ,ftd) (let ([size ($ftd-size ftd)]) (case (cat-place cat) @@ -2742,18 +2860,18 @@ ;; argument copied to stack (loop types cats (cons (load-indirect-stack isp 0 size) locs) - (fx+ isp size-on-stack) ind-sp)]))]))] + (fx+ isp size-on-stack (cat-pad cat)) ind-sp)]))]))] [else ;; integer, scheme-object, etc. (cond [(eq? 'int (cat-place cat)) - (loop types cats + (loop types cats (cons (load-int-reg (car (cat-regs cat))) locs) isp ind-sp)] [else - (loop types cats - (cons (load-int-stack isp) locs) - (fx+ isp (cat-size cat)) ind-sp)])])))))] + (loop types cats + (cons (load-int-stack isp (cat-size cat)) locs) + (fx+ isp (cat-size cat) (cat-pad cat)) ind-sp)])])))))] [add-fill-result ;; may destroy the values in result registers (lambda (result-cat result-type args-frame-size e) @@ -2808,9 +2926,9 @@ [arg-type* (if ftd-result? (cdr arg-type*) arg-type*)] - [arg-cat* (categorize-arguments arg-type*)] [conv* (info-foreign-conv* info)] - [result-cat (car (categorize-arguments (list result-type)))] + [arg-cat* (categorize-arguments arg-type* (extract-varargs-after-conv conv*))] + [result-cat (car (categorize-arguments (list result-type) #f))] [result-reg* (cat-regs result-cat)] [fill-result-here? (and ftd-result? (not (cat-indirect-bytes result-cat)) @@ -2839,7 +2957,7 @@ (cond [fill-result-here? ;; stash extra argument on the stack to be retrieved after call and filled with the result: - (cons (load-int-stack (fx+ arg-stack-bytes indirect-stack-bytes)) locs)] + (cons (load-int-stack (fx+ arg-stack-bytes indirect-stack-bytes) 8) locs)] [ftd-result? ;; callee expects pointer to fill for return in %r8: (cons (lambda (rhs) `(set! ,%r8 ,rhs)) locs)] @@ -2976,7 +3094,7 @@ [else (loop types cats (cons (load-double-stack stack-arg-offset) locs) - int-reg-offset float-reg-offset (fx+ stack-arg-offset (cat-size cat)))])] + int-reg-offset float-reg-offset (fx+ stack-arg-offset (cat-size cat) (cat-pad cat)))])] [(fp-single-float) (case (cat-place cat) [(fp) @@ -2986,7 +3104,7 @@ [else (loop types cats (cons (load-single-stack stack-arg-offset) locs) - int-reg-offset float-reg-offset (fx+ stack-arg-offset (cat-size cat)))])] + int-reg-offset float-reg-offset (fx+ stack-arg-offset (cat-size cat) (cat-pad cat)))])] [(fp-ftd& ,ftd) (case (cat-place cat) @@ -3003,7 +3121,7 @@ ;; point to argument on stack (loop types cats (cons (load-stack-address int-reg-offset) locs) - (fx+ int-reg-offset (cat-size cat)) float-reg-offset stack-arg-offset)]))] + (fx+ int-reg-offset (cat-size cat) (cat-pad cat)) float-reg-offset stack-arg-offset)]))] [(fp) ;; point to argument, but if they're floats, then we need to ;; shift double-sized registers into float-sized elements @@ -3030,7 +3148,7 @@ (inline ,(make-info-load 'unsigned-32 #f) ,%store ,%sp ,%zero (immediate ,dest-offset) ,%argtmp) ,(loop (cdr members) (fx+ dest-offset 4) (fx+ src-offset 8)))))))])) locs) - int-reg-offset (fx+ float-reg-offset (cat-size cat)) stack-arg-offset)] + int-reg-offset (fx+ float-reg-offset (cat-size cat) (cat-pad cat)) stack-arg-offset)] [else (let ([indirect-bytes (cat-indirect-bytes cat)]) (cond @@ -3044,7 +3162,7 @@ ;; point to argument on stack (loop types cats (cons (load-stack-address stack-arg-offset) locs) - int-reg-offset float-reg-offset (fx+ stack-arg-offset (cat-size cat)))]))])] + int-reg-offset float-reg-offset (fx+ stack-arg-offset (cat-size cat) (cat-pad cat)))]))])] [else ;; integer, scheme-object, etc. (case (cat-place cat) @@ -3055,7 +3173,7 @@ [else (loop types cats (cons (load-int-stack type stack-arg-offset) locs) - int-reg-offset float-reg-offset (fx+ stack-arg-offset (cat-size cat)))])])))))) + int-reg-offset float-reg-offset (fx+ stack-arg-offset (cat-size cat) (cat-pad cat)))])])))))) (define do-result (lambda (result-type result-cat synthesize-first? return-stack-offset) (nanopass-case (Ltype Type) result-type @@ -3141,13 +3259,13 @@ [arg-type* (if ftd-result? (cdr arg-type*) arg-type*)] - [arg-cat* (categorize-arguments arg-type*)] - [result-cat (car (categorize-arguments (list result-type)))] + [conv* (info-foreign-conv* info)] + [arg-cat* (categorize-arguments arg-type* (extract-varargs-after-conv conv*))] + [result-cat (car (categorize-arguments (list result-type) #f))] [synthesize-first? (and ftd-result? (not (cat-indirect-bytes result-cat)) (not (eq? 'stack (cat-place result-cat))))] [indirect-result? (and ftd-result? (not synthesize-first?))] - [conv* (info-foreign-conv* info)] [adjust-active? (if-feature pthreads (memq 'adjust-active conv*) #f)] [arg-regs (let ([regs (get-registers arg-cat* 'int)]) diff --git a/src/ChezScheme/s/base-lang.ss b/src/ChezScheme/s/base-lang.ss index 96941a7fc5..745d6279fa 100644 --- a/src/ChezScheme/s/base-lang.ss +++ b/src/ChezScheme/s/base-lang.ss @@ -17,7 +17,8 @@ lookup-primref primref? primref-name primref-level primref-flags primref-arity sorry! make-preinfo preinfo? preinfo-lambda? preinfo-sexpr preinfo-sexpr-set! preinfo-src make-preinfo-lambda preinfo-lambda-name preinfo-lambda-flags preinfo-lambda-libspec - make-preinfo-call preinfo-call? preinfo-call-flags preinfo-call-check? preinfo-call-can-inline? + make-preinfo-call preinfo-call? preinfo-call-flags preinfo-call-check? + preinfo-call-can-inline? preinfo-call-no-return? preinfo-call-single-valued? prelex? make-prelex prelex-name prelex-name-set! prelex-flags prelex-flags-set! prelex-source prelex-operand prelex-operand-set! prelex-uname make-prelex* target-fixnum? target-bignum?) @@ -156,7 +157,9 @@ (define convention? (lambda (x) - (symbol? x))) + (or (symbol? x) + (and (pair? x) + (eq? 'varargs (car x)))))) (define-record-type preinfo (nongenerative #{preinfo e23pkvo5btgapnzomqgegm-2}) @@ -202,6 +205,12 @@ (define (preinfo-call-can-inline? preinfo) (not (all-set? (preinfo-call-mask no-inline) (preinfo-call-flags preinfo)))) + (define (preinfo-call-no-return? preinfo) + (all-set? (preinfo-call-mask no-return) (preinfo-call-flags preinfo))) + + (define (preinfo-call-single-valued? preinfo) + (all-set? (preinfo-call-mask single-valued) (preinfo-call-flags preinfo))) + ; language of foreign types (define-language Ltype (nongenerative-id #{Ltype czp82kxwe75y4e18-1}) diff --git a/src/ChezScheme/s/bytevector.ss b/src/ChezScheme/s/bytevector.ss index f9b8366933..98e1d7a5e0 100644 --- a/src/ChezScheme/s/bytevector.ss +++ b/src/ChezScheme/s/bytevector.ss @@ -786,7 +786,7 @@ (lambda (v) (cond [(immutable-bytevector? v) v] - [(eqv? v '#vu8()) ($tc-field 'null-immutable-bytevector ($tc))] + [(eqv? v '#vu8()) (bytevector->immutable-bytevector '#vu8())] [else (unless (bytevector? v) ($oops who "~s is not a bytevector" v)) (let ([v2 (bytevector-copy v)]) diff --git a/src/ChezScheme/s/cmacros.ss b/src/ChezScheme/s/cmacros.ss index f86f6c399d..7337af659f 100644 --- a/src/ChezScheme/s/cmacros.ss +++ b/src/ChezScheme/s/cmacros.ss @@ -357,7 +357,7 @@ ;; --------------------------------------------------------------------- ;; Version and machine types: -(define-constant scheme-version #x09050327) +(define-constant scheme-version #x0905033A) (define-syntax define-machine-types (lambda (x) @@ -375,6 +375,7 @@ (define-machine-types any + pb i3le ti3le i3nt ti3nt i3fb ti3fb @@ -393,7 +394,8 @@ arm32le tarm32le ppc32le tppc32le arm64le tarm64le - pb + arm64osx tarm64osx + ppc32osx tppc32osx ) (include "machine.def") @@ -418,6 +420,12 @@ (define-constant ptr-bytes (/ (constant ptr-bits) 8)) ; size in bytes (define-constant log2-ptr-bytes (log2 (constant ptr-bytes))) +(define-constant double-bytes 8) + +(define-constant byte-bytes 1) +(define-constant byte-bits 8) +(define-constant log2-byte-bits 3) + ;;; ordinary types must be no more than 8 bits long (define-constant ordinary-type-bits 8) ; smallest addressable unit @@ -504,7 +512,7 @@ (define-constant fasl-type-immutable-vector 37) (define-constant fasl-type-immutable-string 38) -(define-constant fasl-type-immutable-fxvector 39) +(define-constant fasl-type-flvector 39) (define-constant fasl-type-immutable-bytevector 40) (define-constant fasl-type-immutable-box 41) @@ -773,12 +781,13 @@ (define-constant countof-stencil-vector 26) (define-constant countof-record 27) (define-constant countof-phantom 28) -(define-constant countof-types 29) +(define-constant countof-flvector 29) +(define-constant countof-types 30) ;; --------------------------------------------------------------------- ;; Tags that are part of the pointer represeting an object: -;;; type-fixnum is assumed to be all zeros by at least vector, fxvector, +;;; type-fixnum is assumed to be all zeros by at least vector, fxvector, flvector, ;;; and bytevector index checks (define-constant type-fixnum 0) ; #b100/#b000 32-bit, #b000 64-bit (define-constant type-pair #b001) @@ -822,16 +831,19 @@ ;;; memory, a string or fxvector up to 1/4, and a bytevector up to 1/8. ;;; on 64-bit machines, vectors get only one of the primary tag bits, -;;; bytevectors still get two (but don't need two), and strings and -;;; fxvectors still get one. all have maximum lengths equal to the +;;; bytevectors still get two (but don't need two), and strings, fxvectors +;;; and flvectors still get one. all have maximum lengths equal to the ;;; most-positive fixnum. -;;; vector type/length field must look like a fixnum. an immutable bit sits just above the fixnum tag, with the length above that. +;;; vector type/length field must look like a fixnum. +;;; an immutable bit sits just above the fixnum tag for a vector, +;;; bytevector or string, with the length above that. (define-constant type-vector (constant type-fixnum)) ; #b000 occupied by vectors on 32- and 64-bit machines (define-constant type-bytevector #b01) (define-constant type-string #b010) -(define-constant type-fxvector #b011) +(define-constant type-fxvector #b0011) +(define-constant type-flvector #b1011) ; #b100 occupied by vectors on 32-bit machines, unused on 64-bit machines (define-constant type-other-number #b0110) ; bit 3 reset for numbers (define-constant type-bignum #b00110) ; bit 4 reset for bignums @@ -857,13 +869,14 @@ ;; Flags that matter to the GC must apply only to static-generation ;; objects, and they must not overlap with `forward-marker` -(define-constant code-flag-system #b0000001) -(define-constant code-flag-continuation #b0000010) -(define-constant code-flag-template #b0000100) -(define-constant code-flag-guardian #b0001000) -(define-constant code-flag-mutable-closure #b0010000) -(define-constant code-flag-arity-in-closure #b0100000) -(define-constant code-flag-single-valued #b1000000) +(define-constant code-flag-system #b00000001) +(define-constant code-flag-continuation #b00000010) +(define-constant code-flag-template #b00000100) +(define-constant code-flag-guardian #b00001000) +(define-constant code-flag-mutable-closure #b00010000) +(define-constant code-flag-arity-in-closure #b00100000) +(define-constant code-flag-single-valued #b01000000) +(define-constant code-flag-lift-barrier #b10000000) (define-constant fixnum-bits (case (constant ptr-bits) @@ -921,14 +934,20 @@ (min (- (expt 2 (fx- (constant ptr-bits) (constant vector-length-offset))) 1) (constant most-positive-fixnum))) -; fxvector length field (high bits) + immutabilty is stored with type +; fxvector length field (high bits) (define-constant fxvector-length-offset 4) -(define-constant fxvector-immutable-flag - (expt 2 (- (constant fxvector-length-offset) 1))) (define-constant iptr maximum-fxvector-length (min (- (expt 2 (fx- (constant ptr-bits) (constant fxvector-length-offset))) 1) (constant most-positive-fixnum))) +; flvector length field (high bits) +(define-constant flvector-length-offset 4) +(define-constant iptr maximum-flvector-length + (min (- (expt 2 (fx- (constant ptr-bits) (constant flvector-length-offset))) 1) + (constant most-positive-fixnum))) + +(define-constant never-immutable-flag 0) + ; bytevector length field (high bits) + immutabilty is stored with type (define-constant bytevector-length-offset 3) (define-constant bytevector-immutable-flag @@ -1024,7 +1043,8 @@ (define-constant mask-vector (constant mask-fixnum)) (define-constant mask-bytevector #b11) (define-constant mask-string #b111) -(define-constant mask-fxvector #b111) +(define-constant mask-fxvector #b1111) +(define-constant mask-flvector #b1111) (define-constant mask-other-number #b1111) (define-constant mask-bignum #b11111) (define-constant mask-bignum-sign #b100000) @@ -1093,12 +1113,6 @@ (define-constant mask-mutable-string (fxlogor (constant mask-string) (constant string-immutable-flag))) -(define-constant type-mutable-fxvector (constant type-fxvector)) -(define-constant type-immutable-fxvector - (fxlogor (constant type-fxvector) (constant fxvector-immutable-flag))) -(define-constant mask-mutable-fxvector - (fxlogor (constant mask-fxvector) (constant fxvector-immutable-flag))) - (define-constant type-mutable-bytevector (constant type-bytevector)) (define-constant type-immutable-bytevector (fxlogor (constant type-bytevector) (constant bytevector-immutable-flag))) @@ -1113,6 +1127,7 @@ (define-constant string-length-factor (expt 2 (constant string-length-offset))) (define-constant bignum-length-factor (expt 2 (constant bignum-length-offset))) (define-constant fxvector-length-factor (expt 2 (constant fxvector-length-offset))) +(define-constant flvector-length-factor (expt 2 (constant flvector-length-offset))) (define-constant bytevector-length-factor (expt 2 (constant bytevector-length-offset))) (define-constant char-factor (expt 2 (constant char-data-offset))) @@ -1404,6 +1419,17 @@ (constant-case ptr-bits [(32) + (define-primitive-structure-disps flvector type-typed-object + ([iptr type] + [ptr pad] ; pad needed to maintain double-word alignment for data + [double data 0]))] + [(64) + (define-primitive-structure-disps flvector type-typed-object + ([iptr type] + [double data 0]))]) + +(constant-case ptr-bits + [(32) (define-primitive-structure-disps bytevector type-typed-object ([iptr type] [ptr pad] ; pad needed to maintain double-word alignment for data @@ -1422,6 +1448,8 @@ (define-primitive-structure-disps flonum type-flonum ([double data])) +(define-constant flonum-bytes 8) + ; on 32-bit systems, the iptr pad will have no effect above and ; beyond the normal padding. on 64-bit systems, the pad ; guarantees that the forwarding address will not overwrite @@ -1551,10 +1579,6 @@ [ptr target-machine] [ptr fxlength-bv] [ptr fxfirst-bit-set-bv] - [ptr null-immutable-vector] - [ptr null-immutable-fxvector] - [ptr null-immutable-bytevector] - [ptr null-immutable-string] [ptr meta-level] [ptr compile-profile] [ptr generate-inspector-information] @@ -1602,7 +1626,7 @@ (define-primitive-structure-disps record-type type-typed-object ([ptr type] - [ptr parent] + [ptr ancestry] ; vector: parent at 0, grandparent at 1, etc. [ptr size] ; total record size in bytes, including type tag [ptr pm] ; pointer mask, where low bit corresponds to type tag [ptr mpm] ; mutable-pointer mask, where low bit for type is always 0 @@ -1844,8 +1868,10 @@ ) (define-flags preinfo-call-mask - (unchecked #b01) - (no-inline #b10) + (unchecked #b0001) + (no-inline #b0010) + (no-return #b0100) + (single-valued #b1000) ) (define-syntax define-flag-field @@ -2129,6 +2155,20 @@ (define-constant eq-hashtable-subtype-weak 1) (define-constant eq-hashtable-subtype-ephemeron 2) +(define-syntax fixmix + (syntax-rules () + [(_ x-expr) + ;; Since we tend to use the low bits of a hash code, make sure + ;; higher bits of a hash code are represented there. There's + ;; a copy of this conversion for rehashing in "segment.h". + (let* ([x x-expr] + [x1 (constant-case ptr-bits + [(64) (fxxor x (fxand (fxsra x 32) #xFFFFFFFF))] + [else x])] + [x2 (fxxor x1 (fxand (fxsra x1 16) #xFFFF))] + [x3 (fxxor x2 (fxand (fxsra x2 8) #xFF))]) + x3)])) + ; keep in sync with make-date (define-constant dtvec-nsec 0) (define-constant dtvec-sec 1) @@ -2153,6 +2193,68 @@ (define-constant time-collector-real 6) ;; --------------------------------------------------------------------- +;; vfasl + +;; For vfasl images: Similar to allocation spaces, but not all +;; allocation spaces are represented, and these spaces are more +;; fine-grained in some cases: +(define-enumerated-constants + vspace-symbol + vspace-rtd + vspace-closure + vspace-impure + vspace-pure-typed + vspace-impure-record + ;; rest rest are at then end to make the pointer bitmap + ;; end with zeros (that can be dropped): + vspace-code + vspace-data + vspace-reloc ;; can be dropped after direct to static generation + vspaces-count) + +(define-constant vspaces-offsets-count (- (constant vspaces-count) 1)) + +(define-primitive-structure-disps vfasl-header typemod + ([uptr data-size] + [uptr table-size] + + [uptr result-offset] + + ;; first starting offset is 0, so skip it in this array: + [uptr vspace-rel-offsets (constant vspaces-offsets-count)] + + [uptr symref-count] + [uptr rtdref-count] + [uptr singletonref-count])) + +(define-enumerated-constants + singleton-not-a-singleton + singleton-null-string + singleton-null-vector + singleton-null-fxvector + singleton-null-flvector + singleton-null-bytevector + singleton-null-immutable-string + singleton-null-immutable-vector + singleton-null-immutable-bytevector + singleton-eq + singleton-eqv + singleton-equal + singleton-symbol=? + singleton-symbol-symbol + singleton-symbol-ht-rtd) + +(define-constant vfasl-reloc-tag-bits 3) + +(define-enumerated-constants + vfasl-reloc-not-a-tag + vfasl-reloc-c-entry-tag + vfasl-reloc-library-entry-tag + vfasl-reloc-library-entry-code-tag + vfasl-reloc-symbol-tag + vfasl-reloc-singleton-tag) + +;; --------------------------------------------------------------------- ;; General helpers for the compiler and runtime implementation: (define-syntax default-run-cp0 @@ -2344,6 +2446,7 @@ (string? x) (bytevector? x) (fxvector? x) + (flvector? x) (memq x '(#!eof #!bwp #!base-rtd))))])) ;;; datatype support @@ -2755,6 +2858,10 @@ (sub1 #f 1 #f #t) (-1+ #f 1 #f #t) (fx* #f 2 #t #t) + (fx*/wraparound #f 2 #t #t) + (fx+/wraparound #f 2 #t #t) + (fx-/wraparound #f 2 #t #t) + (fxsll/wraparound #f 2 #t #t) (dofargint64 #f 1 #f #f) (dofretint64 #f 1 #f #f) (dofretuns64 #f 1 #f #f) @@ -2782,6 +2889,9 @@ (fxvector-ref #f 2 #t #t) (fxvector-set! #f 3 #t #t) (fxvector-length #f 1 #t #t) + (flvector-ref #f 2 #t #t) + (flvector-set! #f 3 #t #t) + (flvector-length #f 1 #t #t) (scan-remembered-set #f 0 #f #f) (fold-left1 #f 3 #f #t) (fold-left2 #f 4 #f #t) @@ -2942,6 +3052,7 @@ raw-collect-cond raw-collect-thread0-cond raw-tc-mutex + raw-terminated-cond activate-thread deactivate-thread unactivate-thread @@ -2974,7 +3085,10 @@ fllog fllog2 flexpt - flsqrt)) + flsqrt + null-immutable-vector + null-immutable-bytevector + null-immutable-string)) ) @@ -3101,6 +3215,7 @@ pb-mul pb-div pb-subz + pb-subp pb-and pb-ior pb-xor @@ -3219,8 +3334,6 @@ [double double] [double uptr] [double double double] - [int32 int32] - [int32 int32 uptr] [int32 uptr uptr uptr uptr uptr] [uptr] [uptr uptr] diff --git a/src/ChezScheme/s/compile.ss b/src/ChezScheme/s/compile.ss index 2b2b04b735..e178ba9f3e 100644 --- a/src/ChezScheme/s/compile.ss +++ b/src/ChezScheme/s/compile.ss @@ -70,7 +70,7 @@ (with-output-language (Lsrc Expr) ($c-make-closure ; pretending main is a library routine to avoid argument-count check - (let ([x `(case-lambda ,(make-preinfo-lambda #f #f (lookup-libspec main)) (clause () 0 ,x))]) + (let ([x `(case-lambda ,(make-preinfo-lambda #f #f (lookup-libspec main) #f (constant code-flag-lift-barrier)) (clause () 0 ,x))]) ($np-compile x #f)))))) (define c-set-code-quad! @@ -150,19 +150,16 @@ [(arm32) (record-case c [(arm32-abs) (n x) - ; on ARMV7 would be 8: 4-byte movi, 4-byte movt - (let ([a1 (fx- a 12)]) ; 4-byte ldr, 4-byte bra, 4-byte value + (let ([a1 (fx- a 4)]) ; [4-byte ldr, 4-byte bra,] 4-byte value (let ([x* (cons (mkcode x) x*)]) (let ([r ($reloc (constant reloc-arm32-abs) n (fx- a1 ra))]) (mkc0 (cdr c*) a (cons r r*) a1 x*))))] [(arm32-call) (n x) - ; on ARMV7 would be 12: 4-byte movi, 4-byte movt, 4-byte blx (let ([a1 (fx- a 16)]) ; 4-byte ldr, 4-byte bra, 4-byte value, 4-byte blx (let ([x* (cons (mkcode x) x*)]) (let ([r ($reloc (constant reloc-arm32-call) n (fx- a1 ra))]) (mkc0 (cdr c*) a (cons r r*) a1 x*))))] [(arm32-jump) (n x) - ; on ARMV7 would be 12: 4-byte movi, 4-byte movt, 4-byte bx (let ([a1 (fx- a 16)]) ; 4-byte ldr, 4-byte bra, 4-byte value, 4-byte bx (let ([x* (cons (mkcode x) x*)]) (let ([r ($reloc (constant reloc-arm32-jump) n (fx- a1 ra))]) @@ -411,17 +408,14 @@ [(arm32) (record-case c [(arm32-abs) (n x) - ; on ARMV7 would be 8: 4-byte movi, 4-byte movt - (let ([a1 (fx- a 12)]) ; 4-byte ldr, 4-byte bra, 4-byte value + (let ([a1 (fx- a 4)]) ; [4-byte ldr, 4-byte bra,] 4-byte value (let ([r ($reloc (constant reloc-arm32-abs) n (fx- a1 ra))]) (prf0 (cdr c*) a (cons r r*) a1 (cons x x*))))] [(arm32-call) (n x) - ; on ARMV7 would be 12: 4-byte movi, 4-byte movt, 4-byte blx (let ([a1 (fx- a 16)]) ; 4-byte ldr, 4-byte bra, 4-byte value, 4-byte blx (let ([r ($reloc (constant reloc-arm32-call) n (fx- a1 ra))]) (prf0 (cdr c*) a (cons r r*) a1 (cons x x*))))] [(arm32-jump) (n x) - ; on ARMV7 would be 12: 4-byte movi, 4-byte movt, 4-byte bx (let ([a1 (fx- a 16)]) ; 4-byte ldr, 4-byte bra, 4-byte value, 4-byte bx (let ([r ($reloc (constant reloc-arm32-jump) n (fx- a1 ra))]) (prf0 (cdr c*) a (cons r r*) a1 (cons x x*))))] @@ -493,8 +487,8 @@ (if omit-rtds? (constant fasl-omit-rtds) 0))]) (and (not (fx= flags 0)) flags))]) (c-build-fasl x t a?) - ($fasl-start p t situation - (lambda (p) (c-faslobj x t p a?))))) + ($fasl-start p t situation x + (lambda (x p) (c-faslobj x t p a?))))) (define-record-type visit-chunk (nongenerative) @@ -565,6 +559,7 @@ [$compile-profile ($compile-profile)] [generate-interrupt-trap (generate-interrupt-trap)] [$optimize-closures ($optimize-closures)] + [$lift-closures ($lift-closures)] [enable-cross-library-optimization (enable-cross-library-optimization)] [generate-covin-files (generate-covin-files)] [enable-arithmetic-left-associative (enable-arithmetic-left-associative)] @@ -616,7 +611,7 @@ (parameterize ([$target-machine (machine-type)]) (let ([t ($fasl-table)]) ($fasl-enter x1 t (constant annotation-all) 0) - ($fasl-start wpoop t (constant fasl-type-visit-revisit) (lambda (p) ($fasl-out x1 p t (constant annotation-all))))))))))) + ($fasl-start wpoop t (constant fasl-type-visit-revisit) x1 (lambda (x p) ($fasl-out x p t (constant annotation-all))))))))))) (let-values ([(rcinfo* lpinfo* final*) (compile-file-help1 x1 source-info-string)]) (when hostop ; the host library file contains expander output possibly augmented with @@ -627,7 +622,7 @@ (parameterize ([$target-machine (machine-type)]) (let ([t ($fasl-table)]) ($fasl-enter x1 t (constant annotation-all) 0) - ($fasl-start hostop t (constant fasl-type-visit-revisit) (lambda (p) ($fasl-out x1 p t (constant annotation-all))))))))) + ($fasl-start hostop t (constant fasl-type-visit-revisit) x1 (lambda (x p) ($fasl-out x p t (constant annotation-all))))))))) (cfh0 (+ n 1) (cons rcinfo* rrcinfo**) (cons lpinfo* rlpinfo**) (cons final* rfinal**))))))))))) (define library/program-info? @@ -652,7 +647,7 @@ (with-output-language (Lsrc Expr) (define (lambda-chunk lsrc) ; pretending main is a library routine to avoid argument-count check - `(case-lambda ,(make-preinfo-lambda #f #f (lookup-libspec main)) + `(case-lambda ,(make-preinfo-lambda #f #f (lookup-libspec main) #f (constant code-flag-lift-barrier)) (clause () 0 ,lsrc))) (define (visit lsrc e* rchunk*) (define (rchunks) (cons (make-visit-chunk (lambda-chunk lsrc)) rchunk*)) @@ -1610,7 +1605,7 @@ (let ([x (fold-left (lambda (outer ir) (with-output-language (Lexpand Outer) `(group ,outer ,ir))) (car ir*) (cdr ir*))]) ($fasl-enter x t (constant annotation-all) 0) - ($fasl-start wpoop t (constant fasl-type-visit-revisit) (lambda (p) ($fasl-out x p t (constant annotation-all)))))))))))))) + ($fasl-start wpoop t (constant fasl-type-visit-revisit) x (lambda (x p) ($fasl-out x p t (constant annotation-all)))))))))))))) (define build-required-library-list (lambda (node* visit-lib*) @@ -1829,43 +1824,8 @@ ; create boot loader (invoke) for entry into Scheme from C (lambda (out machine . bootfiles) (do-make-boot-header who out machine bootfiles))) - - (set-who! vfasl-convert-file - (let ([->vfasl (foreign-procedure "(cs)to_vfasl" (scheme-object) scheme-object)] - [vfasl-can-combine? (foreign-procedure "(cs)vfasl_can_combinep" (scheme-object) boolean)]) - (lambda (in-file out-file bootfile*) - (let ([op ($open-file-output-port who out-file (file-options replace))]) - (on-reset (delete-file out-file #f) - (on-reset (close-port op) - (when bootfile* - (emit-boot-header op (constant machine-type-name) bootfile*)) - (emit-header op (constant scheme-version) (constant machine-type)) - (let ([ip ($open-file-input-port who in-file (file-options compressed))]) - (on-reset (close-port ip) - (let* ([write-out (lambda (x) - (let ([bv (->vfasl x)]) - ($write-fasl-bytevectors op (list bv) (bytevector-length bv) - (constant fasl-type-visit-revisit) (constant fasl-type-vfasl))))] - [write-out-accum (lambda (accum) - (unless (null? accum) - (if (null? (cdr accum)) - (write-out (car accum)) - (write-out (list->vector (reverse accum))))))]) - (let loop ([accum '()]) - (let ([x (fasl-read ip)]) - (cond - [(eof-object? x) - (write-out-accum accum)] - [(not (vfasl-can-combine? x)) - (write-out-accum accum) - (write-out x) - (loop '())] - [(vector? x) - (loop (append (reverse (vector->list x)) accum))] - [else - (loop (cons x accum))])))) - (close-port ip))) - (close-port op))))))) + + (set! $emit-boot-header emit-boot-header) ) (set-who! $write-fasl-bytevectors diff --git a/src/ChezScheme/s/cp0.ss b/src/ChezScheme/s/cp0.ss index d1a73eb772..ad4548e885 100644 --- a/src/ChezScheme/s/cp0.ss +++ b/src/ChezScheme/s/cp0.ss @@ -119,7 +119,8 @@ ; don't use rtd-* as defined in record.ss in case we're building a patch ; file for cross compilation, because the offsets may be incorrect (define rtd-flds (csv7:record-field-accessor #!base-rtd 'flds)) - (define rtd-parent (csv7:record-field-accessor #!base-rtd 'parent)) + (define rtd-ancestors (csv7:record-field-accessor #!base-rtd 'ancestors)) + (define rtd-parent (lambda (x) (vector-ref (rtd-ancestors x) 0))) (define rtd-size (csv7:record-field-accessor #!base-rtd 'size)) (define rtd-pm (csv7:record-field-accessor #!base-rtd 'pm)) (define rtd-mpm (csv7:record-field-accessor #!base-rtd 'mpm)) @@ -175,6 +176,24 @@ (lambda (rtd index) (make-fld 'unknown (bitwise-bit-set? (rtd-mpm rtd) (fx+ index 1)) 'scheme-object 0))) + (define make-cte-info + (case-lambda + [(e) e] + [(e full? single-valued?) + (if (or full? single-valued?) + (vector e full? single-valued?) + e)])) + (define (cte-info-inline cte-info) + (if (vector? cte-info) + (vector-ref cte-info 0) + cte-info)) + (define (cte-info-procedure-full? cte-info) + (and (vector? cte-info) + (vector-ref cte-info 1))) + (define (cte-info-procedure-single-valued? cte-info) + (and (vector? cte-info) + (vector-ref cte-info 2))) + (with-output-language (Lsrc Expr) (define void-rec `(quote ,(void))) (define true-rec `(quote #t)) @@ -184,6 +203,7 @@ (define empty-string-rec `(quote "")) (define empty-bytevector-rec `(quote #vu8())) (define empty-fxvector-rec `(quote #vfx())) + (define empty-flvector-rec `(quote #vfl())) ;;; environments (module (empty-env with-extended-env lookup) @@ -351,12 +371,13 @@ (mutable opending) (mutable value) (mutable singly-referenced-score) - (mutable lifted)) + (mutable lifted) + (mutable can-lift?)) (nongenerative) (protocol (lambda (new) (lambda (exp env wd moi) - (new exp env wd moi #f 0 0 0 #f #f #f))))) + (new exp env wd moi #f 0 0 0 #f #f #f #f))))) (define-record-type lifted (fields (immutable seq?) (immutable ids) (immutable vals)) @@ -364,8 +385,20 @@ (sealed #t)) (define build-operands - (lambda (args env wd moi) - (map (lambda (x) (make-operand x env wd moi)) args))) + (lambda (ivory-so-far? args env wd moi) + (let ([opnds (map (lambda (x) (make-operand x env wd moi)) args)]) + (when (and ivory-so-far? + ;; since arguments are evaluated in any order, allow + ;; up to 1 non-ivory argument for arguments be liftable: + (let loop ([one-non-ivory? #f] [args args]) + (cond + [(null? args) #t] + [(ivory? (car args)) (loop one-non-ivory? (cdr args))] + [one-non-ivory? #f] + [else (loop #t (cdr args))]))) + (for-each (lambda (opnd) (operand-can-lift?-set! opnd #t)) + opnds)) + opnds))) (define build-cooked-opnd (lambda (e) @@ -510,7 +543,7 @@ [else #f]))) ; set up to assimilate nested let/letrec/letrec* bindings. ; lifting job is completed by cp0-call or letrec/letrec* - (define (split-value e) + (define (split-value e can-lift?) (nanopass-case (Lsrc Expr) e [(call ,preinfo0 (case-lambda ,preinfo1 (clause (,x* ...) ,interface ,body)) ,e* ...) (guard (fx= interface (length e*))) @@ -521,7 +554,8 @@ ; further, require each RHS to be pure unless the body is pure, since it's ; unsound to split apart two things that can observe a side effect or two ; allocation operations that can be separated by a continuation grab. - [(if (ivory? body) (andmap simple/profile1? e*) (andmap ivory1? e*)) + [(or can-lift? ; => `build-operands` says it's ok to lift anything past other ivory + (if (ivory? body) (andmap simple/profile1? e*) (andmap ivory1? e*))) ; assocate each lhs with cooked operand for corresponding rhs. make-record-constructor-descriptor, ; at least, counts on this to allow protocols to be inlined. (for-each (lambda (x e) (prelex-operand-set! x (build-cooked-opnd e))) x* e*) @@ -629,7 +663,7 @@ (let ([e0 (pending-protect opnd (cp0 (operand-exp opnd) ctxt (operand-env opnd) sc (operand-wd opnd) (operand-name opnd) (operand-moi opnd)))]) (let-values ([(e1 eprof) (extract-profile-forms e0)]) - (with-values (split-value e1) + (with-values (split-value e1 (operand-can-lift? opnd)) (lambda (lifted e) (let ([e (if eprof (make-seq ctxt eprof e) e)]) (operand-lifted-set! opnd lifted) @@ -1373,47 +1407,60 @@ (nanopass-case (Lsrc Expr) e [(quote ,d) #t] [(call ,preinfo ,e ,e* ...) - (let procedure-single-valued ([e e] [e* e*]) - (nanopass-case (Lsrc Expr) (result-exp e) - [,pr - (or (all-set? (prim-mask single-valued) (primref-flags pr)) - (and e* - (let ([proc-e (extract-called-procedure pr e*)]) - (and proc-e - (memoize (procedure-single-valued proc-e #f))))))] - [(case-lambda ,preinfo ,cl* ...) - (memoize (or - (all-set? (constant code-flag-single-valued) - (preinfo-lambda-flags preinfo)) - (fold-left (lambda (r cl) - (and r - (nanopass-case (Lsrc CaseLambdaClause) cl - [(clause (,x* ...) ,interface ,body) - (single-valued-join r (single-valued body))]))) - #t - cl*)))] - [(ref ,maybe-src ,x) - (let ([v (and (not (prelex-was-assigned x)) - (let ([opnd (prelex-operand x)]) - (and opnd - (operand-exp opnd))))]) - (and v - (nanopass-case (Lsrc Expr) v - [(case-lambda ,preinfo ,cl* ...) - ;; Don't recur into the clauses, since that - ;; could send us into a loop for a `letrec` - ;; binding. But use the prelex as a summary - ;; or a way to tie a loop: - (preinfo->single-valued preinfo x)] - [else #f])))] - ;; Recognize call to a loop, and use the loop's prelex in that case: - [(letrec ([,x1 (case-lambda ,preinfo ,cl* ...)]) (ref ,maybe-src ,x2)) - (and (eq? x1 x2) - (preinfo->single-valued preinfo x1))] - [(letrec* ([,x1 (case-lambda ,preinfo ,cl* ...)]) (ref ,maybe-src ,x2)) - (and (eq? x1 x2) - (preinfo->single-valued preinfo x1))] - [else #f]))] + (or (and (preinfo-call-single-valued? preinfo) + (not (preinfo-call-check? preinfo))) + (let procedure-single-valued ([e e] [e* e*]) + (nanopass-case (Lsrc Expr) (result-exp e) + [,pr + (or (all-set? (prim-mask single-valued) (primref-flags pr)) + (all-set? (prim-mask abort-op) (primref-flags pr)) + (and e* + (let ([proc-e (extract-called-procedure pr e*)]) + (and proc-e + (memoize (procedure-single-valued proc-e #f))))))] + [(case-lambda ,preinfo ,cl* ...) + (memoize (or + (all-set? (constant code-flag-single-valued) + (preinfo-lambda-flags preinfo)) + (fold-left (lambda (r cl) + (and r + (nanopass-case (Lsrc CaseLambdaClause) cl + [(clause (,x* ...) ,interface ,body) + (single-valued-join r (single-valued body))]))) + #t + cl*)))] + [(ref ,maybe-src ,x) + (let ([v (and (not (prelex-was-assigned x)) + (let ([opnd (prelex-operand x)]) + (and opnd + (operand-exp opnd))))]) + (and v + (nanopass-case (Lsrc Expr) v + [(case-lambda ,preinfo ,cl* ...) + ;; Don't recur into the clauses, since that + ;; could send us into a loop for a `letrec` + ;; binding. But use the prelex as a summary + ;; or a way to tie a loop: + (preinfo->single-valued preinfo x)] + [else #f])))] + ;; Recognize call to a loop, and use the loop's prelex in that case: + [(letrec ([,x1 (case-lambda ,preinfo ,cl* ...)]) (ref ,maybe-src ,x2)) + (and (eq? x1 x2) + (preinfo->single-valued preinfo x1))] + [(letrec* ([,x1 (case-lambda ,preinfo ,cl* ...)]) (ref ,maybe-src ,x2)) + (and (eq? x1 x2) + (preinfo->single-valued preinfo x1))] + [(call ,preinfo ,pr ,e) + (guard (eq? (primref-name pr) '$top-level-value)) + ;; Check for cross-module single-valued information: + (nanopass-case (Lsrc Expr) e + [(quote ,d) + (guard (symbol? d)) + (let ([as (assq ($target-machine) ($cte-optimization-info d))]) + (and as + (cte-info-procedure-single-valued? (cdr as))))] + [else #f])] + [else #f])))] [(ref ,maybe-src ,x) #t] [(case-lambda ,preinfo ,cl* ...) #t] [(if ,e1 ,e2 ,e3) (memoize (single-valued-join (single-valued e2) (single-valued e3)))] @@ -1746,7 +1793,7 @@ (define cp0-rec-let (lambda (seq? ids vals body ctxt env sc wd name moi) (with-extended-env ((env ids) (env ids #f)) - (let ((opnds (build-operands vals env wd moi))) + (let ((opnds (build-operands #f vals env wd moi))) ; these operands will be cleared by with-extended-env (for-each (lambda (id opnd) (prelex-operand-set! id opnd) @@ -1891,7 +1938,7 @@ (define copy2 ; ctxt is value, test, or app (lambda (maybe-src id opnd ctxt sc wd name moi) - (let ([rhs (result-exp (operand-value opnd))]) + (let loop ([rhs (result-exp (operand-value opnd))]) (nanopass-case (Lsrc Expr) rhs [(case-lambda ,preinfo1 ,cl* ...) (context-case ctxt @@ -1947,7 +1994,9 @@ [,pr (context-case ctxt [(value tail) - (if (all-set? (prim-mask (or primitive proc)) (primref-flags pr)) + ;; formerly constrained to functions marked as `primitive`, + ;; which does not include `system` procedures: + (if (all-set? (prim-mask proc) (primref-flags pr)) rhs (residualize-ref maybe-src id sc))] [(test) @@ -2242,6 +2291,12 @@ [(ref ,maybe-src ,x) (eq? x x0)] [else #f]))) arg*))] + [,pr0 + (andmap (lambda (arg) + (and (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! arg)) + [,pr (eq? pr pr0)] + [else #f]))) + arg*)] [else #f])) (begin (residualize-seq '() (cons arg arg*) ctxt) @@ -2279,7 +2334,7 @@ (residualize-seq '() (list c) ctxt) `(quote ,(and (memv dc (if-feature windows '(#\\ #\/) '(#\/))) #t)))]) - (define-inline 2 foreign-sizeof + (define-inline 2 (foreign-sizeof foreign-alignof) [(x) (and (okay-to-handle?) (let ([xval (value-visit-operand! x)]) (nanopass-case (Lsrc Expr) (result-exp xval) @@ -2290,7 +2345,13 @@ [(_ type bytes pred) (begin (residualize-seq '() (list x) ctxt) - `(quote ,bytes))])) + `(quote ,(cond + [(eq? prim-name 'foreign-alignof) + (case 'type + [(double-float single-float) (gcd (constant max-float-alignment) bytes)] + [(integer-64 unsigned-64) (gcd (constant max-integer-alignment) bytes)] + [else bytes])] + [else bytes])))])) (record-datatype cases (filter-foreign-type d) size #f))] [else #f])))]) @@ -2403,7 +2464,7 @@ [(p-opnd c-opnd) (let ((p-temp (cp0-make-temp #f)) (c-temp (cp0-make-temp #f))) (with-extended-env ((env ids) (empty-env (list p-temp c-temp) (app-opnds ctxt))) - (let ((ctxt1 (make-app '() 'value 'call #f (app-preinfo ctxt)))) + (let ((ctxt1 (make-app '() 'tail 'call #f (app-preinfo ctxt)))) (let ((*p-val (cp0 (build-ref p-temp) ctxt1 env sc wd #f moi))) (cond [(and (app-used ctxt1) @@ -2497,6 +2558,12 @@ empty-fxvector-rec)] [args #f]) + (define-inline 2 flvector + [() (begin + (residualize-seq '() '() ctxt) + empty-flvector-rec)] + [args #f]) + (define-inline 2 (eq? eqv? equal?) [(arg1 arg2) (handle-equality ctxt arg1 (list arg2))]) @@ -2599,7 +2666,11 @@ [(eqv? a ident) (if (and (fx= level 3) (null? (cdr val*)) (direct-result? (car val*))) (car val*) - (build-primcall (app-preinfo ctxt) level prim val*))] + (if (and (null? (cdr val*)) + ;; `op` may require exactly 2 arguments + (eqv? (procedure-arity-mask op) 4)) + (build-primcall (app-preinfo ctxt) level prim (cons `(quote ,ident) val*)) + (build-primcall (app-preinfo ctxt) level prim val*)))] [else (build-primcall (app-preinfo ctxt) level prim (cons `(quote ,a) val*))])])) (let* ([arg (car arg*)] [val (value-visit-operand! arg)]) @@ -2718,12 +2789,14 @@ (partial-folder plus + + 0 generic-nan?) (partial-folder plus fx+ + 0 (lambda (x) #f) 3) (r6rs-fixnum-partial-folder plus r6rs:fx+ fx+ + 0 (lambda (x) #f) 3) + (r6rs-fixnum-partial-folder plus fx+/wraparound fx+/wraparound + 0 (lambda (x) #f) 3) (partial-folder plus fl+ fl+ -0.0 fl-nan? #f obviously-fl?) (partial-folder plus cfl+ cfl+ -0.0 cfl-nan?) (partial-folder plus * * 1 exact-zero?) ; exact zero trumps nan (partial-folder plus fx* * 1 exact-zero? 3) (r6rs-fixnum-partial-folder plus r6rs:fx* fx* * 1 exact-zero? 3) + (r6rs-fixnum-partial-folder plus fx*/wraparound fx*/wraparound * 1 (lambda (x) #f) 3) (partial-folder plus fl* fl* 1.0 fl-nan? #f obviously-fl?) (partial-folder plus cfl* cfl* 1.0 cfl-nan?) @@ -2733,6 +2806,7 @@ (partial-folder minus - - 0) (partial-folder minus fx- - 0) (r6rs-fixnum-partial-folder minus r6rs:fx- fx- - 0) + (r6rs-fixnum-partial-folder minus fx-/wraparound fx-/wraparound - 0) (partial-folder minus fl- fl- -0.0) (partial-folder minus cfl- cfl- -0.0) @@ -2876,6 +2950,7 @@ (fold (fxarithmetic-shift-left tfixnum? u<fxwidth?) tfixnum? #2%bitwise-arithmetic-shift-left handle-shift) (fold (fxarithmetic-shift-right tfixnum? u<fxwidth?) tfixnum? #2%bitwise-arithmetic-shift-right handle-shift) (fold (fxsll tfixnum? u<=fxwidth?) tfixnum? #2%bitwise-arithmetic-shift-left handle-shift) + (fold (fxsll/wraparound tfixnum? u<=fxwidth?) tfixnum? #2%fxsll/wraparound handle-shift) (fold (fxsra tfixnum? u<=fxwidth?) tfixnum? #2%bitwise-arithmetic-shift-right handle-shift) (fold (fxsrl tfixnum? u<=fxwidth?) tfixnum? (lambda (x k) @@ -3023,40 +3098,47 @@ (preinfo-call-can-inline? (app-preinfo ctxt)) ; $top-level-value may be marked by previous inline (assq ($target-machine) ($cte-optimization-info d))) => (lambda (as) - (let ([opt (cdr as)]) - (nanopass-case (Lsrc Expr) opt - [(quote ,d) - (residualize-seq '() (list x) ctxt) - opt] - [,pr - (residualize-seq '() (list x) ctxt) - opt] - [(case-lambda ,preinfo ,cl* ...) - (context-case (app-ctxt ctxt) - [(test) (residualize-seq '() (list x) ctxt) true-rec] - ; reprocess to complete inlining done in the same cp0 pass and, more - ; importantly, to rewrite any prelexes so multiple call sites don't - ; result in multiple bindings for the same prelexes - [(app) - (and - ;; Check that enclosing call allows inlining, which is a - ;; separate specification from the nested `$top-level-value` call: - (preinfo-call-can-inline? (app-preinfo (app-ctxt ctxt))) - ;; The `case-lambda` form for inlining may have fewer cases - ;; than the actual binding, so only try to inline if there's - ;; a matching clause - (let ([n (length (app-opnds (app-ctxt ctxt)))]) - (cond - [(ormap (lambda (cl) - (nanopass-case (Lsrc CaseLambdaClause) cl - [(clause (,x* ...) ,interface ,body) - (= n interface)])) - cl*) - (residualize-seq '() (list x) ctxt) - (cp0 opt (app-ctxt ctxt) empty-env sc wd (app-name ctxt) moi)] - [else #f])))] - [else #f])] - [else #f])))] + (let* ([opt (cte-info-inline (cdr as))] + [full? (cte-info-procedure-full? (cdr as))]) + (and + opt + (nanopass-case (Lsrc Expr) opt + [(quote ,d) + (residualize-seq '() (list x) ctxt) + opt] + [,pr + (residualize-seq '() (list x) ctxt) + opt] + [(case-lambda ,preinfo ,cl* ...) + (context-case (app-ctxt ctxt) + [(test) (residualize-seq '() (list x) ctxt) true-rec] + ; reprocess to complete inlining done in the same cp0 pass and, more + ; importantly, to rewrite any prelexes so multiple call sites don't + ; result in multiple bindings for the same prelexes + [(app) + (and + ;; Check that enclosing call allows inlining, which is a + ;; separate specification from the nested `$top-level-value` call: + (preinfo-call-can-inline? (app-preinfo (app-ctxt ctxt))) + ;; The `case-lambda` form for inlining may have fewer cases + ;; than the actual binding, so only try to inline if there's + ;; a matching clause + ;; unless all the clauses are preserved + (let ([n (length (app-opnds (app-ctxt ctxt)))]) + (cond + [(ormap (lambda (cl) + (nanopass-case (Lsrc CaseLambdaClause) cl + [(clause (,x* ...) ,interface ,body) + (or (= n interface) + (and full? + (fx< interface 0) + (fx>= n (fx- -1 interface))))])) + cl*) + (residualize-seq '() (list x) ctxt) + (cp0 opt (app-ctxt ctxt) empty-env sc wd (app-name ctxt) moi)] + [else #f])))] + [else #f])] + [else #f]))))] [else #f])] [else #f])]) @@ -3920,6 +4002,10 @@ (and rtd (f rtd)))))) (residualize-seq '() (list ?x ?rtd) ctxt) true-rec] + [(record ,rtd ,rtd-expr ,e* ...) + (obviously-incompatible? rtd d0) + (residualize-seq '() (list ?x ?rtd) ctxt) + false-rec] [else (abandon-ship xval xres d0)]))))] [(record-type ,rtd ,e) (cond @@ -4077,7 +4163,25 @@ (non-result-exp r-expr main))) (loop (cdr e*) (cons (car e*) re*) (fx- index 1)))))] - [else #f]))] + [else + (nanopass-case (Lsrc Expr) (result-exp/indirect-ref r-expr) + [(record ,rtd1 ,rtd-expr1 ,e* ...) + (guard (< d (length e*)) + (rtd-immutable-field? rtd1 d)) + (let* ([e (list-ref e* d)] + [new-e (nanopass-case (Lsrc Expr) e + [(quote ,d) e] + [(ref ,maybe-src ,x) + (and (not (prelex-assigned x)) + (residualize-ref maybe-src x sc))] + [,pr (and (all-set? (prim-mask proc) (primref-flags pr)) + e)] + [else #f])]) + (and new-e + (begin + (residualize-seq (list ?r ?i) '() ctxt) + (non-result-exp i-expr (non-result-exp r-expr new-e)))))] + [else #f])]))] [else #f]))]) (let () @@ -4773,6 +4877,9 @@ (define-inline 2 fxvector-ref [(?x ?i) (tryref ctxt ?x ?i 'fxvector target-fixnum?)]) + (define-inline 2 flvector-ref + [(?x ?i) (tryref ctxt ?x ?i 'flvector flonum?)]) + ; skipping bytevector-u8-ref and bytevector-s8-ref, which generally need to adjust the result. (define-inline 2 list-ref @@ -5074,6 +5181,58 @@ (preinfo-call-mask)) (preinfo-call-mask no-inline)))]) (cp0 `(call ,preinfo ,e ,e* ...) ctxt env sc wd name moi))] + [(call ,preinfo ,pr ,e ,e* ...) + (guard (eq? (primref-name pr) '$app/no-return)) + (let ([preinfo (make-preinfo-call (preinfo-src preinfo) (preinfo-sexpr preinfo) + (set-flags (if (all-set? (prim-mask unsafe) (primref-flags pr)) + (preinfo-call-mask unchecked) + (preinfo-call-mask)) + (preinfo-call-mask no-inline no-return single-valued)))]) + (cp0 `(call ,preinfo ,e ,e* ...) ctxt env sc wd name moi))] + [(call ,preinfo ,pr ,e ,e* ...) + (guard (eq? (primref-name pr) '$app/value)) + (let ([preinfo (make-preinfo-call (preinfo-src preinfo) (preinfo-sexpr preinfo) + (set-flags (if (all-set? (prim-mask unsafe) (primref-flags pr)) + (preinfo-call-mask unchecked) + (preinfo-call-mask)) + (preinfo-call-mask single-valued)))]) + (cp0 `(call ,preinfo ,e ,e* ...) ctxt env sc wd name moi))] + [(call ,preinfo ,pr ,e1 ,e2 ,e3) + ;; remove wrapper for immediately applied + (guard (app? ctxt) + (or (eq? (primref-name pr) 'make-wrapper-procedure) + (eq? (primref-name pr) 'make-arity-wrapper-procedure)) + (nanopass-case (Lsrc Expr) e2 + [(quote ,d) + (and (exact? d) (integer? d) + (bitwise-bit-set? d (length (app-opnds ctxt))))] + [else #f])) + (let ([e1 (cp0 e1 ctxt env sc wd name moi)]) + (if (app-used ctxt) + (make-1seq ctxt (make-seq* 'ignored (list e2 e3)) e1) + (let ([e2 (cp0 e2 'value env sc wd #f moi)] + [e3 (cp0 e2 'value env sc wd #f moi)]) + `(call ,preinfo ,pr ,e1 ,e2 ,e3))))] + [(call ,preinfo ,pr ,e1 ,e2 ,e3) + ;; discard unused, non-error wrapper construction + (guard (or (eq? (primref-name pr) 'make-wrapper-procedure) + (eq? (primref-name pr) 'make-arity-wrapper-procedure)) + (unused-value-context? ctxt)) + (let ([e1 (cp0 e1 'value env sc wd name moi)] + [e2 (cp0 e2 'value env sc wd #f moi)] + [e3 (cp0 e3 'value env sc wd #f moi)]) + (cond + [(nanopass-case (Lsrc Expr) e2 + [(quote ,d) + (and (exact? d) (integer? d) + (nanopass-case (Lsrc Expr) e1 + [(case-lambda ,preinfo (clause (,x* ...) ,interface ,body) ...) #t] + [else #f]))] + [else #f]) + ;; can drop call + (make-1seq* 'ignored (list e1 e3))] + [else + `(call ,preinfo ,pr ,e1 ,e2 ,e3)]))] [(call ,preinfo ,e ,e* ...) (let () (define lift-let @@ -5109,7 +5268,7 @@ xids xargs)])))] [else (values e args)]))) (let-values ([(e args) (lift-let e e*)]) - (cp0-call preinfo e (build-operands args env wd moi) ctxt env sc wd name moi)))] + (cp0-call preinfo e (build-operands (ivory? e) args env wd moi) ctxt env sc wd name moi)))] [(case-lambda ,preinfo ,cl* ...) (context-case ctxt [(value tail) @@ -5276,14 +5435,14 @@ (when (enable-cross-library-optimization) (let () (define update-box! - (lambda (box e) + (lambda (box cte-info) (set-box! box (cons - (cons ($target-machine) e) + (cons ($target-machine) cte-info) (remp (lambda (as) (eq? (car as) ($target-machine))) (unbox box)))))) (nanopass-case (Lsrc Expr) e - [(quote ,d) (and (okay-to-copy? d) (update-box! box e))] - [,pr (update-box! box pr)] + [(quote ,d) (and (okay-to-copy? d) (update-box! box (make-cte-info e)))] + [,pr (update-box! box (make-cte-info pr))] [(ref ,maybe-src ,x) (and (not (prelex-was-assigned x)) (let ([rhs (result-exp (operand-value (prelex-operand x)))]) @@ -5292,15 +5451,23 @@ ;; Function registered for inlining may report fewer clauses ;; than supported by the original, since only inlinable clauses ;; are kept - (let ([cl* (fold-right (lambda (cl cl*) - (let ([cl (externally-inlinable cl exts)]) - (if cl - (cons cl cl*) - cl*))) - '() - cl*)]) - (when (pair? cl*) - (update-box! box `(case-lambda ,preinfo ,cl* ...))))] + (let ([new-cl* (fold-right (lambda (cl cl*) + (let ([cl (externally-inlinable cl exts)]) + (if cl + (cons cl cl*) + cl*))) + '() + cl*)] + [sv? (andmap (lambda (cl) + (nanopass-case (Lsrc CaseLambdaClause) cl + [(clause (,x* ...) ,interface ,body) + (single-valued? body)])) + cl*)]) + (when (or (pair? new-cl*) sv?) + (update-box! box (make-cte-info + `(case-lambda ,preinfo ,new-cl* ...) + (= (length cl*) (length new-cl*)) + sv?))))] [else #f])))] [else (void)]))) `(cte-optimization-loc ,box ,e ,exts)] diff --git a/src/ChezScheme/s/cpnanopass.ss b/src/ChezScheme/s/cpnanopass.ss index 27c0c34626..cd7af1f5d7 100644 --- a/src/ChezScheme/s/cpnanopass.ss +++ b/src/ChezScheme/s/cpnanopass.ss @@ -217,6 +217,8 @@ (annotation-expression x) x))) + (define rtd-ancestors (csv7:record-field-accessor #!base-rtd 'ancestors)) + (let () (import (nanopass) np-languages) @@ -548,7 +550,7 @@ arg-offset fp-offset rextra* rfpextra*) (if (eq? (syntax->datum (car other-type*)) 'fp) (f (cdr other*) (cdr other-type*) (cons fp-offset rtc-disp*) - arg-offset (fx+ fp-offset 8) rextra* (cons other rfpextra*)) + arg-offset (fx+ fp-offset (constant double-bytes)) rextra* (cons other rfpextra*)) (f (cdr other*) (cdr other-type*) (cons arg-offset rtc-disp*) (fx+ arg-offset (constant ptr-bytes)) fp-offset (cons other rextra*) rfpextra*))))))] [_ (syntax-error x "missing or out-of-order required registers")])] @@ -855,7 +857,7 @@ (define-record-type info-lambda (nongenerative) (parent info) (sealed #t) - (fields src sexpr libspec interface* (mutable dcl*) (mutable flags) (mutable fv*) (mutable name) + (fields src sexpr libspec (mutable interface*) (mutable dcl*) (mutable flags) (mutable fv*) (mutable name) (mutable well-known?) (mutable closure-rep) ctci (mutable pinfo*) seqno) (protocol (lambda (pargs->new) @@ -1147,7 +1149,8 @@ `(letrec ([,uvar* ,e*] ...) ,(Expr body))))] [(call ,preinfo ,e ,[e*] ...) (unless (preinfo-call? preinfo) (error 'preinfo-call "oops")) - `(call ,(make-info-call (preinfo-src preinfo) (preinfo-sexpr preinfo) (preinfo-call-check? preinfo) #f #f) + `(call ,(make-info-call (preinfo-src preinfo) (preinfo-sexpr preinfo) (preinfo-call-check? preinfo) #f + (and (preinfo-call-no-return? preinfo) (not (preinfo-call-check? preinfo)))) ,(Expr e) ,e* ...)] [(foreign (,conv* ...) ,name ,[e] (,arg-type* ...) ,result-type) (let ([info (make-info-foreign conv* arg-type* result-type #f)]) @@ -2098,6 +2101,367 @@ `(closures ([,(map binding-x b*) (,(map binding-x* b*) ...) ,(map binding-le b*)] ...) ,(f (cdr b**)))))))])) + ;;; This pass lifts all internal well-known closures to a intermost lambda body with a lift barrier + (module (np-lift-well-known-closures) + (define-syntax with-level + (syntax-rules () + [(_ [?x* ?level] ?e1 ?e2 ...) + (let ([x* ?x*] [level ?level]) + (for-each (lambda (x) (var-index-set! x level)) x*) + (let ([v (begin ?e1 ?e2 ...)]) + (for-each (lambda (x) (var-index-set! x #f)) x*) + v))])) + + (define-syntax with-lifts + (syntax-rules () + [(_ ?x* ?e1 ?e2 ...) + (with-level [?x* 'lifted] ?e1 ?e2 ...)])) + + ;; defined in or lifted to outer lambda body + (define outer? + (case-lambda + [(target x) + (let ([index (var-index x)]) + (or (eq? index 'lifted) + (fx<= index target)))] + [(target) + (lambda (x) (outer? target x))])) + + (define (lifted? x) + (eq? 'lifted (var-index x))) + + (define-record-type lift-info + (nongenerative) + (sealed #t) + (fields (mutable le**)) + (protocol (lambda (n) (lambda () (n '()))))) + + (define-record-type le-info + (nongenerative) + (sealed #t) + (fields x fv* cle)) + + (define cle-info + (lambda (cle) + (nanopass-case (L6 CaseLambdaExpr) cle + [(case-lambda ,info ,cl* ...) info]))) + + ;; simply a eq-hashtable, but can retrieve the keys deterministically + (define-record-type uvar-set + (nongenerative) + (sealed #t) + (fields ht (mutable ls)) + (protocol + (lambda (n) + (lambda (ls) + (define ht (make-eq-hashtable)) + (for-each (lambda (x) (eq-hashtable-set! ht x #t)) ls) + (n ht ls))))) + + (define uvar-set-has? + (lambda (us x) + (eq-hashtable-contains? (uvar-set-ht us) x))) + + (define uvar-set-add! + (lambda (us x) + (cond + [(null? x) (void)] + [(pair? x) + (for-each (lambda (x) (uvar-set-add! us x)) x)] + [(eq-hashtable-contains? (uvar-set-ht us) x) + (void)] + [else + (eq-hashtable-set! (uvar-set-ht us) x #t) + (uvar-set-ls-set! us (cons x (uvar-set-ls us)))]))) + + (define partition3 + (lambda (proc l1 l2 l3) + (let f ([l1 l1] [l2 l2] [l3 l3]) + (cond + [(null? l1) (values '()'())] + [(proc (car l1) (car l2) (car l3)) + (let-values ([(a b) (f (cdr l1) (cdr l2) (cdr l3))]) + (values (cons (car l1) a) b))] + [else + (let-values ([(a b) (f (cdr l1) (cdr l2) (cdr l3))]) + (values a (cons (car l1) b)))])))) + + (define info-lambda-lift-barrier? + (lambda (info) + (fx= (bitwise-and (info-lambda-flags info) (constant code-flag-lift-barrier)) + (constant code-flag-lift-barrier)))) + + (define-pass np-lift : L6 (ir) -> L6 () + (definitions + (define partition-liftable + (lambda (x* fv** cle*) + (partition3 + (lambda (x fv* cle) + (info-lambda-well-known? (cle-info cle))) + x* fv** cle*))) + + (define find-extra-arg* + (lambda (x arg-info) + (and (lifted? x) + (let ([info (uvar-info-lambda x)]) + (and info + (assq x arg-info)))))) + + (define partition-lift + (lambda (x* x** le* target) + (let f ([x* x*] [x** x**] [le* le*]) + (cond + [(null? x*) (values '() '() '())] + [(lifted? (car x*)) + ;; any free variables other than + ;; procedures lifted or defined in outermost lambda body + ;; are moved to extra arguments + (let*-values ([(new-fv* extra-arg*) (partition (outer? target) (car x**))] + [(rest* lift* extra-arg**) (f (cdr x*) (cdr x**) (cdr le*))]) + (values rest* + (cons (make-le-info (car x*) new-fv* (car le*)) + lift*) + (cons extra-arg* extra-arg**)))] + [else + (let-values ([(rest* lift* extra-arg**) + (f (cdr x*) (cdr x**) (cdr le*))]) + (values (cons (make-le-info (car x*) (car x**) (car le*)) + rest*) + lift* + extra-arg**))])))) + + (define rename + (case-lambda + [(rename-info) + (lambda (x) + (rename rename-info x))] + [(rename-info x) + (cond + [(assq x rename-info) => cdr] + [else x])])) + + (define (make-renamed x) + (make-tmp (uvar-name x))) + + (define-syntax (recur stx) + (syntax-case stx () + [(_ ?f ?e ...) + (identifier? #'?f) + (with-implicit (?f lift-info arg-info rename-info level target) + #'(?f ?e ... lift-info arg-info rename-info level target))])) + + (define rewrite-rest-body + (lambda (le-info lift-info arg-info rename-info level target) + (define new-lift-info (make-lift-info)) + (define le (let ([level (fx+ level 1)] + [lift-info new-lift-info]) + (recur CaseLambdaExpr (le-info-cle le-info)))) + (define lift-x* (map le-info-x (apply append (lift-info-le** new-lift-info)))) + (lift-info-le**-set! lift-info (append (lift-info-le** new-lift-info) (lift-info-le** lift-info))) + ;; add newly lifted procedures as free variables + (values (append lift-x* (le-info-fv* le-info)) le))) + + (define rewrite-rest-le + (lambda (le-info lift-info arg-info rename-info level target) + (define-values (new-fv* new-le) (recur rewrite-rest-body le-info)) + (define us (make-uvar-set new-fv*)) + + ;; also add extra arguments from free lifted procedures as free variables + ;; there is no need to recur since extra arguments of a lifted procedure would not be lifted procedures + (for-each + (lambda (fv) + (cond + [(find-extra-arg* fv arg-info) + => + (lambda (xe*) + (uvar-set-add! us (cdr xe*)))] + [else (void)])) + new-fv*) + + (make-le-info (le-info-x le-info) + (map (rename rename-info) (uvar-set-ls us)) + new-le))) + + (define union-extra-arg* + (lambda (le-info* arg-info extra-arg**) + (define us (make-uvar-set '())) + ;; simply computes a union since lambdas are strongly-connected after np-identify-scc + (for-each + (lambda (le-info extra-arg*) + (uvar-set-add! us extra-arg*) + (for-each + (lambda (fv) + (cond + [(find-extra-arg* fv arg-info) + => + (lambda (x+e*) + (uvar-set-add! us (cdr x+e*)))] + [else (void)])) + (le-info-fv* le-info))) + le-info* extra-arg**) + + ;;if rules in filter-liftable are changed, lambdas passed as extra arguments would no longer be well-known + (for-each + (lambda (x) + (let ([info (uvar-info-lambda x)]) + (and info + (when (info-lambda-well-known? info) + (info-lambda-well-known?-set! info #f))))) + (uvar-set-ls us)) + + (uvar-set-ls us))) + + (define rewrite-lifted-le + (lambda (le-info extra-arg* lift-info arg-info rename-info level target) + (define-values (new-le lift-x*) + (recur LiftedCaseLambdaExpr (le-info-cle le-info) extra-arg*)) + (nanopass-case (L6 CaseLambdaExpr) new-le + [(case-lambda ,info (clause (,x** ...) ,mcp* ,interface* ,body*) ...) + (let* () + (info-lambda-interface*-set! info interface*) + (make-le-info (le-info-x le-info) + ;; add newly lifted procedures as free variables + (append lift-x* (map (rename rename-info) (le-info-fv* le-info))) + new-le))]))) + ) + + ;; arg-info : lifted-x -> unrenamed extra-arg* + ;; rename-info : unrenamed x -> renamed x + (Expr : Expr (ir lift-info arg-info rename-info level target) -> Expr () + [,x (rename rename-info x)] + + [(call ,info ,mdcl ,x ,[e*] ...) + (cond + [(find-extra-arg* x arg-info) + => + (lambda (x+extra-arg*) + `(call ,info ,mdcl ,(rename rename-info x) + ,(append (map (rename rename-info) (cdr x+extra-arg*)) e*) ...))] + [else + `(call ,info ,mdcl ,(rename rename-info x) ,e* ...)])] + + [(let ([,x* ,[e*]] ...) ,body) + (with-level [x* level] + `(let ([,x* ,e*] ...) ,(recur Expr body)))] + + [(mvlet ,[e] ((,x** ...) ,interface* ,body*) ...) + `(mvlet ,e + ((,x** ...) + ,interface* + ,(map (lambda (x* body) + (with-level [x* level] + (recur Expr body))) + x** body*)) + ...)] + [(loop ,x (,x* ...) ,body) + (with-level [(list x) level] + `(loop ,x (,x* ...) ,(recur Expr body)))] + + ;; a lift barrier on this level + [(closures ([,x* (,x** ...) ,le*] ...) ,body) + (guard (fx= level target)) + (with-level [x* level] + (let f ([x* x*] [x** x**] [le* le*] [rx* '()] [rfv** '()] [rle* '()]) + (cond + [(null? x*) + `(closures ([,(reverse rx*) (,(reverse rfv**) ...) ,(reverse rle*)] ...) + ,(recur Expr body))] + [else + (let*-values ([(new-lift-info) (make-lift-info)] + [(new-le) (let ([level (fx+ level 1)] [lift-info new-lift-info]) + (recur CaseLambdaExpr (car le*)))] + [(lift*) (apply append (lift-info-le** new-lift-info))]) + (f (cdr x*) (cdr x**) (cdr le*) + (append (map le-info-x lift*) (cons (car x*) rx*)) + (append (map le-info-fv* lift*) (cons (append (car x**) (map le-info-x lift*)) rfv**)) + (append (map le-info-cle lift*) (cons new-le rle*))))])))] + + [(closures ([,x* (,x** ...) ,le*] ...) ,body) + (let-values ([(lift-x* non-lift-x*) (partition-liftable x* x** le*)]) + (with-level [non-lift-x* level] + (with-lifts lift-x* + (let*-values ([(rest-le* lift-le* extra-arg**) (partition-lift x* x** le* target)] + [(extra-arg*) (union-extra-arg* lift-le* arg-info extra-arg**)] + [(arg-info) (append (map (lambda (le-info) + (cons (le-info-x le-info) extra-arg*)) + lift-le*) + arg-info)] + [(rest-le*) + (map (lambda (le-info) (recur rewrite-rest-le le-info)) + rest-le*)] + [(lift-le*) + (map (lambda (le-info) + (recur rewrite-lifted-le le-info extra-arg*)) + lift-le*)]) + (unless (null? lift-le*) + (lift-info-le**-set! lift-info (cons lift-le* (lift-info-le** lift-info)))) + (let ([body (recur Expr body)]) + (cond + [(null? rest-le*) body] + [else + `(closures ([,(map le-info-x rest-le*) (,(map le-info-fv* rest-le*) ...) + ,(map le-info-cle rest-le*)] ...) + ,body)]))))))]) + + (CaseLambdaClause : CaseLambdaClause (ir lift-info arg-info rename-info level target) -> CaseLambdaClause () + [(clause (,x* ...) ,mcp ,interface ,body) + (with-level [x* level] + (let* ([old-le** (lift-info-le** lift-info)] + [new-body (recur Expr body)]) + `(clause (,x* ...) + ,(or mcp + ;;introduce a cpvar if something lifted from this clause + (and (not (eq? (lift-info-le** lift-info) old-le**)) + (make-cpvar))) + ,interface ,new-body)))]) + (CaseLambdaExpr : CaseLambdaExpr (ir lift-info arg-info rename-info level target) -> CaseLambdaExpr () + [(case-lambda ,info ,cl* ...) + `(case-lambda + ,info + ,(if (info-lambda-lift-barrier? info) + (let ([target level]) + (map (lambda (cl) (recur CaseLambdaClause cl)) cl*)) + (map (lambda (cl) (recur CaseLambdaClause cl)) cl*)) + ...)]) + + (LiftedCaseLambdaClause : CaseLambdaClause (ir extra-arg* lift-info arg-info rename-info level target) -> CaseLambdaClause () + [(clause (,x* ...) ,mcp ,interface ,body) + (with-level [x* level] + (let* ([new-extra-arg* (map make-renamed extra-arg*)] + [n (length new-extra-arg*)] + [new-rename-info (append (map cons extra-arg* new-extra-arg*) rename-info)] + [old-le** (lift-info-le** lift-info)] + [new-body (let ([rename-info new-rename-info]) + (recur Expr body))] + [new-interface (cond + [(fx< interface 0) (fx- interface n)] + [else (fx+ interface n)])]) + `(clause (,(append new-extra-arg* x*) ...) + ,(or mcp + ;;introduce a cpvar if something lifted from this clause + (and (not (eq? (lift-info-le** lift-info) old-le**)) + (make-cpvar))) + ,new-interface ,new-body)))]) + + (LiftedCaseLambdaExpr : CaseLambdaExpr (ir extra-arg* lift-info arg-info rename-info level target) -> CaseLambdaExpr (lift-x*) + [(case-lambda ,info ,cl* ...) + (let* ([new-lift-info (make-lift-info)] + [cl* (let ([lift-info new-lift-info]) + (if (info-lambda-lift-barrier? info) + (let ([target level]) + (map (lambda (cl) (recur LiftedCaseLambdaClause cl extra-arg*)) cl*)) + (map (lambda (cl) (recur LiftedCaseLambdaClause cl extra-arg*)) cl*)))] + [lift-x* (map le-info-x (apply append (lift-info-le** new-lift-info)))]) + (lift-info-le**-set! lift-info (append (lift-info-le** new-lift-info) (lift-info-le** lift-info))) + (values `(case-lambda ,info ,cl* ...) lift-x*))]) + + (CaseLambdaExpr ir (make-lift-info) '() '() 0 0)) + + (define np-lift-well-known-closures + (lambda (ir) + (let ([ir (np-lift ir)]) + (np-identify-scc ir))))) + (module (np-expand-closures np-expand/optimize-closures) (define sort-bindings ; sort-bindings uses the otherwise unneeded info-lambda-seqno to put labels @@ -3048,6 +3412,10 @@ (guard (eq? 'bytevector-ieee-double-native-set! (primref-name pr))) (Expr e3 #t) #f] + [(call ,info ,mdcl ,pr ,[e1 #f -> * fp?1] ,[e2 #f -> * fp?2] ,e3) + (guard (eq? 'flvector-set! (primref-name pr))) + (Expr e3 #t) + #f] [(call ,info ,mdcl ,pr ,[e* #f -> * fp?] ...) (primref-flonum-result? pr)] [(loop ,x (,x* ...) ,body) @@ -3587,6 +3955,12 @@ (define build-fix (lambda (e) (%inline sll ,e ,(%constant fixnum-offset)))) + (define build-double-scale + (lambda (e) + (constant-case ptr-bits + [(32) (%inline sll ,e (immediate 1))] + [(64) e] + [else ($oops 'build-double-scale "unknown ptr-bit size ~s" (constant ptr-bits))]))) (define build-unfix (lambda (e) (nanopass-case (L7 Expr) e @@ -3727,6 +4101,8 @@ [(base index offset e build-assign build-barrier-seq) (if (nanopass-case (L7 Expr) e [(quote ,d) (ptr->imm d)] + [(call ,info ,mdcl ,pr ,e* ...) + (eq? 'fixnum ($sgetprop (primref-name pr) '*result-type* #f))] [else #f]) (build-assign base index offset e) (let ([a (if (eq? index %zero) @@ -3805,7 +4181,7 @@ ,(constant-case ptr-bytes [(4) (case elt-bytes - [(1) (let ([imm (logand imm #xff)]) + [(1) (let ([imm (logand imm #xff)])< (let ([imm (logor (ash imm 8) imm)]) (logor (ash imm 16) imm)))] [(2) (let ([imm (logand imm #xffff)]) @@ -4588,7 +4964,8 @@ [(e) (ensure-single-valued e #f)]) (define-inline 2 eq? [(e1 e2) - (or (relop-length RELOP= e1 e2) + (or (eqvop-null-fptr e1 e2) + (relop-length RELOP= e1 e2) (%inline eq? ,e1 ,e2))]) (define-inline 2 keep-live [(e) (%seq ,(%inline keep-live ,e) ,(%constant svoid))]) @@ -4780,6 +5157,8 @@ [(e1 . e*) (reduce src sexpr moi e1 e*)]) (define-inline 3 r6rs:fx+ ; limited to two arguments [(e1 e2) (%inline + ,e1 ,e2)]) + (define-inline 3 fx+/wraparound + [(e1 e2) (%inline + ,e1 ,e2)]) (define-inline 3 fx1+ [(e) (%inline + ,e (immediate ,(fix 1)))]) (define-inline 2 $fx+? @@ -4825,7 +5204,13 @@ (goto ,Llib))))] [(e1 . e*) #f]) (define-inline 2 r6rs:fx+ ; limited to two arguments - [(e1 e2) (go src sexpr e1 e2)])) + [(e1 e2) (go src sexpr e1 e2)]) + (define-inline 2 fx+/wraparound + [(e1 e2) + (bind #t (e1 e2) + `(if ,(build-fixnums? (list e1 e2)) + ,(%inline + ,e1 ,e2) + ,(build-libcall #t src sexpr fx+/wraparound e1 e2)))])) (define-inline 3 fx- [(e) (%inline - (immediate 0) ,e)] @@ -4834,6 +5219,8 @@ (define-inline 3 r6rs:fx- ; limited to one or two arguments [(e) (%inline - (immediate 0) ,e)] [(e1 e2) (%inline - ,e1 ,e2)]) + (define-inline 3 fx-/wraparound + [(e1 e2) (%inline - ,e1 ,e2)]) (define-inline 3 fx1- [(e) (%inline - ,e (immediate ,(fix 1)))]) (define-inline 2 $fx-? @@ -4875,7 +5262,13 @@ [(e1 . e*) #f]) (define-inline 2 r6rs:fx- ; limited to one or two arguments [(e) (go src sexpr `(immediate ,(fix 0)) e)] - [(e1 e2) (go src sexpr e1 e2)])) + [(e1 e2) (go src sexpr e1 e2)]) + (define-inline 2 fx-/wraparound + [(e1 e2) + (bind #t (e1 e2) + `(if ,(build-fixnums? (list e1 e2)) + ,(%inline - ,e1 ,e2) + ,(build-libcall #t src sexpr fx-/wraparound e1 e2)))])) (define-inline 2 fx1- [(e) (let ([Llib (make-local-label 'Llib)]) (bind #t (e) @@ -4960,6 +5353,8 @@ [(e1 . e*) (reduce src sexpr moi e1 e*)]) (define-inline 3 r6rs:fx* ; limited to two arguments [(e1 e2) (build-fx* e1 e2 #f)]) + (define-inline 3 fx*/wraparound + [(e1 e2) (build-fx* e1 e2 #f)]) (let () (define (go src sexpr e1 e2) (let ([Llib (make-local-label 'Llib)]) @@ -4993,7 +5388,13 @@ (goto ,Llib))))] [(e1 . e*) #f]) (define-inline 2 r6rs:fx* ; limited to two arguments - [(e1 e2) (go src sexpr e1 e2)])) + [(e1 e2) (go src sexpr e1 e2)]) + (define-inline 2 fx*/wraparound + [(e1 e2) + (bind #t (e1 e2) + `(if ,(build-fixnums? (list e1 e2)) + ,(build-fx* e1 e2 #f) + ,(build-libcall #t src sexpr fx*/wraparound e1 e2)))])) (let () (define build-fx/p2 (lambda (e1 p2) @@ -5148,6 +5549,8 @@ (define-inline 3 fxsll [(e1 e2) (do-fxsll e1 e2)]) (define-inline 3 fxarithmetic-shift-left + [(e1 e2) (do-fxsll e1 e2)]) + (define-inline 3 fxsll/wraparound [(e1 e2) (do-fxsll e1 e2)])) (define-inline 3 fxsrl [(e1 e2) @@ -5624,8 +6027,7 @@ (typed-object-pred $code? mask-code type-code) (typed-object-pred $exactnum? mask-exactnum type-exactnum) (typed-object-pred fxvector? mask-fxvector type-fxvector) - (typed-object-pred mutable-fxvector? mask-mutable-fxvector type-mutable-fxvector) - (typed-object-pred immutable-fxvector? mask-mutable-fxvector type-immutable-fxvector) + (typed-object-pred flvector? mask-flvector type-flvector) (typed-object-pred $inexactnum? mask-inexactnum type-inexactnum) (typed-object-pred $rtd-counts? mask-rtd-counts type-rtd-counts) (typed-object-pred phantom-bytevector? mask-phantom type-phantom) @@ -5814,6 +6216,28 @@ (let ([n (length e*)]) (list-bind #f (e*) (bind #t ([t (%constant-alloc type-typed-object + (fx+ (constant header-size-flvector) (fx* n (constant flonum-bytes))))]) + (let loop ([e* e*] [i 0]) + (if (null? e*) + `(seq + (set! ,(%mref ,t ,(constant flvector-type-disp)) + (immediate ,(+ (fx* n (constant flvector-length-factor)) + (constant type-flvector)))) + ,t) + `(seq + (set! ,(%mref ,t ,%zero ,(fx+ i (constant flvector-data-disp)) fp) ,(car e*)) + ,(loop (cdr e*) (fx+ i (constant flonum-bytes)))))))))) + (define-inline 2 flvector + [() `(quote #vfl())] + [e* (and (andmap (lambda (x) (constant? flonum? x)) e*) (go e*))]) + (define-inline 3 flvector + [() `(quote #vfl())] + [e* (go e*)])) + (let () + (define (go e*) + (let ([n (length e*)]) + (list-bind #f (e*) + (bind #t ([t (%constant-alloc type-typed-object (fx+ (constant header-size-string) (fx* n (constant string-char-bytes))))]) (let loop ([e* e*] [i 0]) (if (null? e*) @@ -6054,6 +6478,7 @@ [(e) (extract-length (%mref ,e ,(constant type-disp)) (constant length-offset))])])) (def-len vector-length vector-type-disp vector-length-offset) (def-len fxvector-length fxvector-type-disp fxvector-length-offset) + (def-len flvector-length flvector-type-disp flvector-length-offset) (def-len string-length string-type-disp string-length-offset) (def-len bytevector-length bytevector-type-disp bytevector-length-offset) (def-len $bignum-length bignum-type-disp bignum-length-offset) @@ -6073,6 +6498,7 @@ (label ,Lerr ,(build-libcall #t #f sexpr prim e)))))])])) (def-len vector-length mask-vector type-vector vector-type-disp vector-length-offset) (def-len fxvector-length mask-fxvector type-fxvector fxvector-type-disp fxvector-length-offset) + (def-len flvector-length mask-flvector type-flvector flvector-type-disp flvector-length-offset) (def-len string-length mask-string type-string string-type-disp string-length-offset) (def-len bytevector-length mask-bytevector type-bytevector bytevector-type-disp bytevector-length-offset) (def-len stencil-vector-mask mask-stencil-vector type-stencil-vector stencil-vector-type-disp stencil-vector-mask-offset)) @@ -6553,6 +6979,8 @@ (when-feature pthreads (define-inline 2 $raw-tc-mutex [() `(literal ,(make-info-literal #f 'entry (lookup-c-entry raw-tc-mutex) 0))]) + (define-inline 2 $raw-terminated-cond + [() `(literal ,(make-info-literal #f 'entry (lookup-c-entry raw-terminated-cond) 0))]) (define-inline 2 $raw-collect-cond [() `(literal ,(make-info-literal #f 'entry (lookup-c-entry raw-collect-cond) 0))]) (define-inline 2 $raw-collect-thread0-cond @@ -6762,6 +7190,19 @@ [(e0 e1) (build-libcall #f src sexpr fxsll e0 e1)]) (define-inline 2 fxarithmetic-shift-left [(e0 e1) (build-libcall #f src sexpr fxarithmetic-shift-left e0 e1)]) + (define-inline 2 fxsll/wraparound + [(e1 e2) + (bind #t (e1 e2) + `(if ,(nanopass-case (L7 Expr) e2 + [(quote ,d) + (guard (target-fixnum? d) + ($fxu< d (fx+ 1 (constant fixnum-bits)))) + (build-fixnums? (list e1 e2))] + [else + (build-and (build-fixnums? (list e1 e2)) + (%inline u< ,e2 (immediate ,(fix (fx+ 1 (constant fixnum-bits))))))]) + ,(%inline sll ,e1 ,(build-unfix e2)) + ,(build-libcall #t src sexpr fxsll/wraparound e1 e2)))]) (define-inline 3 display-string [(e-s) (build-libcall #f src sexpr display-string e-s (%tc-ref current-output))] [(e-s e-op) (build-libcall #f src sexpr display-string e-s e-op)]) @@ -9122,8 +9563,8 @@ [(e-name e-handler e-ib e-ob) (go e-name e-handler e-ib e-ob `(quote #f))] [(e-name e-handler e-ib e-ob e-info) (go e-name e-handler e-ib e-ob e-info)])))) (let () - (define build-fxvector-ref-check (build-ref-check fxvector-type-disp maximum-fxvector-length fxvector-length-offset type-fxvector mask-fxvector fxvector-immutable-flag)) - (define build-fxvector-set!-check (build-ref-check fxvector-type-disp maximum-fxvector-length fxvector-length-offset type-mutable-fxvector mask-mutable-fxvector fxvector-immutable-flag)) + (define build-fxvector-ref-check (build-ref-check fxvector-type-disp maximum-fxvector-length fxvector-length-offset type-fxvector mask-fxvector never-immutable-flag)) + (define build-fxvector-set!-check (build-ref-check fxvector-type-disp maximum-fxvector-length fxvector-length-offset type-fxvector mask-fxvector never-immutable-flag)) (define-inline 2 $fxvector-ref-check? [(e-fv e-i) (bind #t (e-fv e-i) (build-fxvector-ref-check e-fv e-i #f))]) (define-inline 2 $fxvector-set!-check? @@ -9162,9 +9603,55 @@ (bind #t (e-fv e-i e-new) `(if ,(build-fxvector-set!-check e-fv e-i e-new) ,(go e-fv e-i e-new) - ,(build-libcall #t src sexpr fxvector-set! e-fv e-i e-new)))]) - (define-inline 3 $fxvector-set-immutable! - [(e-fv) ((build-set-immutable! fxvector-type-disp fxvector-immutable-flag) e-fv)]))) + ,(build-libcall #t src sexpr fxvector-set! e-fv e-i e-new)))]))) + (let () + (define build-flvector-ref-check (build-ref-check flvector-type-disp maximum-flvector-length flvector-length-offset type-flvector mask-flvector never-immutable-flag)) + (define build-flvector-set!-check (build-ref-check flvector-type-disp maximum-flvector-length flvector-length-offset type-flvector mask-flvector never-immutable-flag)) + (define-inline 2 $flvector-ref-check? + [(e-fv e-i) (bind #t (e-fv e-i) (build-flvector-ref-check e-fv e-i #f))]) + (define-inline 2 $flvector-set!-check? + [(e-fv e-i) (bind #t (e-fv e-i) (build-flvector-set!-check e-fv e-i #f))]) + (let () + (define (go e-fv e-i) + (cond + [(expr->index e-i 1 (constant maximum-flvector-length)) => + (lambda (index) + `(unboxed-fp ,(%mref ,e-fv ,%zero ,(+ (fx* index (constant flonum-bytes)) (constant flvector-data-disp)) fp)))] + [else `(unboxed-fp ,(%mref ,e-fv ,(build-double-scale e-i) ,(constant flvector-data-disp) fp))])) + (define-inline 3 flvector-ref + [(e-fv e-i) (go e-fv e-i)]) + (define-inline 2 flvector-ref + [(e-fv e-i) + (bind #t (e-fv e-i) + `(if ,(build-flvector-ref-check e-fv e-i #f) + ,(go e-fv e-i) + ,(build-libcall #t src sexpr flvector-ref e-fv e-i)))])) + (let () + (define (go e-fv e-i e-new) + `(set! + ,(cond + [(expr->index e-i 1 (constant maximum-flvector-length)) => + (lambda (index) + (%mref ,e-fv ,%zero ,(+ (fx* index (constant flonum-bytes)) (constant flvector-data-disp)) fp))] + [else (%mref ,e-fv ,(build-double-scale e-i) ,(constant flvector-data-disp) fp)]) + ,e-new)) + (define (checked-go src sexpr e-fv e-i e-new add-check) + `(if ,(add-check (build-flvector-set!-check e-fv e-i #f)) + ,(go e-fv e-i e-new) + ,(build-libcall #t src sexpr flvector-set! e-fv e-i e-new))) + (define-inline 3 flvector-set! + [(e-fv e-i e-new) + (go e-fv e-i e-new)]) + (define-inline 2 flvector-set! + [(e-fv e-i e-new) + (bind #t (e-fv e-i) + (if (known-flonum-result? e-new) + (bind #t fp (e-new) + (checked-go src sexpr e-fv e-i e-new values)) + (bind #t (e-new) + (checked-go src sexpr e-fv e-i e-new + (lambda (e) + (build-and e (build-flonums? (list e-new))))))))]))) (let () (define build-string-ref-check (lambda (e-s e-i) @@ -9465,7 +9952,14 @@ ,(%mref ,e-bv ,(constant bytevector-type-disp)) ,(%constant bytevector-length-offset)) e-fill) - ,(%constant svoid)))])) + ,(%constant svoid)))]) + (define-inline 2 bytevector->immutable-bytevector + [(e-bv) + (nanopass-case (L7 Expr) e-bv + [(quote ,d) + (guard (bytevector? d) (= 0 (bytevector-length d))) + `(literal ,(make-info-literal #f 'entry (lookup-c-entry null-immutable-bytevector) 0))] + [else #f])])) (let () (define build-bytevector @@ -10011,7 +10505,14 @@ (constant string-length-offset) (constant string-char-offset)) e-fill)) - ,(%constant svoid))])) + ,(%constant svoid))]) + (define-inline 2 string->immutable-string + [(e-str) + (nanopass-case (L7 Expr) e-str + [(quote ,d) + (guard (string? d) (= 0 (string-length d))) + `(literal ,(make-info-literal #f 'entry (lookup-c-entry null-immutable-string) 0))] + [else #f])])) (let () (define build-fxvector-fill @@ -10085,6 +10586,59 @@ ,(%constant svoid))])) (let () + ;; Used only to fill with 0s: + (define build-flvector-fill + (make-build-fill (constant ptr-bytes) (constant flvector-data-disp))) + (meta-assert (= (constant log2-ptr-bytes) (constant fixnum-offset))) + (let () + (define do-make-flvector + (lambda (e-length) + (if (constant? (lambda (x) (and (fixnum? x) (fx<= 0 x 10000))) e-length) + (let ([n (constant-value e-length)]) + (if (fx= n 0) + `(quote ,(flvector)) + (let ([bytes (fx* n (constant flonum-bytes))]) + (bind #t ([t (%constant-alloc type-typed-object + (fx+ (constant header-size-flvector) bytes))]) + `(seq + (set! ,(%mref ,t ,(constant flvector-type-disp)) + (immediate ,(fx+ (fx* n (constant flvector-length-factor)) + (constant type-flvector)))) + ,(build-flvector-fill t `(immediate ,bytes) `(immediate 0))))))) + (bind #t (e-length) ; fixnum length doubles as byte count + (let ([t-fxv (make-tmp 'tfxv)]) + `(if ,(%inline eq? ,e-length (immediate 0)) + (quote ,(flvector)) + (let ([,t-fxv (alloc ,(make-info-alloc (constant type-typed-object) #f #f) + ,(%inline logand + ,(%inline + ,(build-double-scale e-length) + (immediate ,(fx+ (constant header-size-flvector) + (fx- (constant byte-alignment) 1)))) + (immediate ,(- (constant byte-alignment)))))]) + (seq + (set! ,(%mref ,t-fxv ,(constant flvector-type-disp)) + ,(build-type/length e-length + (constant type-flvector) + (constant fixnum-offset) + (constant flvector-length-offset))) + ,(build-flvector-fill t-fxv (build-double-scale e-length) `(immediate 0)))))))))) + (define-inline 3 make-flvector + [(e-length) (do-make-flvector e-length)] + [(e-length e-init) #f]) + (let () + (define (valid-length? e-length) + (constant? + (lambda (x) + (and (or (fixnum? x) (bignum? x)) + (<= 0 x (constant maximum-flvector-length)))) + e-length)) + (define-inline 2 make-flvector + [(e-length) + (and (valid-length? e-length) + (do-make-flvector e-length))] + [(e-length e-init) #f])))) + + (let () (define build-vector-fill (make-build-fill (constant ptr-bytes) (constant vector-data-disp))) (meta-assert (= (constant log2-ptr-bytes) (constant fixnum-offset))) @@ -10138,7 +10692,14 @@ [(e-length e-fill) (and (valid-length? e-length) (constant? fixnum? e-fill) - (do-make-vector e-length e-fill))])))) + (do-make-vector e-length e-fill))])) + (define-inline 2 vector->immutable-vector + [(e-vec) + (nanopass-case (L7 Expr) e-vec + [(quote ,d) + (guard (vector? d) (fx= 0 (vector-length d))) + `(literal ,(make-info-literal #f 'entry (lookup-c-entry null-immutable-vector) 0))] + [else #f])]))) (let () (meta-assert (= (constant log2-ptr-bytes) (constant fixnum-offset))) @@ -10540,23 +11101,34 @@ ,e-rtd)))))) (define build-unsealed-isa? (lambda (e e-rtd) - (let ([t (make-assigned-tmp 't)] [Ltop (make-local-label 'Ltop)]) - (bind #t (e e-rtd) - (build-and - (%type-check mask-typed-object type-typed-object ,e) - `(let ([,t ,(%mref ,e ,(constant typed-object-type-disp))]) - ,(build-simple-or - (%inline eq? ,t ,e-rtd) - (build-and + (let ([t (make-tmp 't)] [a (make-tmp 'a)]) + (let ([known-depth (nanopass-case (L7 Expr) e-rtd + [(quote ,d) (and (record-type-descriptor? d) + (vector-length (rtd-ancestors d)))] + [else #f])]) + (bind #t (e e-rtd) + (build-and + (%type-check mask-typed-object type-typed-object ,e) + `(let ([,t ,(%mref ,e ,(constant typed-object-type-disp))]) + ,(build-simple-or + (%inline eq? ,t ,e-rtd) + (build-and (%type-check mask-record type-record ,t) - `(label ,Ltop - (seq - (set! ,t ,(%mref ,t ,(constant record-type-parent-disp))) - ,(build-simple-or - (%inline eq? ,t ,e-rtd) - `(if ,(%inline eq? ,t ,(%constant sfalse)) - ,(%constant sfalse) - (goto ,Ltop))))))))))))) + `(let ([,a ,(%mref ,t ,(constant record-type-ancestry-disp))]) + ,(begin + ;; take advantage of being able to use the type field of a vector + ;; as a pointer offset with just shifting: + (safe-assert (zero? (constant type-vector))) + (bind #f ([d (%inline -/pos ,(%mref ,a ,(constant vector-type-disp)) + ,(if known-depth + `(immediate ,(fxsll known-depth (constant vector-length-offset))) + (%mref ,(%mref ,e-rtd ,(constant record-type-ancestry-disp)) + ,(constant vector-type-disp))))]) + `(if (inline ,(make-info-condition-code 'positive #f #t) ,%condition-code) + ,(%inline eq? ,e-rtd ,(%mref ,a + ,(translate d (constant vector-length-offset) (constant log2-ptr-bytes)) + ,(fx- (constant vector-data-disp) (constant ptr-bytes)))) + ,(%constant sfalse)))))))))))))) (define-inline 3 record? [(e) (build-record? e)] [(e e-rtd) @@ -11115,7 +11687,7 @@ (lambda (ir setup*) (if (var? ir) (values ir setup*) - (let ([tmp (make-tmp 't 'uptr)]) + (let ([tmp (make-tmp 't 'ptr)]) (values tmp (cons (Rhs ir tmp) setup*)))))) (define Lvalue? (lambda (x) @@ -11168,7 +11740,7 @@ (literal ,(make-info-literal #t 'object '$oops (constant symbol-value-disp))) ,(%constant sfalse) (literal ,(make-info-literal #f 'object - (format "returned ~r values to single value return context" + (format "returned ~a values to single value return context" (length t*)) 0))) (set! ,lvalue ,(%constant svoid)))] [else (sorry! who "unexpected Rhs expression ~s" e)]))))))) @@ -11586,7 +12158,7 @@ (literal ,(make-info-literal #t 'object '$oops (constant symbol-value-disp))) ,(%constant sfalse) (literal ,(make-info-literal #f 'object - (format "returned ~r values to single value return context" + (format "returned ~a values to single value return context" (length t*)) 0)) ()) (true))]) @@ -16311,12 +16883,15 @@ (define asm-rp-compact-header (lambda (code* err? fs lpm func code-size) (let ([size (constant-case ptr-bits [(32) 'long] [(64) 'quad])]) - (let* ([code* (cons* `(,size . ,(fxior (constant compact-header-mask) - (if err? - (constant compact-header-values-error-mask) - 0) - (fxsll fs (constant compact-frame-words-offset)) - (fxsll lpm (constant compact-frame-mask-offset)))) + (let* ([code* (cons* `(,size . ,(let ([v (bitwise-ior + (constant compact-header-mask) + (if err? + (constant compact-header-values-error-mask) + 0) + (bitwise-arithmetic-shift-left fs (constant compact-frame-words-offset)) + (bitwise-arithmetic-shift-left lpm (constant compact-frame-mask-offset)))]) + (safe-assert (target-fixnum? v)) + v)) (aop-cons* `(asm "mrv pt:" (,lpm ,fs ,(if err? 'error 'continue))) code*))] [code* (cons* @@ -18561,6 +19136,9 @@ (pass np-convert-closures unparse-L6) (pass np-optimize-direct-call unparse-L6) (pass np-identify-scc unparse-L6) + (if ($lift-closures) + (pass np-lift-well-known-closures unparse-L6) + (lambda (ir) ir)) (if ($optimize-closures) (pass np-expand/optimize-closures unparse-L7) (pass np-expand-closures unparse-L7)) @@ -18606,4 +19184,6 @@ (set! $track-static-closure-counts track-static-closure-counts) (set! $optimize-closures (make-parameter #t (lambda (x) (and x #t)))) + + (set! $lift-closures (make-parameter #t (lambda (x) (and x #t)))) ) diff --git a/src/ChezScheme/s/cprep.ss b/src/ChezScheme/s/cprep.ss index e43357de62..df2896a5e1 100644 --- a/src/ChezScheme/s/cprep.ss +++ b/src/ChezScheme/s/cprep.ss @@ -131,7 +131,8 @@ '(let $primitive quote begin case-lambda library-case-lambda lambda if set! letrec letrec* $foreign-procedure - $foreign-callable eval-when)))) + $foreign-callable eval-when + $lambda/lift-barrier)))) (nanopass-case (Lsrc Expr) x [(ref ,maybe-src ,x) (get-name x)] [(call ,preinfo0 (case-lambda ,preinfo1 (clause (,x* ...) ,interface ,body)) ,e* ...) @@ -163,17 +164,22 @@ [,pr `(,(uncprep e) ,@(map uncprep e*))] [else (let ([a `(,(uncprep e) ,@(map uncprep e*))]) - (if (or (preinfo-call-check? preinfo) - ;; Reporting `#3%$app` is redundant for unsafe mode. - ;; Note that we're losing explicit `#2%$app`s. - (>= (optimize-level) 3) - (enable-unsafe-application)) - (if (preinfo-call-can-inline? preinfo) - a - (cons '$app/no-inline a)) - (if (preinfo-call-can-inline? preinfo) - (cons '#3%$app a) - (cons '#3%$app/no-inline a))))])))] + (let ([prim (if (or (preinfo-call-check? preinfo) + ;; Reporting `#3%$app` is redundant for unsafe mode. + ;; Note that we're losing explicit `#2%$app`s. + (>= (optimize-level) 3) + (enable-unsafe-application)) + (lambda (s a) (if s (cons s a) a)) + (lambda (s arg) (cons `($primitive 3 ,(or s '$app)) a)))]) + (cond + [(preinfo-call-no-return? preinfo) + (prim '$app/no-return a)] + [(preinfo-call-single-valued? preinfo) + (prim '$app/value a)] + [(preinfo-call-can-inline? preinfo) + (prim #f a)] + [else + (prim '$app/no-inline a)])))])))] [,pr (let ([sym (primref-name pr)]) (if sexpr? ($sgetprop sym '*unprefixed* sym) @@ -193,7 +199,10 @@ (lambda () (let ((cl* (map uncprep-lambda-clause cl*))) (if (and (not (null? cl*)) (null? (cdr cl*))) - `(lambda ,@(car cl*)) + (if (fx= (bitwise-and (constant code-flag-lift-barrier) (preinfo-lambda-flags preinfo)) + (constant code-flag-lift-barrier)) + `($lambda/lift-barrier ,@(car cl*)) + `(lambda ,@(car cl*))) `(case-lambda ,@cl*)))))] [(if ,[e0] ,[e1] ,[e2]) `(if ,e0 ,e1 ,e2)] [(set! ,maybe-src ,x ,[e]) `(set! ,(get-name x) ,e)] diff --git a/src/ChezScheme/s/cptypes.ss b/src/ChezScheme/s/cptypes.ss index ff2609e2d1..19e646d5b3 100644 --- a/src/ChezScheme/s/cptypes.ss +++ b/src/ChezScheme/s/cptypes.ss @@ -82,10 +82,6 @@ Notes: (define true-rec `(quote #t)) (define false-rec `(quote #f)) (define null-rec `(quote ())) - (define empty-vector-rec `(quote #())) - (define empty-string-rec `(quote "")) - (define empty-bytevector-rec `(quote #vu8())) - (define empty-fxvector-rec `(quote #vfx())) (define eof-rec `(quote #!eof)) (define bwp-rec `(quote #!bwp)) @@ -466,7 +462,7 @@ Notes: (predicate-implies? y t))) '(char null-or-pair $record gensym uninterned-symbol interned-symbol symbol - fixnum exact-integer flonum real number + fixnum bignum exact-integer flonum real number boolean true ptr))] ; ensure they are order from more restrictive to less restrictive [else #f])) @@ -546,6 +542,7 @@ Notes: [(string? d) 'string] [(bytevector? d) 'bytevector] [(fxvector? d) 'fxvector] + [(flvector? d) 'flvector] [else #f])) (define (rtd->record-predicate rtd extend?) @@ -576,6 +573,7 @@ Notes: [box? 'box] [$record? '$record] [fixnum? 'fixnum] + [bignum? 'bignum] [flonum? 'flonum] [real? 'real] [number? 'number] @@ -583,6 +581,7 @@ Notes: [string? 'string] [bytevector? 'bytevector] [fxvector? 'fxvector] + [flvector? 'flvector] [gensym? 'gensym] [uninterned-symbol? 'uninterned-symbol] #;[interned-symbol? 'interned-symbol] @@ -594,7 +593,7 @@ Notes: [null? null-rec] [eof-object? eof-rec] [bwp-object? bwp-rec] - [list? (if (not extend?) null-rec 'null-or-pair)] + [(list? list-assuming-immutable?) (if (not extend?) null-rec 'null-or-pair)] [else ((if extend? cdr car) (case name [(record? record-type-descriptor?) '(bottom . $record)] @@ -621,6 +620,7 @@ Notes: [box 'box] [$record '$record] [fixnum 'fixnum] + [bignum 'bignum] [flonum 'flonum] [real 'real] [number 'number] @@ -628,6 +628,7 @@ Notes: [string 'string] [bytevector 'bytevector] [fxvector 'fxvector] + [flvector 'flvector] [gensym 'gensym] [uninterned-symbol 'uninterned-symbol] [interned-symbol 'interned-symbol] @@ -649,6 +650,7 @@ Notes: [(record rtd) '(bottom . $record)] [(bit length ufixnum pfixnum) '(bottom . fixnum)] [(uint sub-uint) '(bottom . exact-integer)] + [(index sub-index u8 s8) '(bottom . fixnum)] [(sint) '(fixnum . exact-integer)] [(uinteger) '(bottom . real)] [(integer rational) '(exact-integer . real)] @@ -717,16 +719,20 @@ Notes: [(null-or-pair) (or (eq? x 'pair) (check-constant-is? x null?))] [(fixnum) (check-constant-is? x target-fixnum?)] + [(bignum) (check-constant-is? x target-bignum?)] [(exact-integer) (or (eq? x 'fixnum) + (eq? x 'bignum) (check-constant-is? x (lambda (x) (and (integer? x) (exact? x)))))] [(flonum) (check-constant-is? x flonum?)] [(real) (or (eq? x 'fixnum) + (eq? x 'bignum) (eq? x 'exact-integer) (eq? x 'flonum) (check-constant-is? x real?))] [(number) (or (eq? x 'fixnum) + (eq? x 'bignum) (eq? x 'exact-integer) (eq? x 'flonum) (eq? x 'real) @@ -753,6 +759,7 @@ Notes: [(string) (check-constant-is? x string?)] ; i.e. "" [(bytevector) (check-constant-is? x bytevector?)] ; i.e. '#vu8() [(fxvector) (check-constant-is? x fxvector?)] ; i.e. '#vfx() + [(flvector) (check-constant-is? x flvector?)] ; i.e. '#vfl() [(ptr) #t] [else #f])] [else #f])))) @@ -1067,6 +1074,40 @@ Notes: [else (values `(call ,preinfo ,pr ,n) ret ntypes #f #f)]))]) + (define-specialize 2 zero? + [(n) (let ([r (get-type n)]) + (cond + [(predicate-implies? r 'bignum) + (values (make-seq ctxt n false-rec) + false-rec ntypes #f #f)] + [(predicate-implies? r 'fixnum) + (values `(call ,preinfo ,(lookup-primref 3 'fxzero?) ,n) + ret + ntypes + (pred-env-add/ref ntypes n `(quote 0) plxc) + #f)] + [(predicate-implies? r 'exact-integer) + (values `(call ,preinfo ,(lookup-primref 3 'eq?) ,n (quote 0)) + ret + ntypes + (pred-env-add/ref ntypes n `(quote 0) plxc) + #f)] + [(predicate-implies? r 'flonum) + (values `(call ,preinfo ,(lookup-primref 3 'flzero?) ,n) + ret + ntypes + #f ; TODO: Add a type for flzero + #f)] + [else + (values `(call ,preinfo ,pr ,n) ret ntypes #f #f)]))]) + + (define-specialize 2 fxzero? + [(n) (values `(call ,preinfo ,pr ,n) + ret + ntypes + (pred-env-add/ref ntypes n `(quote 0) plxc) + #f)]) + (define-specialize 2 atan [(n) (let ([r (get-type n)]) (cond @@ -1243,12 +1284,13 @@ Notes: (define (fold-primref/next preinfo pr e* ctxt oldtypes plxc) (let-values ([(t e* r* t* t-t* f-t*) (map-Expr/delayed e* oldtypes plxc)]) - (let ([ret (primref->result-predicate pr (length e*))]) + (let* ([len (length e*)] + [ret (primref->result-predicate pr len)]) (let-values ([(ret t) (let loop ([e* e*] [r* r*] [n 0] [ret ret] [t t]) (if (null? e*) (values ret t) - (let ([pred (primref->argument-predicate pr n (length e*) #t)]) + (let ([pred (primref->argument-predicate pr n len #t)]) (loop (cdr e*) (cdr r*) (fx+ n 1) @@ -1357,7 +1399,7 @@ Notes: [(e0 ret0 types0 t-types0 f-types0) (Expr/call e0 'value ntypes oldtypes plxc)]) (values `(call ,preinfo ,e0 ,e* ...) - ret0 types0 t-types0 f-types0))) + (if (preinfo-call-no-return? preinfo) 'bottom ret0) types0 t-types0 f-types0))) (define (map-Expr/delayed e* oldtypes plxc) (define first-pass* (map (lambda (e) diff --git a/src/ChezScheme/s/default.def b/src/ChezScheme/s/default.def index 9181b5e59c..da1946fe00 100644 --- a/src/ChezScheme/s/default.def +++ b/src/ChezScheme/s/default.def @@ -31,6 +31,7 @@ (define-constant-default max-integer-alignment (if (= 64 (constant ptr-bits)) 8 4)) +(define-constant-default special-initial-field-alignment? #f) (define-constant-default time-t-bits (constant ptr-bits)) (define-constant-default segment-table-levels (if (= 64 (constant ptr-bits)) 3 diff --git a/src/ChezScheme/s/expeditor.ss b/src/ChezScheme/s/expeditor.ss index 11204209bc..e739e0e702 100644 --- a/src/ChezScheme/s/expeditor.ss +++ b/src/ChezScheme/s/expeditor.ss @@ -1430,7 +1430,7 @@ [(atomic box dot insert mark quote) (loop stack)] [(lbrack record-brack) (loop (cons (cons 'rbrack end) stack))] - [(lparen vfxnparen vfxparen vnparen vparen vu8nparen vu8paren) + [(lparen vfxnparen vfxparen vflnparen vflparen vnparen vparen vu8nparen vu8paren) (loop (cons (cons 'rparen end) stack))] [(rbrack rparen) (if (= end (string-length s)) @@ -1469,7 +1469,7 @@ [(atomic box dot insert mark quote) (loop stack)] [(lbrack record-brack) (loop (cons 'rbrack stack))] - [(lparen vfxnparen vfxparen vnparen vparen vu8nparen vu8paren) + [(lparen vfxnparen vfxparen vflnparen vflparen vnparen vparen vu8nparen vu8paren) (loop (cons 'rparen stack))] [(rbrack rparen) (if (fx= (length stack) 1) @@ -1510,7 +1510,7 @@ (if (and (not (null? stack)) (eq? (caar stack) 'qubx)) (loop (cons (cons 'rbrack (cdar stack)) (cdr stack)) #f) (loop (cons (cons 'rbrack start) stack) #f))] - [(lparen vfxnparen vfxparen vnparen vparen vu8nparen vu8paren) + [(lparen vfxnparen vfxparen vflnparen vflparen vnparen vparen vu8nparen vu8paren) (if (and (not (null? stack)) (eq? (caar stack) 'qubx)) (loop (cons (cons 'rparen (cdar stack)) (cdr stack)) #f) (loop (cons (cons 'rparen start) stack) #f))] @@ -1560,7 +1560,7 @@ (loop stack #f ignore?)] [(eof fasl) #f] [(lbrack record-brack) (loop (cons 'rbrack stack) #f ignore?)] - [(lparen vfxnparen vfxparen vnparen vparen vu8nparen vu8paren) + [(lparen vfxnparen vfxparen vflnparen vflparen vflnparen vflparen vnparen vparen vu8nparen vu8paren) (loop (cons 'rparen stack) #f ignore?)] [(rbrack rparen) (and (not (null? stack)) diff --git a/src/ChezScheme/s/fasl-helpers.ss b/src/ChezScheme/s/fasl-helpers.ss index e45fdce123..7ca6c872ff 100644 --- a/src/ChezScheme/s/fasl-helpers.ss +++ b/src/ChezScheme/s/fasl-helpers.ss @@ -148,10 +148,16 @@ (put-bytevector p (constant fasl-header)) (put-uptr p version) (put-uptr p mtype) - (put-u8 p (char->integer #\()) ; ) + (put-u8 p (char->integer #\()) (let f ([bootfiles bootfiles] [sep? #f]) (unless (null? bootfiles) - (when sep? (put-u8 p (char->integer #\space))) - (put-str p (car bootfiles)) - (f (cdr bootfiles) #t))) ; ( + (cond + [(string? (car bootfiles)) + (when sep? (put-u8 p (char->integer #\space))) + (put-str p (car bootfiles)) + (f (cdr bootfiles) #t)] + [else + ;; strip produces dependenices as a sequence of bytes + (put-u8 p (car bootfiles)) + (f (cdr bootfiles) #f)]))) (put-u8 p (char->integer #\)))])) diff --git a/src/ChezScheme/s/fasl.ss b/src/ChezScheme/s/fasl.ss index a6ca341e8b..b56b6d0222 100644 --- a/src/ChezScheme/s/fasl.ss +++ b/src/ChezScheme/s/fasl.ss @@ -13,6 +13,9 @@ ;;; See the License for the specific language governing permissions and ;;; limitations under the License. +;; The fasl reader is "fasl.c", which includes an overview of the fasl +;; format. + (let () (define-record-type target (nongenerative #{target dchg2hp5v3cck8ge283luo-1}) @@ -35,7 +38,7 @@ ; file for cross compilation, because the offsets may be incorrect (define rtd-size (csv7:record-field-accessor #!base-rtd 'size)) (define rtd-flds (csv7:record-field-accessor #!base-rtd 'flds)) -(define rtd-parent (csv7:record-field-accessor #!base-rtd 'parent)) +(define rtd-ancestors (csv7:record-field-accessor #!base-rtd 'ancestors)) (define rtd-name (csv7:record-field-accessor #!base-rtd 'name)) (define rtd-uid (csv7:record-field-accessor #!base-rtd 'uid)) (define rtd-flags (csv7:record-field-accessor #!base-rtd 'flags)) @@ -207,9 +210,7 @@ [(symbol-hashtable? x) (bld-graph x t a? d #t bld-ht)] [($record? x) (bld-graph x t a? d #t bld-record)] [(box? x) (bld-graph x t a? d #t bld-box)] - [(or (large-integer? x) (ratnum? x) ($inexactnum? x) ($exactnum? x) - (fxvector? x) (bytevector? x)) - (bld-graph x t a? d #t bld-simple)]))) + [else (bld-graph x t a? d #t bld-simple)]))) (module (small-integer? large-integer?) (define least-small-integer (- (expt 2 31))) @@ -323,9 +324,7 @@ (define wrf-fxvector (lambda (x p t a?) - (put-u8 p (if (immutable-fxvector? x) - (constant fasl-type-immutable-fxvector) - (constant fasl-type-fxvector))) + (put-u8 p (constant fasl-type-fxvector)) (let ([n (fxvector-length x)]) (put-uptr p n) (let wrf-fxvector-loop ([i 0]) @@ -333,6 +332,16 @@ (put-iptr p (fxvector-ref x i)) (wrf-fxvector-loop (fx+ i 1))))))) +(define wrf-flvector + (lambda (x p t a?) + (put-u8 p (constant fasl-type-flvector)) + (let ([n (flvector-length x)]) + (put-uptr p n) + (let wrf-flvector-loop ([i 0]) + (unless (fx= i n) + (wrf-flonum (flvector-ref x i) p) + (wrf-flvector-loop (fx+ i 1))))))) + (define wrf-bytevector (lambda (x p t a?) (put-u8 p (if (immutable-bytevector? x) @@ -618,6 +627,11 @@ (put-u8 p (constant fasl-type-graph-ref)) (put-uptr p (car a))])))) +(define (wrf-invalid x p t a?) + (wrf-graph x p t a? + (lambda (x p t a?) + ($oops 'fasl-write "invalid fasl object ~s" x)))) + (define wrf (lambda (x p t a?) (cond @@ -629,6 +643,7 @@ [(eq? x #t) (wrf-immediate (constant strue) p)] [(string? x) (wrf-graph x p t a? wrf-string)] [(fxvector? x) (wrf-graph x p t a? wrf-fxvector)] + [(flvector? x) (wrf-graph x p t a? wrf-flvector)] [(bytevector? x) (wrf-graph x p t a? wrf-bytevector)] ; this check must go before $record? check [(annotation? x) @@ -640,7 +655,7 @@ ; this check must go before $record? check [(symbol-hashtable? x) (wrf-graph x p t a? wrf-symht)] ; this check must go before $record? check - [(hashtable? x) ($oops 'fasl-write "invalid fasl object ~s" x)] + [(hashtable? x) (wrf-invalid x p t a?)] [($record? x) (wrf-graph x p t a? wrf-record)] [(vector? x) (wrf-graph x p t a? wrf-vector)] [(stencil-vector? x) (wrf-graph x p t a? wrf-stencil-vector)] @@ -658,11 +673,11 @@ [(eq? x '#0=#0#) (wrf-immediate (constant black-hole) p)] [($rtd-counts? x) (wrf-immediate (constant sfalse) p)] [(phantom-bytevector? x) (wrf-phantom x p)] - [else ($oops 'fasl-write "invalid fasl object ~s" x)]))) + [else (wrf-invalid x p t a?)]))) (module (start) (define start - (lambda (p t situation proc) + (lambda (p t situation x proc) (shift-externals! t) (dump-graph) (let-values ([(bv* size) @@ -680,7 +695,7 @@ (proc x p) (wrf x p t (constant annotation-all)))) begins))) - (proc p) + (proc x p) (extractor))]) ($write-fasl-bytevectors p bv* size situation (constant fasl-type-fasl))))) @@ -718,7 +733,7 @@ (constant fasl-omit-rtds) 0))]) (bld x t a? 0) - (start p t (constant fasl-type-visit-revisit) (lambda (p) (wrf x p t a?)))))) + (start p t (constant fasl-type-visit-revisit) x (lambda (x p) (wrf x p t a?)))))) (define-who fasl-write (case-lambda @@ -760,7 +775,7 @@ (emit-header p (constant scheme-version) (constant machine-type-any)) (let ([t (make-table)]) (bld-graph x t #f 0 #t really-bld-record) - (start p t (constant fasl-type-visit-revisit) (lambda (p) (wrf-graph x p t #f really-wrf-record)))))) + (start p t (constant fasl-type-visit-revisit) x (lambda (x p) (wrf-graph x p t #f really-wrf-record)))))) ($fasl-target (make-target bld-graph bld wrf start make-table wrf-graph fasl-base-rtd fasl-write fasl-file)) ) @@ -774,7 +789,7 @@ (set! $fasl-bld-graph (lambda (x t a? d inner? handler) ((target-fasl-bld-graph (fasl-target)) x t a? d inner? handler))) (set! $fasl-enter (lambda (x t a? d) ((target-fasl-enter (fasl-target)) x t a? d))) (set! $fasl-out (lambda (x p t a?) ((target-fasl-out (fasl-target)) x p t a?))) - (set! $fasl-start (lambda (p t situation proc) ((target-fasl-start (fasl-target)) p t situation proc))) + (set! $fasl-start (lambda (p t situation x proc) ((target-fasl-start (fasl-target)) p t situation x proc))) (set! $fasl-table (case-lambda [() ((target-fasl-table (fasl-target)))] [(external?-pred) ((target-fasl-table (fasl-target)) external?-pred)])) diff --git a/src/ChezScheme/s/front.ss b/src/ChezScheme/s/front.ss index d6ff185fce..593b6093b0 100644 --- a/src/ChezScheme/s/front.ss +++ b/src/ChezScheme/s/front.ss @@ -170,6 +170,7 @@ compile-whole-library compile-whole-program ($dynamic-closure-counts compile) + ($lift-closures compile) ($loop-unroll-limit compile) make-boot-file ($make-boot-file make-boot-file) diff --git a/src/ChezScheme/s/ftype.ss b/src/ChezScheme/s/ftype.ss index c344b70167..b2cf68a1d5 100644 --- a/src/ChezScheme/s/ftype.ss +++ b/src/ChezScheme/s/ftype.ss @@ -34,12 +34,6 @@ todo: followed and new fptrs are generated, but that probably isn't a big deal. would need to pass $fptr-ref a who argument for use in following pointers from ftype-&ref and ftype-set! - - consider trying to fix 32-bit macos x powerpc alignment issues. - doubles and long-longs are aligned on 8-byte boundaries if they - are first in a struct; otherwise, they are mostly aligned on - 4-byte boundaries. haven't entirely penetrated the rules governing - unions, but it's clear the same union can have a different size - depending on whether it is stand-alone or embedded in a struct |# #| @@ -484,7 +478,7 @@ ftype operators: (make-ftd-array ftd (and defid (symbol->string (syntax->datum defid))) stype - (* n (ftd-size ftd)) + (* n ($ftd-size ftd)) ; use `$ftd-size` for PPC Mac OS (ftd-alignment ftd) n ftd)))] [(bits-kwd (field-name signedness bits) ...) @@ -562,7 +556,7 @@ ftype operators: (make-ftd-function rtd/fptr (and defid (symbol->string (syntax->datum defid))) stype #f #f - ($filter-conv 'function-ftype #'(conv ...)) + ($filter-conv 'function-ftype #'(conv ...) (length #'(arg-type ...))) (map (lambda (x) (filter-type r x #f)) #'(arg-type ...)) (filter-type r #'result-type #t)))] [(packed-kwd ftype) @@ -1017,16 +1011,33 @@ ftype operators: (let ([ftd (expand-ftype-name r #'ftype)]) (when (ftd-function? ftd) ($oops 'ftype-sizeof "function ftypes have unknown size")) - (ftd-size ftd))])))) + ($ftd-size ftd))])))) (set! $ftd? (lambda (x) (ftd? x))) + (set! $ftd-size + (lambda (ftd) + (constant-case special-initial-field-alignment? + [(#f) (ftd-size ftd)] + [else + ;; PPC32 Mac OS: if the first field of a compound type is size 8, + ;; then size is rounded up to an alignment of 8. This doesn't apply + ;; if the compound type is inside another one and not at the start. + (let ([initial (let loop ([ftd ftd]) + (cond + [(ftd-struct? ftd) + (loop (caddr (car (ftd-struct-field* ftd))))] + [(ftd-union? ftd) + (apply max (map (lambda (f) (loop (cdr f))) (ftd-union-field* ftd)))] + [(ftd-array? ftd) + (loop (ftd-array-ftd ftd))] + [else (ftd-size ftd)]))]) + (if (fx= initial 8) + (fxlogand (fx+ (ftd-size ftd) 7) (fxlognot 7)) + (ftd-size ftd)))]))) (set! $ftd-as-box? ; represents `(& <ftype>)` from `$expand-fp-ftype` (lambda (x) (and (box? x) (ftd? (unbox x))))) - (set! $ftd-size - (lambda (x) - (ftd-size x))) (set! $ftd-alignment (lambda (x) (ftd-alignment x))) @@ -1035,6 +1046,9 @@ ftype operators: (or (ftd-struct? x) (ftd-union? x) (ftd-array? x)))) + (set! $ftd-union? + (lambda (x) + (ftd-union? x))) (set! $ftd-unsigned? (lambda (x) (and (ftd-base? x) diff --git a/src/ChezScheme/s/hashtable-types.ss b/src/ChezScheme/s/hashtable-types.ss index e805f5492e..5e66eeccaa 100644 --- a/src/ChezScheme/s/hashtable-types.ss +++ b/src/ChezScheme/s/hashtable-types.ss @@ -36,8 +36,8 @@ (define-record-type gen-ht (parent ht) - (fields (immutable hash) (immutable equiv?)) - (nongenerative #{gen-ht bu811z2onf9o6tfc-7}) + (fields (immutable hash) (immutable equiv?) (immutable eqht)) + (nongenerative #{gen-ht bu811z2onf9o6tfc-9}) (sealed #t)) (define-record-type eqv-ht diff --git a/src/ChezScheme/s/inspect.ss b/src/ChezScheme/s/inspect.ss index 031c9ee5ef..7f07fb6f2b 100644 --- a/src/ChezScheme/s/inspect.ss +++ b/src/ChezScheme/s/inspect.ss @@ -454,7 +454,7 @@ (up) (case ((object) 'type) [(pair) (ref-list n)] - [(continuation procedure vector fxvector bytevector string record + [(continuation procedure vector fxvector flvector bytevector string record ftype-struct ftype-union ftype-array ftype-bits stencil-vector) (ref n)] [else (invalid-movement)])))) @@ -493,6 +493,7 @@ symbol-dispatch-table)] [(vector) vector-dispatch-table] [(fxvector) fxvector-dispatch-table] + [(flvector) flvector-dispatch-table] [(bytevector) bytevector-dispatch-table] [(stencil-vector) stencil-vector-dispatch-table] [(record) record-dispatch-table] @@ -1002,6 +1003,27 @@ )) +(define flvector-dispatch-table + (make-dispatch-table + + [("length" . "l") + "display flvector length" + (() (show " ~d elements" ((object) 'length)))] + + [("ref" . "r") + "inspect [nth] element" + (() (ref 0)) + ((n) (ref n))] + + [("show" . "s") + "show [n] elements" + (() (display-refs ((object) 'length))) + ((n) + (range-check n ((object) 'length)) + (display-refs n))] + +)) + (define bytevector-dispatch-table (make-dispatch-table @@ -1907,6 +1929,18 @@ [write (p) (write x p)] [print (p) (pretty-print x p)])) + (define make-flvector-object + (make-object-maker flvector (x) + [value () x] + [length () (flvector-length x)] + [ref (i) + (unless (and (flonum? i) (fx< -1 i (flvector-length x))) + ($oops 'flvector-object "invalid index ~s" i)) + (make-object (flvector-ref x i))] + [size (g) (compute-size x g)] + [write (p) (write x p)] + [print (p) (pretty-print x p)])) + (define make-bytevector-object (make-object-maker bytevector (x) [value () x] @@ -2432,6 +2466,7 @@ [(symbol? x) (make-symbol-object x)] [(vector? x) (make-vector-object x)] [(fxvector? x) (make-fxvector-object x)] + [(flvector? x) (make-flvector-object x)] [(bytevector? x) (make-bytevector-object x)] [(stencil-vector? x) (make-stencil-vector-object x)] ; ftype-pointer? test must come before record? test @@ -2600,6 +2635,7 @@ (fx+ size (compute-size (vector-ref x i)))]) ((fx= i n) size)))] [(fxvector? x) (align (fx+ (constant header-size-fxvector) (fx* (fxvector-length x) (constant ptr-bytes))))] + [(flvector? x) (align (fx+ (constant header-size-flvector) (fx* (flvector-length x) (constant ptr-bytes))))] [(bytevector? x) (align (fx+ (constant header-size-bytevector) (bytevector-length x)))] [(stencil-vector? x) (let ([n (stencil-vector-length x)]) @@ -2743,7 +2779,7 @@ (vector-set! count-vec i (cons 1 size))))] ...))))]))) (define-counters (type-names type-counts incr!) - pair symbol vector fxvector bytevector stencil-vector string box flonum bignum ratnum exactnum + pair symbol vector fxvector flvector bytevector stencil-vector string box flonum bignum ratnum exactnum inexactnum continuation stack procedure code-object reloc-table port thread tlc rtd-counts phantom) (define compute-composition! @@ -2772,6 +2808,7 @@ (incr! vector (align (fx+ (constant header-size-vector) (fx* (vector-length x) (constant ptr-bytes))))) (vector-for-each compute-composition! x)] [(fxvector? x) (incr! fxvector (align (fx+ (constant header-size-fxvector) (fx* (fxvector-length x) (constant ptr-bytes)))))] + [(flvector? x) (incr! flvector (align (fx+ (constant header-size-flvector) (fx* (flvector-length x) (constant ptr-bytes)))))] [(bytevector? x) (incr! bytevector (align (fx+ (constant header-size-bytevector) (bytevector-length x))))] [(stencil-vector? x) (let ([len (stencil-vector-length x)]) @@ -2965,7 +3002,7 @@ (if (eq? (fld-type fld) 'scheme-object) (construct-proc ($object-ref 'scheme-object x (fld-byte fld)) (f (cdr flds))) (f (cdr flds))))))]))))] - [(or (fxvector? x) (bytevector? x) (string? x) (flonum? x) (bignum? x) + [(or (fxvector? x) (flvector? x) (bytevector? x) (string? x) (flonum? x) (bignum? x) ($inexactnum? x) ($rtd-counts? x) (phantom-bytevector? x)) next-proc] [(box? x) (construct-proc (unbox x) next-proc)] diff --git a/src/ChezScheme/s/library.ss b/src/ChezScheme/s/library.ss index 492fd4c6d6..09542d98c7 100644 --- a/src/ChezScheme/s/library.ss +++ b/src/ChezScheme/s/library.ss @@ -287,9 +287,9 @@ (define fxvector-oops (lambda (who x) ($oops who "~s is not an fxvector" x))) - (define mutable-fxvector-oops + (define flvector-oops (lambda (who x) - ($oops who "~s is not a mutable fxvector" x))) + ($oops who "~s is not an flvector" x))) (define bytevector-oops (lambda (who x) ($oops who "~s is not a bytevector" x))) @@ -358,15 +358,30 @@ (fxvector-oops 'fxvector-ref v))) (define-library-entry (fxvector-set! v i x) - (if (mutable-fxvector? v) + (if (fxvector? v) (if (and (fixnum? i) ($fxu< i (fxvector-length v))) (fixnum-oops 'fxvector-set! x) (index-oops 'fxvector-set! v i)) - (mutable-fxvector-oops 'fxvector-set! v))) + (fxvector-oops 'fxvector-set! v))) (define-library-entry (fxvector-length v) (fxvector-oops 'fxvector-length v)) + (define-library-entry (flvector-ref v i) + (if (flvector? v) + (index-oops 'flvector-ref v i) + (flvector-oops 'flvector-ref v))) + + (define-library-entry (flvector-set! v i x) + (if (flvector? v) + (if (and (fixnum? i) ($fxu< i (flvector-length v))) + ($oops 'flvector-set! "~s is not a flonum" x) + (index-oops 'flvector-set! v i)) + (flvector-oops 'flvector-set! v))) + + (define-library-entry (flvector-length v) + (flvector-oops 'flvector-length v)) + (define-library-entry (bytevector-s8-ref v i) (if (bytevector? v) (index-oops 'bytevector-s8-ref v i) @@ -508,6 +523,14 @@ (define-library-entry (fx1+ x) (fxoops1 'fx1+ x)) (define-library-entry (fx1- x) (fxoops1 'fx1- x)) +(define-library-entry (fx+/wraparound x y) (fxoops2 'fx+/wraparound x y)) +(define-library-entry (fx-/wraparound x y) (fxoops2 'fx-/wraparound x y)) +(define-library-entry (fx*/wraparound x y) (fxoops2 'fx*/wraparound x y)) +(define-library-entry (fxsll/wraparound x y) + (if (and (fixnum? x) (fixnum? y)) + (shift-count-oops 'fxsll/wraparound y) + (fxoops2 'fxsll/wraparound x y))) + (define-library-entry (fx= x y) (fxnonfixnum2 'fx= x y)) (define-library-entry (fx< x y) (fxnonfixnum2 'fx< x y)) (define-library-entry (fx> x y) (fxnonfixnum2 'fx> x y)) @@ -1520,6 +1543,11 @@ (if (fx<= n2 target) (adjust! h vec n n2) (loop n2)))))))])) + + ;; Must be consistent with `eq_hash` in "../c/segment.h" + (define-syntax eq-hash + (syntax-rules () + [(_ v-expr) (fixmix ($fxaddress v-expr))])) (define adjust! (lambda (h vec1 n1 n2) @@ -1529,7 +1557,7 @@ (let loop ([b (vector-ref vec1 i1)]) (unless (fixnum? b) (let ([next ($tlc-next b)] [keyval ($tlc-keyval b)]) - (let ([i2 (fxlogand ($fxaddress (car keyval)) mask2)]) + (let ([i2 (fxlogand (eq-hash (car keyval)) mask2)]) ($set-tlc-next! b (vector-ref vec2 i2)) (vector-set! vec2 i2 b)) (loop next))))) @@ -1538,26 +1566,26 @@ (define-library-entry (eq-hashtable-ref h x v) (lookup-keyval x (let ([vec (ht-vec h)]) - (vector-ref vec (fxlogand ($fxaddress x) (fx- (vector-length vec) 1)))) + (vector-ref vec (fxlogand (eq-hash x) (fx- (vector-length vec) 1)))) cdr v)) (define-library-entry (eq-hashtable-ref-cell h x) (lookup-keyval x (let ([vec (ht-vec h)]) - (vector-ref vec (fxlogand ($fxaddress x) (fx- (vector-length vec) 1)))) + (vector-ref vec (fxlogand (eq-hash x) (fx- (vector-length vec) 1)))) (lambda (x) x) #f)) (define-library-entry (eq-hashtable-contains? h x) (lookup-keyval x (let ([vec (ht-vec h)]) - (vector-ref vec (fxlogand ($fxaddress x) (fx- (vector-length vec) 1)))) + (vector-ref vec (fxlogand (eq-hash x) (fx- (vector-length vec) 1)))) (lambda (x) #t) #f)) (define-library-entry (eq-hashtable-cell h x v) (let* ([vec (ht-vec h)] - [idx (fxlogand ($fxaddress x) (fx- (vector-length vec) 1))] + [idx (fxlogand (eq-hash x) (fx- (vector-length vec) 1))] [b (vector-ref vec idx)]) (lookup-keyval x b values @@ -1575,7 +1603,7 @@ ;; resizing. (define-library-entry (eq-hashtable-try-atomic-cell h x v) (let* ([vec (ht-vec h)] - [idx (fxlogand ($fxaddress x) (fx- (vector-length vec) 1))] + [idx (fxlogand (eq-hash x) (fx- (vector-length vec) 1))] [b (vector-ref vec idx)]) (lookup-keyval x b values @@ -1596,7 +1624,7 @@ (define do-set! (lambda (h x v) (let* ([vec (ht-vec h)] - [idx (fxlogand ($fxaddress x) (fx- (vector-length vec) 1))] + [idx (fxlogand (eq-hash x) (fx- (vector-length vec) 1))] [b (vector-ref vec idx)]) (lookup-keyval x b (lambda (keyval) (set-cdr! keyval v)) @@ -1616,7 +1644,7 @@ (define-library-entry (eq-hashtable-update! h x p v) (let* ([vec (ht-vec h)] - [idx (fxlogand ($fxaddress x) (fx- (vector-length vec) 1))] + [idx (fxlogand (eq-hash x) (fx- (vector-length vec) 1))] [b (vector-ref vec idx)]) (lookup-keyval x b (lambda (a) (set-cdr! a (p (cdr a)))) @@ -1624,7 +1652,7 @@ (define-library-entry (eq-hashtable-delete! h x) (let* ([vec (ht-vec h)] - [idx (fxlogand ($fxaddress x) (fx- (vector-length vec) 1))] + [idx (fxlogand (eq-hash x) (fx- (vector-length vec) 1))] [b (vector-ref vec idx)]) (unless (fixnum? b) (if (eq? (car ($tlc-keyval b)) x) diff --git a/src/ChezScheme/s/mathprims.ss b/src/ChezScheme/s/mathprims.ss index b5f54a126e..8c2996972e 100644 --- a/src/ChezScheme/s/mathprims.ss +++ b/src/ChezScheme/s/mathprims.ss @@ -348,6 +348,14 @@ [(x) (#2%r6rs:fx- x)] [(x y) (#2%r6rs:fx- x y)])) + (set-who! fx+/wraparound + (lambda (x1 x2) + (#2%fx+/wraparound x1 x2))) + + (set-who! fx-/wraparound + (lambda (x1 x2) + (#2%fx-/wraparound x1 x2))) + (set! fx1- (lambda (x) (#2%fx1- x))) @@ -403,6 +411,10 @@ (fxargerr who x2)) (fxargerr who x1)))) + (set-who! fx*/wraparound + (lambda (x1 x2) + (#2%fx*/wraparound x1 x2))) + (set! fxquotient (rec fxquotient (case-lambda @@ -518,16 +530,20 @@ (set! fxsll (lambda (x y) - (#2%fxsll x y))) + (#2%fxsll x y))) - (set! fxarithmetic-shift-left - (lambda (x y) - (#2%fxarithmetic-shift-left x y))) + (set-who! fxsll/wraparound + (lambda (x1 x2) + (#2%fxsll/wraparound x1 x2))) (set! fxsrl (lambda (x y) (#2%fxsrl x y))) + (set! fxarithmetic-shift-left + (lambda (x y) + (#2%fxarithmetic-shift-left x y))) + (set! fxsra (lambda (x y) (#2%fxsra x y))) diff --git a/src/ChezScheme/s/mkgc.ss b/src/ChezScheme/s/mkgc.ss index e64b2336ca..e65a9bbd84 100644 --- a/src/ChezScheme/s/mkgc.ss +++ b/src/ChezScheme/s/mkgc.ss @@ -25,8 +25,6 @@ ;; - self-test : check immediate pointers only for self references ;; - size : immediate size, so does not recur ;; - measure : recurs for reachable size -;; - vfasl-copy -;; - vfasl-sweep ;; - check ;; For the specification, there are a few declaration forms described @@ -71,7 +69,6 @@ ;; Primitive actions/declarations, must be used as statements in roughly ;; this order (but there are exceptions to the order): ;; - (space <space>) : target for copy; works as a constraint for other modes -;; - (vspace <vspace>) : target for vfasl ;; - (size <size> [<scale>]) : size for copy; skips rest in size mode ;; - (mark <flag>) : in mark mode, skips rest except counting; ;; possible <flags>: @@ -106,7 +103,6 @@ ;; an identifier or a Parenthe-C expression. The meaning of a plain ;; identifier depends on the nonterminal: ;; - <space> : should be a `space-...` from cmacro -;; - <vspace> : should be a `vspace_...` ;; - <size> : should be a constant from cmacro ;; - <field> : accessor from cmacro, implicitly applied to `_` and `_copy_` @@ -151,7 +147,7 @@ ;; ;; Built-in variables: ;; - _ : object being copied, swept, etc. -;; - _copy_ : target in copy or vfasl mode, same as _ otherwise +;; - _copy_ : target in copy mode, same as _ otherwise ;; - _size_ : size of the current object, but only in parallel mode ;; - _tf_ : type word ;; - _tg_ : target generation @@ -168,7 +164,6 @@ (case-space [space-ephemeron (space space-ephemeron) - (vfasl-fail "ephemeron") (size size-ephemeron) (copy pair-car) (copy pair-cdr) @@ -186,7 +181,6 @@ (count countof-ephemeron)] [space-weakpair (space space-weakpair) - (vfasl-fail "weakpair") (case-mode [(check) (trace pair-car)] [else]) @@ -195,7 +189,6 @@ countof-weakpair)] [else (space space-impure) - (vspace vspace_impure) (try-double-pair trace pair-car trace pair-cdr countof-pair)])] @@ -214,7 +207,6 @@ (space (cond [(and-counts (is_counting_root si _)) space-count-pure] [else space-continuation])) - (vfasl-fail "closure") (size size-continuation) (case-mode [self-test] @@ -243,7 +235,7 @@ ;; A stack segment has a single owner, so it's ok for us ;; to sweep the stack content, even though it's on a ;; remote segment relative to the current sweeper. - (RECORD_REMOTE_RANGE _tgc_ _ _size_ s_si)] + (RECORD_REMOTE s_si)] [else (set! (continuation-stack _) (copy_stack _tgc_ @@ -282,10 +274,6 @@ space-closure] [off space-pure])])])) - (vspace vspace_closure) - (when-vfasl - (when (& (code-type code) (<< code-flag-mutable-closure code-flags-offset)) - (vfasl-fail "mutable closure"))) (define len : uptr (code-closure-length code)) (size (size_closure len)) (when-mark @@ -311,20 +299,18 @@ [symbol (space space-symbol) - (vspace vspace_symbol) (size size-symbol) (mark one-bit) - (trace/define symbol-value val :vfasl-as (FIX (vfasl_symbol_to_index vfi _))) + (trace/define symbol-value val) (trace-local-symcode symbol-pvalue val) - (trace-nonself/vfasl-as-nil symbol-plist) + (trace-nonself symbol-plist) (trace-nonself symbol-name) - (trace-nonself/vfasl-as-nil symbol-splist) + (trace-nonself symbol-splist) (trace-nonself symbol-hash) (count countof-symbol)] [flonum (space space-data) - (vspace vspace_data) (size size-flonum) (mark) (copy-flonum flonum-data) @@ -372,19 +358,12 @@ space-pure-typed-object] [else space-impure-record])])) - (vspace (cond - [(is_rtd rtd vfi) vspace_rtd] - [(== (record-type-mpm rtd) (FIX 0)) vspace_pure_typed] - [else vspace_impure_record])) - (vfasl-check-parent-rtd rtd) (define len : uptr (UNFIX (record-type-size rtd))) (size (size_record_inst len)) (mark counting-root) (trace-record rtd len) - (vfasl-set-base-rtd) - (pad (when (or-vfasl - (\|\| (== p_spc space-pure) (\|\| (== p_spc space-impure) - (and-counts (== p_spc space-count-impure))))) + (pad (when (\|\| (== p_spc space-pure) (\|\| (== p_spc space-impure) + (and-counts (== p_spc space-count-impure)))) (let* ([ua_size : uptr (unaligned_size_record_inst len)]) (when (!= p_sz ua_size) (set! (* (cast ptr* (TO_VOIDP (+ (cast uptr (UNTYPE _copy_ type_typed_object)) ua_size)))) @@ -404,7 +383,6 @@ (cond [_backreferences?_ space-impure-typed-object] [else space-impure])])) - (vspace vspace_impure) (define len : uptr (Svector_length _)) (size (size_vector len)) (mark) @@ -421,7 +399,6 @@ (cond [_backreferences?_ space-impure-typed-object] [else space-impure])) - (vspace vspace_impure) (define len : uptr (Sstencil_vector_length _)) (size (size_stencil_vector len)) (mark within-segment) ; see assertion @@ -434,7 +411,6 @@ [string (space space-data) - (vspace vspace_data) (define sz : uptr (size_string (Sstring_length _))) (size (just sz)) (mark) @@ -443,16 +419,22 @@ [fxvector (space space-data) - (vspace vspace_data) (define sz : uptr (size_fxvector (Sfxvector_length _))) (size (just sz)) (mark) (copy-bytes fxvector-type sz) (count countof-fxvector)] + [flvector + (space space-data) + (define sz : uptr (size_flvector (Sflvector_length _))) + (size (just sz)) + (mark) + (copy-bytes flvector-type sz) + (count countof-flvector)] + [bytevector (space space-data) - (vspace vspace_data) (define sz : uptr (size_bytevector (Sbytevector_length _))) (size (just sz)) (mark) @@ -464,7 +446,6 @@ (cond [_backreferences?_ space-impure-typed-object] [else space-impure])) - (vfasl-fail "tlc") (size size-tlc) (mark) (copy-type tlc-type) @@ -484,7 +465,6 @@ (cond [_backreferences?_ space-impure-typed-object] [else space-impure])])) - (vspace vspace_impure) (size size-box) (mark) (copy-type box-type) @@ -495,7 +475,6 @@ (space (case-flag parallel? [on space-pure] [off space-data])) - (vspace vspace_impure) ; would be better if we had pure, but these are rare (size size-ratnum) (copy-type ratnum-type) (trace-nonparallel-now ratnum-numerator) @@ -504,14 +483,12 @@ [on (pad (set! (ratnum-pad _copy_) 0))] [off]) (mark) - (vfasl-pad-word) (count countof-ratnum)] [exactnum (space (case-flag parallel? [on space-pure] [off space-data])) - (vspace vspace_impure) ; same rationale as ratnum (size size-exactnum) (copy-type exactnum-type) (trace-nonparallel-now exactnum-real) @@ -520,12 +497,10 @@ [on (pad (set! (exactnum-pad _copy_) 0))] [off]) (mark) - (vfasl-pad-word) (count countof-exactnum)] [inexactnum (space space-data) - (vspace vspace_data) (size size-inexactnum) (mark) (copy-type inexactnum-type) @@ -535,7 +510,6 @@ [bignum (space space-data) - (vspace vspace_data) (define sz : uptr (size_bignum (BIGLEN _))) (size (just sz)) (mark) @@ -544,7 +518,6 @@ [port (space space-port) - (vfasl-fail "port") (size size-port) (mark one-bit) (copy-type port-type) @@ -559,7 +532,6 @@ [code (space space-code) - (vspace vspace_code) (define len : uptr (code-length _)) ; in bytes (size (size_code len)) (mark one-bit) @@ -579,7 +551,6 @@ (space (cond [(and-counts (is_counting_root si _)) space-count-pure] [else space-pure-typed-object])) - (vfasl-fail "thread") (size size-thread) (mark one-bit) (case-mode @@ -592,7 +563,6 @@ [rtd-counts (space space-data) - (vfasl-as-false "rtd-counts") ; prune counts, since GC will recreate as needed (size size-rtd-counts) (mark) (copy-bytes rtd-counts-type size_rtd_counts) @@ -600,7 +570,6 @@ [phantom (space space-data) - (vfasl-fail "phantom") (size size-phantom) (mark) (copy-type phantom-type) @@ -611,11 +580,11 @@ (count countof-phantom) ;; Separate from `count`, because we want to track sizes even ;; if counting is not enabled: - (GC_TC_MUTEX_ACQUIRE) + (GC_MUTEX_ACQUIRE) (set! (array-ref (array-ref S_G.bytesof _tg_) countof-phantom) += (phantom-length _)) - (GC_TC_MUTEX_RELEASE))] + (GC_MUTEX_RELEASE))] [measure (set! measure_total += (phantom-length _))] [else])])])) @@ -631,13 +600,6 @@ [else (trace-pure field)])) -(define-trace-macro (trace-nonself/vfasl-as-nil field) - (case-mode - [vfasl-copy - (set! (field _copy_) Snil)] - [else - (trace-nonself field)])) - (define-trace-macro (trace-nonparallel-now field) (case-flag parallel? [on (trace-pure field)] @@ -705,34 +667,24 @@ (define-trace-macro (trace-code-early code) (unless-code-relocated - (case-mode - [(vfasl-sweep) - ;; Special relocation handling for code in a closure: - (set! code (vfasl_relocate_code vfi code))] - [else - ;; In parallel mode, the `code` pointer may or may not have been - ;; forwarded. In that case, we may misinterpret the forward mmarker - ;; as a code type with flags, but it's ok, because the flags will - ;; only be set for static-generation objects - (case-flag parallel? - [on (case-mode - [(sweep sweep-in-old) - (trace-pure-code (just code))] - [else])] - [off (trace-early (just code))])]))) + ;; In parallel mode, the `code` pointer may or may not have been + ;; forwarded. In that case, we may misinterpret the forward mmarker + ;; as a code type with flags, but it's ok, because the flags will + ;; only be set for static-generation objects + (case-flag parallel? + [on (case-mode + [(sweep sweep-in-old) + (trace-pure-code (just code))] + [else])] + [off (trace-early (just code))]))) (define-trace-macro (copy-clos-code code) (case-mode - [(copy vfasl-copy) + [(copy) (SETCLOSCODE _copy_ code)] [(sweep sweep-in-old) (unless-code-relocated (SETCLOSCODE _copy_ code))] - [(vfasl-sweep) - ;; Make the code pointer relative to the base address. - ;; It's turned back absolute when loading from vfasl - (define rel_code : ptr (cast ptr (ptr_diff code (-> vfi base_addr)))) - (SETCLOSCODE p rel_code)] [else])) (define-trace-macro (copy-stack-length continuation-stack-length continuation-stack-clength) @@ -743,23 +695,21 @@ [(== (continuation-stack-length _) opportunistic-1-shot-flag) (set! (continuation-stack-length _copy_) (continuation-stack-clength _)) ;; May need to recur at end to promote link: - (GC_TC_MUTEX_ACQUIRE) + (GC_MUTEX_ACQUIRE) (set! conts_to_promote (S_cons_in (-> _tgc_ tc) space_new 0 _copy_ conts_to_promote)) - (GC_TC_MUTEX_RELEASE)] + (GC_MUTEX_RELEASE)] [else (copy continuation-stack-length)])] [else (copy continuation-stack-length)])) -(define-trace-macro (trace/define ref val :vfasl-as vfasl-val) +(define-trace-macro (trace/define ref val) (case-mode [(copy measure) (trace ref)] [(sweep sweep-in-old) (trace ref) ; can't trace `val` directly, because we need an impure relocate (define val : ptr (ref _))] - [vfasl-copy - (set! (ref _copy_) vfasl-val)] [else])) (define-trace-macro (trace-symcode symbol-pvalue val) @@ -773,8 +723,6 @@ [off (trace-pure (just code))]) (INITSYMCODE _ code)] [measure] - [vfasl-copy - (set! (symbol-pvalue _copy_) Snil)] [else (copy symbol-pvalue)])) @@ -794,7 +742,7 @@ (SEGMENT_IS_LOCAL v_si val)) (trace-symcode symbol-pvalue val)] [else - (RECORD_REMOTE_RANGE _tgc_ _ _size_ v_si)])] + (RECORD_REMOTE v_si)])] [off (trace-symcode symbol-pvalue val)])] [else (trace-symcode symbol-pvalue val)])) @@ -815,16 +763,16 @@ ;; determine if key is old, since keyval might or might not have been ;; swept already. NB: assuming keyvals are always pairs. (when (&& (!= next Sfalse) (OLDSPACE keyval)) - (GC_TC_MUTEX_ACQUIRE) + (GC_MUTEX_ACQUIRE) (set! tlcs_to_rehash (S_cons_in (-> _tgc_ tc) space_new 0 _copy_ tlcs_to_rehash)) - (GC_TC_MUTEX_RELEASE))] + (GC_MUTEX_RELEASE))] [else (trace-nonself tlc-keyval) (trace-nonself tlc-next)])) (define-trace-macro (trace-record trd len) (case-mode - [(copy vfasl-copy) + [(copy) (copy-bytes record-data (- len ptr_bytes))] [else ;; record-type descriptor was forwarded already @@ -869,7 +817,7 @@ (trace-record-type-pm num rtd)] [else ;; Try again in the bignum's sweeper - (RECORD_REMOTE_RANGE _tgc_ _ _size_ pm_si) + (RECORD_REMOTE pm_si) (set! num S_G.zero_length_bignum)])] [off (trace-record-type-pm num rtd)])] @@ -901,37 +849,6 @@ (trace-pure (record-type-pm rtd)) (set! num (record-type-pm rtd))) -(define-trace-macro (vfasl-check-parent-rtd rtd) - (case-mode - [(vfasl-copy) - (when (is_rtd rtd vfi) - (when (!= _ S_G.base_rtd) - ;; Make sure rtd's type is registered firs, but - ;; discard the relocated pointer (leaving to sweep) - (cast void (vfasl_relocate_help vfi rtd))) - ;; Need parent before child - (vfasl_relocate_parents vfi (record-type-parent _)))] - [(vfasl-sweep) - ;; Don't need to save fields of base-rtd - (when (== _ (-> vfi base_rtd)) - (let* ([pp : ptr* (& (record-data _ 0))] - [ppend : ptr* (- (cast ptr* (TO_VOIDP (+ (cast uptr (TO_PTR pp)) (UNFIX (record-type-size rtd))))) 1)]) - (while - :? (< pp ppend) - (set! (* pp) Snil) - (set! pp += 1)) - (return (size_record_inst (UNFIX (record-type-size rtd)))))) - ;; Relocation of rtd fields was deferred - (vfasl_relocate vfi (& (record-type _)))] - [else])) - -(define-trace-macro (vfasl-set-base-rtd) - (case-mode - [(vfasl-copy) - (when (== _ S_G.base_rtd) - (set! (-> vfi base_rtd) _copy_))] - [else])) - (define-trace-macro (count-record rtd) (case-mode [(copy mark) @@ -1053,10 +970,6 @@ (trace-pure (tc-target-machine tc)) (trace-pure (tc-fxlength-bv tc)) (trace-pure (tc-fxfirst-bit-set-bv tc)) - (trace-pure (tc-null-immutable-vector tc)) - (trace-pure (tc-null-immutable-fxvector tc)) - (trace-pure (tc-null-immutable-bytevector tc)) - (trace-pure (tc-null-immutable-string tc)) (trace-pure (tc-compile-profile tc)) (trace-pure (tc-subset-mode tc)) (trace-pure (tc-default-record-equal-procedure tc)) @@ -1110,7 +1023,9 @@ (trace-pure (* (ENTRYNONCOMPACTLIVEMASKADDR oldret))) (set! num (ENTRYLIVEMASK oldret))] [else - (RECORD_REMOTE_RANGE _tgc_ _ _size_ n_si) + (case-mode + [(measure)] + [else (RECORD_REMOTE n_si)]) (set! num S_G.zero_length_bignum)])]) (let* ([index : iptr (BIGLEN num)]) (while @@ -1140,7 +1055,7 @@ [(sweep sweep-in-old) (define x_si : seginfo* (SegInfo (ptr_get_segment c_p))) (when (-> x_si old_space) - (relocate_code c_p x_si _ _size_) + (relocate_code c_p x_si) (case-mode [sweep-in-old] [else @@ -1150,7 +1065,7 @@ (define-trace-macro (trace-code len) (case-mode - [(copy vfasl-copy) + [(copy) (copy-bytes code-data len)] [else (define t : ptr (code-reloc _)) @@ -1160,13 +1075,6 @@ (define oldco : ptr (cond [t (reloc-table-code t)] [else 0])) - (case-mode - [vfasl-sweep - (let* ([r_sz : uptr (size_reloc_table m)] - [new_t : ptr (vfasl_find_room vfi vspace_reloc typemod r_sz)]) - (memcpy_aligned (TO_VOIDP new_t) (TO_VOIDP t) r_sz) - (set! t new_t))] - [else]) (define a : iptr 0) (define n : iptr 0) (while @@ -1186,16 +1094,10 @@ (set! code_off (RELOC_CODE_OFFSET entry))]) (set! a (+ a code_off)) (let* ([obj : ptr (S_get_code_obj (RELOC_TYPE entry) oldco a item_off)]) - (case-mode - [vfasl-sweep - (set! obj (vfasl_encode_relocation vfi obj))] - [else - (trace-pure (just obj))]) + (trace-pure (just obj)) (case-mode [sweep (S_set_code_obj "gc" (RELOC_TYPE entry) _ a obj item_off)] - [vfasl-sweep - (S_set_code_obj "vfasl" (abs_reloc_variant (RELOC_TYPE entry)) _ a obj item_off)] [else])))) (case-mode @@ -1222,14 +1124,10 @@ (find_gc_room _tgc_ space_data from_g typemod n t) (memcpy_aligned (TO_VOIDP t) (TO_VOIDP oldt) n))])] [else - (RECORD_REMOTE_RANGE _tgc_ _ _size_ t_si)]))) + (RECORD_REMOTE t_si)]))) (set! (reloc-table-code t) _) (set! (code-reloc _) t)]) (S_record_code_mod (-> _tgc_ tc) (cast uptr (TO_PTR (& (code-data _ 0)))) (cast uptr (code-length _)))] - [vfasl-sweep - ;; no vfasl_register_pointer, since relink_code can handle it - (set! (reloc-table-code t) (cast ptr (ptr_diff _ (-> vfi base_addr)))) - (set! (code-reloc _) (cast ptr (ptr_diff t (-> vfi base_addr))))] [else])])) (define-trace-macro (check-bignum var) @@ -1264,21 +1162,11 @@ [on e] [off 1])) -(define-trace-macro (or-vfasl e) - (case-mode - [vfasl-copy 1] - [else e])) - (define-trace-macro (and-purity-sensitive-mode e) (case-mode [(sweep sweep-in-old) e] [else 0])) -(define-trace-macro (when-vfasl e) - (case-mode - [(vfasl-copy vfasl-sweep) e] - [else])) - (define-trace-macro (when-mark e) (case-mode [(mark) e] @@ -1286,34 +1174,7 @@ (define-trace-macro (pad e) (case-mode - [(copy vfasl-copy) e] - [else])) - -(define-trace-macro (vfasl-pad-word) - (case-mode - [(vfasl-copy) - (set! (array-ref (cast ptr* (TO_VOIDP (UNTYPE _copy_ type_typed_object))) 3) - 0)] - [else])) - -(define-trace-macro (vfasl-fail what) - (case-mode - [(vfasl-copy vfasl-sweep) - (vfasl_fail vfi what) - (case-mode - [vfasl-copy (return (cast ptr 0))] - [vfasl-sweep (return 0)]) - (vspace #f)] - [else])) - -(define-trace-macro (vfasl-as-false what) - (case-mode - [(vfasl-copy) - (return Sfalse) - (vspace #f)] - [(vfasl-sweep) - (vfasl-fail what) - (vspace #f)] + [(copy) e] [else])) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1453,8 +1314,7 @@ (format "static ~a ~a(~aptr p~a)" (case (lookup 'mode config) [(copy mark) "IGEN"] - [(vfasl-copy) "ptr"] - [(size vfasl-sweep) "uptr"] + [(size) "uptr"] [(self-test) "IBOOL"] [(sweep) (if (lookup 'as-dirty? config #f) "IGEN" @@ -1464,12 +1324,10 @@ name (case (lookup 'mode config) [(copy mark sweep sweep-in-old measure) "thread_gc *tgc, "] - [(vfasl-copy vfasl-sweep) - "vfasl_info *vfi, "] [else ""]) (case (lookup 'mode config) [(copy) ", seginfo *si, ptr *dest"] - [(mark vfasl-copy) ", seginfo *si"] + [(mark) ", seginfo *si"] [(sweep) (cond [(lookup 'as-dirty? config #f) ", IGEN youngest"] @@ -1526,32 +1384,26 @@ "return si->generation;")] [(sweep) (code-block + "FLUSH_REMOTE_BLOCK" (and (lookup 'maybe-backreferences? config #f) "PUSH_BACKREFERENCE(p)") (body) (and (lookup 'maybe-backreferences? config #f) "POP_BACKREFERENCE()") + "FLUSH_REMOTE(tgc, p);" (and (lookup 'as-dirty? config #f) "return youngest;"))] [(sweep-in-old) - (body)] + (code-block + "FLUSH_REMOTE_BLOCK" + (body) + "ASSERT_EMPTY_FLUSH_REMOTE();")] [(measure) (body)] [(self-test) (code-block (body) "return 0;")] - [(vfasl-copy) - (code-block - "ptr new_p;" - (body) - "vfasl_register_forward(vfi, p, new_p);" - "return new_p;")] - [(vfasl-sweep) - (code-block - "uptr result_sz;" - (body) - "return result_sz;")] [else (body)])))) @@ -1617,7 +1469,7 @@ (code-block (format "ISPC p_at_spc = ~a;" (case (lookup 'mode config) - [(copy mark vfasl-copy) "si->space"] + [(copy mark) "si->space"] [else "SPACE(p)"])) (let loop ([all-clauses all-clauses] [else? #f]) (match all-clauses @@ -1687,7 +1539,7 @@ (relocate-statement 'pure "tmp_p" config) (format "~a = tmp_p;" (field-expression field config "new_p" #f)))] [(self-test) #f] - [(measure vfasl-copy vfasl-sweep) + [(measure) (statements (list `(trace ,field)) config)] [(mark) (relocate-statement 'pure (field-expression field config "p" #t) config)] @@ -1723,14 +1575,12 @@ (field-expression field config "new_p" #f) (field-expression field config "p" #f))) (statements (cdr l) config))] - [(vfasl-copy) - (statements (cons `(copy ,field) (cdr l)) config)] [else (statements (cdr l) config)])] [else (statements (cons `(copy ,field) (cdr l)) config)])] [`(copy-bytes ,offset ,len) (code (case (lookup 'mode config) - [(copy vfasl-copy) + [(copy) (format "memcpy_aligned(&~a, &~a, ~a);" (field-expression offset config "new_p" #t) (field-expression offset config "p" #t) @@ -1739,7 +1589,7 @@ (statements (cdr l) config))] [`(copy-type ,field) (case (lookup 'mode config) - [(copy vfasl-copy) + [(copy) (code (format "~a = ~a;" (field-expression field config "new_p" #f) @@ -1758,11 +1608,11 @@ config)] [`(trace-ptrs ,offset ,len ,purity) (case (lookup 'mode config) - [(copy vfasl-copy) + [(copy) (statements (cons `(copy-bytes ,offset (* ptr_bytes ,len)) (cdr l)) config)] - [(sweep measure sweep-in-old vfasl-sweep check) + [(sweep measure sweep-in-old check) (code (loop-over-pointers (field-expression offset config "p" #t) @@ -1805,21 +1655,6 @@ (cons `(known-space ,s) config) config))] [else (statements (cdr l) config)])] - [`(vspace ,s) - (case (lookup 'mode config) - [(vfasl-copy) - (cond - [(not s) (code)] - [else - (code (code-indent "int p_vspc = " - (expression s config #f #t) - ";") - (statements (cdr l) (cons '(vspace-ready? #t) config)))])] - [(vfasl-sweep) - (cond - [(not s) (code)] - [else (statements (cdr l) config)])] - [else (statements (cdr l) config)])] [`(size ,sz) (statements (cons `(size ,sz ,1) (cdr l)) config)] [`(size ,sz ,scale) @@ -1842,25 +1677,18 @@ config)] [rest (case mode - [(copy vfasl-copy) - (case mode - [(copy) (unless (lookup 'space-ready? config #f) - (error 'generate "size before space"))] - [(vfasl-copy) (unless (lookup 'vspace-ready? config #f) - (error 'generate "size before vspace for ~a/~a" - (lookup 'basetype config) - (lookup 'type config #f)))]) + [(copy) + (unless (lookup 'space-ready? config #f) + (error 'generate "size before space")) (hashtable-set! (lookup 'used config) 'p_sz #t) (code (format "~a, ~a, p_sz, new_p);" - (case mode - [(copy) "find_gc_room(tgc, p_spc, tg"] - [(vfasl-copy) "FIND_ROOM(vfi, p_vspc"]) + "find_gc_room(tgc, p_spc, tg" (as-c 'type (lookup 'basetype config))) (statements (let ([extra (lookup 'copy-extra config #f)]) (if extra (cons `(copy ,extra) (cdr l)) (let* ([mode (lookup 'mode config)] - [extra (and (memq mode '(copy vfasl-copy)) + [extra (and (memq mode '(copy)) (lookup 'copy-extra-rtd config #f))]) (if extra (cons `(set! (,extra _copy_) @@ -1878,10 +1706,6 @@ [(size) (hashtable-set! (lookup 'used config) 'p_sz #t) (code "return p_sz;")] - [(vfasl-sweep) - (hashtable-set! (lookup 'used config) 'p_sz #t) - (code "result_sz = p_sz;" - (statements (cdr l) config))] [(measure) (hashtable-set! (lookup 'used config) 'p_sz #t) (code "measure_total += p_sz;" @@ -2057,7 +1881,7 @@ (match a [`_ "p"] [`_copy_ (case (lookup 'mode config) - [(copy vfasl-copy) "new_p"] + [(copy) "new_p"] [else "p"])] [`_size_ (cond @@ -2193,12 +2017,10 @@ (cond [(or (eq? mode 'sweep) (eq? mode 'sweep-in-old) - (eq? mode 'vfasl-sweep) (and early? (or (eq? mode 'copy) (eq? mode 'mark)))) (relocate-statement purity (field-expression field config "p" #t) config)] - [(or (eq? mode 'copy) - (eq? mode 'vfasl-copy)) + [(eq? mode 'copy) (copy-statement field config)] [(eq? mode 'measure) (measure-statement (field-expression field config "p" #f))] @@ -2215,27 +2037,22 @@ (define (relocate-statement purity e config) (define mode (lookup 'mode config)) - (define (get-start) (expression '_ config)) - (define (get-size) (cond - [(lookup 'early-rtd? config #f) - (expression '(size_record_inst (UNFIX (record-type-size (record-type _)))) config)] - [(lookup 'early-code? config #f) - (expression '(size_closure (CODEFREE (CLOSCODE _))) config)] - [else - (expression '_size_ config)])) (case mode - [(vfasl-sweep) - (format "vfasl_relocate(vfi, &~a);" e)] [(sweep-in-old) (if (eq? purity 'pure) - (format "relocate_pure(&~a, ~a, ~a);" e (get-start) (get-size)) - (format "relocate_indirect(~a, ~a, ~a);" e (get-start) (get-size)))] + (format "relocate_pure(&~a);" e) + (format "relocate_indirect(~a);" e))] [else (if (lookup 'as-dirty? config #f) (begin (when (eq? purity 'pure) (error 'relocate-statement "pure as dirty?")) - (format "relocate_dirty(&~a, youngest, ~a, ~a);" e (get-start) (get-size))) - (format "relocate_~a(&~a~a, ~a, ~a);" purity e (if (eq? purity 'impure) ", from_g" "") (get-start) (get-size)))])) + (format "relocate_dirty(&~a, youngest);" e)) + (let ([in-owner (case mode + [(copy mark) (if (lookup 'parallel? config #f) + "_in_owner" + "")] + [else ""])]) + (format "relocate_~a~a(&~a~a);" purity in-owner e (if (eq? purity 'impure) ", from_g" ""))))])) (define (measure-statement e) (code @@ -2248,7 +2065,7 @@ (define (copy-statement field config) (define mode (lookup 'mode config)) (case mode - [(copy vfasl-copy) + [(copy) (cond [(symbol? field) (unless (lookup 'copy-ready? config #f) @@ -2655,7 +2472,7 @@ (sweep1 'port "sweep_port" `((parallel? ,parallel?))) (sweep1 'port "sweep_dirty_port" `((as-dirty? #t) (parallel? ,parallel?))) - (sweep1 'closure "sweep_continuation" `((code-relocated? #t) + (sweep1 'closure "sweep_continuation" `((code-relocated? ,(not parallel?)) (assume-continuation? #t) (parallel? ,parallel?))) (sweep1 'code "sweep_code_object" `((parallel? ,parallel?)))) @@ -2677,16 +2494,6 @@ (when measure? (print-code (generate "measure" `((mode measure)))))))) - (define (gen-vfasl ofn) - (guard - (x [#t (raise x)]) - (parameterize ([current-output-port (open-output-file ofn 'replace)]) - (print-code (generate "copy" - `((mode vfasl-copy)))) - (print-code (generate "sweep" - `((mode vfasl-sweep) - (return-size? #t))))))) - (define (gen-heapcheck ofn) (guard (x [#t (raise x)]) @@ -2702,7 +2509,6 @@ (mkequates.h op)) (set! mkgc-ocd.inc (lambda (ofn) (gen-gc ofn #f #f #f))) - (set! mkgc-oce.inc (lambda (ofn) (gen-gc ofn #t #t #f))) + (set! mkgc-oce.inc (lambda (ofn) (gen-gc ofn #t #t #f))) ; not currently parallel (but could be "parallel" for ownership preservation) (set! mkgc-par.inc (lambda (ofn) (gen-gc ofn #f #f #t))) - (set! mkvfasl.inc (lambda (ofn) (gen-vfasl ofn))) (set! mkheapcheck.inc (lambda (ofn) (gen-heapcheck ofn)))) diff --git a/src/ChezScheme/s/mkheader.ss b/src/ChezScheme/s/mkheader.ss index 8e13572e1a..6c5ca768b2 100644 --- a/src/ChezScheme/s/mkheader.ss +++ b/src/ChezScheme/s/mkheader.ss @@ -45,6 +45,8 @@ [(#\?) (cons #\p rest)] [(#\>) rest] [(#\*) (cons #\s rest)] + [(#\=) (cons* #\e #\q #\l rest)] + [(#\?) (cons #\p rest)] [else (cons x rest)])) '() (string->list (symbol->string x)))))) @@ -190,7 +192,9 @@ (constant-case architecture [(pb) (nl) - (pr "#define _LARGEFILE64_SOURCE\n") ; needed on some 32-bit platforms before <stdint.h> + (pr "#ifndef _LARGEFILE64_SOURCE\n") + (pr "# define _LARGEFILE64_SOURCE\n") ; needed on some 32-bit platforms before <stdint.h> + (pr "#endif\n") (pr "#include <stdint.h>\n")] [else (void)]) @@ -274,6 +278,7 @@ (deftotypep "Svectorp" ($ mask-vector) ($ type-vector)) (deftotypep "Sfxvectorp" ($ mask-fxvector) ($ type-fxvector)) + (deftotypep "Sflvectorp" ($ mask-flvector) ($ type-flvector)) (deftotypep "Sbytevectorp" ($ mask-bytevector) ($ type-bytevector)) (deftotypep "Sstringp" ($ mask-string) ($ type-string)) (deftotypep "Sstencil_vectorp" ($ mask-stencil-vector) ($ type-stencil-vector)) @@ -308,6 +313,12 @@ (access "x" fxvector type) ($ fxvector-length-offset))) (defref Sfxvector_ref fxvector data) + + (def "Sflvector_length(x)" + (format "((iptr)((uptr)~a>>~d))" + (access "x" flvector type) + ($ flvector-length-offset))) + (defref Sflvector_ref flvector data) (def "Sbytevector_length(x)" (format "((iptr)((uptr)~a>>~d))" @@ -347,6 +358,7 @@ (format "((void)(~a = (string_char)(uptr)Schar(c)))" (access "x" "i" string data))) (def "Sfxvector_set(x,i,n)" "((void)(Sfxvector_ref(x,i) = (n)))") + (def "Sflvector_set(x,i,n)" "((void)(Sflvector_ref(x,i) = (n)))") (def "Sbytevector_u8_set(x,i,n)" "((void)(Sbytevector_u8_ref(x,i) = (n)))") (export "void" "Svector_set" "(ptr, iptr, ptr)") @@ -370,6 +382,7 @@ (export "ptr" "Sflonum" "(double)") (export "ptr" "Smake_vector" "(iptr, ptr)") (export "ptr" "Smake_fxvector" "(iptr, ptr)") + (export "ptr" "Smake_flvector" "(iptr, ptr)") (export "ptr" "Smake_bytevector" "(iptr, int)") (export "ptr" "Smake_string" "(iptr, int)") (export "ptr" "Smake_uninitialized_string" "(iptr)") @@ -422,6 +435,7 @@ (export "void" "Sregister_boot_file" "(const char *)") (export "void" "Sregister_boot_direct_file" "(const char *)") (export "void" "Sregister_boot_file_fd" "(const char *, int fd)") + (export "void" "Sregister_boot_file_fd_region" "(const char *, int fd, iptr offset, iptr len, int close_after)") (export "void" "Sregister_heap_file" "(const char *)") (export "void" "Scompact_heap" "(void)") (export "void" "Ssave_heap" "(const char *, int)") @@ -640,9 +654,12 @@ (pr " : \"r\" (addr) \\~%") (pr " : \"flags\", \"memory\")~%")))] [(ppc32) + (let ([reg (constant-case machine-type-name + [(ppc32osx tppc32osx) ""] + [else "%%"])]) (pr "#define INITLOCK(addr) \\~%") - (pr " __asm__ __volatile__ (\"li %%r0, 0\\n\\t\"\\~%") - (pr " \"stw %%r0, 0(%0)\\n\\t\"\\~%") + (pr " __asm__ __volatile__ (\"li ~ar0, 0\\n\\t\"\\~%" reg) + (pr " \"stw ~ar0, 0(%0)\\n\\t\"\\~%" reg) (pr " : \\~%") (pr " : \"b\" (addr)\\~%") (pr " :\"memory\", \"r0\")~%") @@ -650,16 +667,16 @@ (nl) (pr "#define SPINLOCK(addr) \\~%") (pr " __asm__ __volatile__ (\"0:\\n\\t\"\\~%") ; top: - (pr " \"lwarx %%r0, 0, %0\\n\\t\"\\~%") ; start lock acquisition - (pr " \"cmpwi %%r0, 0\\n\\t\"\\~%") ; see if someone already owns the lock + (pr " \"lwarx ~ar0, 0, %0\\n\\t\"\\~%" reg) ; start lock acquisition + (pr " \"cmpwi ~ar0, 0\\n\\t\"\\~%" reg) ; see if someone already owns the lock (pr " \"bne 1f\\n\\t\"\\~%") ; if so, go to our try_again loop - (pr " \"li %%r0, 1\\n\\t\"\\~%") ; attempt to store the value 1 - (pr " \"stwcx. %%r0, 0, %0\\n\\t\"\\~%") ; + (pr " \"li ~ar0, 1\\n\\t\"\\~%" reg) ; attempt to store the value 1 + (pr " \"stwcx. ~ar0, 0, %0\\n\\t\"\\~%" reg); (pr " \"beq 2f\\n\\t\"\\~%") ; if we succeed, we own the lock (pr " \"1:\\n\\t\"\\~%") ; again: (pr " \"isync\\n\\t\"\\~%") ; sync things to pause the processor - (pr " \"lwz %%r0, 0(%0)\\n\\t\"\\~%") ; try a non-reserved load to see if we are likely to succeed - (pr " \"cmpwi %%r0, 0\\n\\t\"\\~%") ; if it is = 0, try to acquire at start + (pr " \"lwz ~ar0, 0(%0)\\n\\t\"\\~%" reg) ; try a non-reserved load to see if we are likely to succeed + (pr " \"cmpwi ~ar0, 0\\n\\t\"\\~%" reg) ; if it is = 0, try to acquire at start (pr " \"beq 0b\\n\\t\"\\~%") ; (pr " \"b 1b\\n\\t\"\\~%") ; othwerise loop through the try again (pr " \"2:\\n\\t\"\\~%") ; done: @@ -669,8 +686,8 @@ (nl) (pr "#define UNLOCK(addr) \\~%") - (pr " __asm__ __volatile__ (\"li %%r0, 0\\n\\t\"\\~%") - (pr " \"stw %%r0, 0(%0)\\n\\t\"\\~%") + (pr " __asm__ __volatile__ (\"li ~ar0, 0\\n\\t\"\\~%" reg) + (pr " \"stw ~ar0, 0(%0)\\n\\t\"\\~%" reg) (pr " : \\~%") (pr " : \"b\" (addr)\\~%") (pr " :\"memory\", \"r0\")~%") @@ -679,11 +696,11 @@ (pr "#define LOCKED_INCR(addr, ret) \\~%") (pr " __asm__ __volatile__ (\"li %0, 0\\n\\t\"\\~%") (pr " \"0:\\n\\t\"\\~%") - (pr " \"lwarx %%r12, 0, %1\\n\\t\"\\~%") - (pr " \"addi %%r12, %%r12, 1\\n\\t\"\\~%") - (pr " \"stwcx. %%r12, 0, %1\\n\\t\"\\~%") + (pr " \"lwarx ~ar12, 0, %1\\n\\t\"\\~%" reg) + (pr " \"addi ~ar12, ~ar12, 1\\n\\t\"\\~%" reg reg) + (pr " \"stwcx. ~ar12, 0, %1\\n\\t\"\\~%" reg) (pr " \"bne 0b\\n\\t\"\\~%") - (pr " \"cmpwi %%r12, 0\\n\\t\"\\~%") + (pr " \"cmpwi ~ar12, 0\\n\\t\"\\~%" reg) (pr " \"bne 1f\\n\\t\"\\~%") (pr " \"li %0, 1\\n\\t\"\\~%") (pr " \"1:\\n\\t\"\\~%") @@ -695,17 +712,17 @@ (pr "#define LOCKED_DECR(addr, ret) \\~%") (pr " __asm__ __volatile__ (\"li %0, 0\\n\\t\"\\~%") (pr " \"0:\\n\\t\"\\~%") - (pr " \"lwarx %%r12, 0, %1\\n\\t\"\\~%") - (pr " \"addi %%r12, %%r12, -1\\n\\t\"\\~%") - (pr " \"stwcx. %%r12, 0, %1\\n\\t\"\\~%") + (pr " \"lwarx ~ar12, 0, %1\\n\\t\"\\~%" reg) + (pr " \"addi ~ar12, ~ar12, -1\\n\\t\"\\~%" reg reg) + (pr " \"stwcx. ~ar12, 0, %1\\n\\t\"\\~%" reg) (pr " \"bne 0b\\n\\t\"\\~%") - (pr " \"cmpwi %%r12, 0\\n\\t\"\\~%") + (pr " \"cmpwi ~ar12, 0\\n\\t\"\\~%" reg) (pr " \"bne 1f\\n\\t\"\\~%") (pr " \"li %0, 1\\n\\t\"\\~%") (pr " \"1:\\n\\t\"\\~%") (pr " : \"=&r\" (ret)\\~%") (pr " : \"r\" (addr)\\~%") - (pr " : \"cc\", \"memory\", \"r12\")~%")] + (pr " : \"cc\", \"memory\", \"r12\")~%"))] [(arm32) (pr "#define INITLOCK(addr) \\~%") (pr " __asm__ __volatile__ (\"mov r12, #0\\n\\t\"\\~%") @@ -752,6 +769,7 @@ (pr " \"cmp r7, #0\\n\\t\"\\~%") (pr " \"bne 0b\\n\\t\"\\~%") (pr " \"cmp r12, #0\\n\\t\"\\~%") + (pr " \"it eq\\n\\t\"\\~%") (pr " \"moveq %0, #1\\n\\t\"\\~%") (pr " : \"=&r\" (ret)\\~%") (pr " : \"r\" (addr)\\~%") @@ -767,6 +785,7 @@ (pr " \"cmp r7, #0\\n\\t\"\\~%") (pr " \"bne 0b\\n\\t\"\\~%") (pr " \"cmp r12, #0\\n\\t\"\\~%") + (pr " \"it eq\\n\\t\"\\~%") (pr " \"moveq %0, #1\\n\\t\"\\~%") (pr " : \"=&r\" (ret)\\~%") (pr " : \"r\" (addr)\\~%") @@ -809,6 +828,8 @@ (nl) (pr "#define LOCKED_INCR(addr, ret) \\~%") + (pr " do {\\~%") + (pr " long _return_;\\~%") (pr " __asm__ __volatile__ (\"mov %0, #0\\n\\t\"\\~%") (pr " \"0:\\n\\t\"\\~%") (pr " \"ldxr x12, [%1, #0]\\n\\t\"\\~%") @@ -820,12 +841,16 @@ (pr " \"bne 1f\\n\\t\"\\~%") (pr " \"mov %0, #1\\n\\t\"\\~%") (pr " \"1:\\n\\t\"\\~%") - (pr " : \"=&r\" (ret)\\~%") + (pr " : \"=&r\" (_return_)\\~%") (pr " : \"r\" (addr)\\~%") - (pr " : \"cc\", \"memory\", \"x12\", \"x7\")~%") + (pr " : \"cc\", \"memory\", \"x12\", \"x7\");\\~%") + (pr " ret = _return_;\\~%") + (pr " } while (0)~%") (nl) (pr "#define LOCKED_DECR(addr, ret) \\~%") + (pr " do {\\~%") + (pr " long _return_;\\~%") (pr " __asm__ __volatile__ (\"mov %0, #0\\n\\t\"\\~%") (pr " \"0:\\n\\t\"\\~%") (pr " \"ldxr x12, [%1, #0]\\n\\t\"\\~%") @@ -837,9 +862,11 @@ (pr " \"bne 1f\\n\\t\"\\~%") (pr " \"mov %0, #1\\n\\t\"\\~%") (pr " \"1:\\n\\t\"\\~%") - (pr " : \"=&r\" (ret)\\~%") + (pr " : \"=&r\" (_return_)\\~%") (pr " : \"r\" (addr)\\~%") - (pr " : \"cc\", \"memory\", \"x12\", \"x7\")~%")] + (pr " : \"cc\", \"memory\", \"x12\", \"x7\");\\~%") + (pr " ret = _return_;\\~%") + (pr " } while (0)~%")] [(pb) (pr "#define INITLOCK(addr) (*((long *) addr) = 0)~%") (pr "#define SPINLOCK(addr) (*((long *) addr) = 1)~%") @@ -1000,6 +1027,9 @@ (defref FXVECTOR_TYPE fxvector type) (defref FXVECTIT fxvector data) + (defref FLVECTOR_TYPE flvector type) + (defref FLVECTIT flvector data) + (defref BYTEVECTOR_TYPE bytevector type) (defref BVIT bytevector data) @@ -1069,7 +1099,7 @@ (defref RTDCOUNTSTIMESTAMP rtd-counts timestamp) (defref RTDCOUNTSIT rtd-counts data) - (defref RECORDDESCPARENT record-type parent) + (defref RECORDDESCANCESTRY record-type ancestry) (defref RECORDDESCSIZE record-type size) (defref RECORDDESCPM record-type pm) (defref RECORDDESCMPM record-type mpm) @@ -1125,6 +1155,14 @@ (defref RPCOMPACTHEADERMASKANDSIZE rp-compact-header mask+size+mode) (defref RPCOMPACTHEADERTOPLINK rp-compact-header toplink) + (defref VFASLHEADER_DATA_SIZE vfasl-header data-size) + (defref VFASLHEADER_TABLE_SIZE vfasl-header table-size) + (defref VFASLHEADER_RESULT_OFFSET vfasl-header result-offset) + (defref VFASLHEADER_VSPACE_REL_OFFSETS vfasl-header vspace-rel-offsets) + (defref VFASLHEADER_SYMREF_COUNT vfasl-header symref-count) + (defref VFASLHEADER_RTDREF_COUNT vfasl-header rtdref-count) + (defref VFASLHEADER_SINGLETONREF_COUNT vfasl-header singletonref-count) + (nl) (comment "machine types") (pr "#define machine_type_names ") diff --git a/src/ChezScheme/s/newhash.ss b/src/ChezScheme/s/newhash.ss index 0dcbc6c5cb..4d049d7724 100644 --- a/src/ChezScheme/s/newhash.ss +++ b/src/ChezScheme/s/newhash.ss @@ -22,6 +22,11 @@ Documentation notes: hashtable-entries. - symbols are collectable, so weak hash tables should not be used to create permanent associations with symbols as keys +- a weak or ephemeron generic hashtable maps keys to #f using weak + pairs, and then uses a weak or ephemeron eq hashtable to map the key + to its value; use the size of the eq hashtable as the generic hashtable's + size +- an eqv hashtabble pairs an eq hashtable and an generic hashtable |# #| @@ -113,8 +118,8 @@ Documentation notes: ; NB: allow negative exact integers. (let ([i (hash x)]) (cond - [(fixnum? i) (fxlogand i mask)] - [(bignum? i) (logand i mask)] + [(fixnum? i) (fxlogand (fixmix i) mask)] + [(bignum? i) (fxlogand (fixmix (bitwise-and i (most-positive-fixnum))) mask)] [else ($oops who "invalid hash-function ~s return value ~s for ~s" hash i x)])))) (define size->minlen @@ -133,7 +138,12 @@ Documentation notes: (if (null? b) v (let ([a (car b)]) - (if (equiv? (car a) x) (cdr a) (loop (cdr b))))))))) + (if (equiv? (car a) x) + (let ([eqht (gen-ht-eqht h)]) + (if eqht + (eq-hashtable-ref eqht (car a) v) + (cdr a))) + (loop (cdr b))))))))) (define $gen-hashtable-ref-cell (lambda (h x who) @@ -142,7 +152,12 @@ Documentation notes: (if (null? b) #f (let ([a (car b)]) - (if (equiv? (car a) x) a (loop (cdr b))))))))) + (if (equiv? (car a) x) + (let ([eqht (gen-ht-eqht h)]) + (if eqht + (eq-hashtable-ref-cell eqht (car a)) + a)) + (loop (cdr b))))))))) (define $gen-hashtable-contains? (lambda (h x who) @@ -155,19 +170,19 @@ Documentation notes: (module ($gen-hashtable-set! $gen-hashtable-update! $gen-hashtable-cell $gen-hashtable-delete!) (define-syntax incr-size! (syntax-rules () - [(_ h vec who) + [(_ h eqht vec who) (let ([size (fx+ (ht-size h) 1)] [n (vector-length vec)]) (ht-size-set! h size) (when (and (fx> size n) (fx< n (fxsrl (most-positive-fixnum) 1))) - (adjust! h vec (fxsll n 1) who)))])) + (adjust! h vec (if eqht (fxmin (fxsll n 1) (vector-length (ht-vec eqht))) (fxsll n 1)) who)))])) (define-syntax decr-size! (syntax-rules () - [(_ h vec who) + [(_ h eqht vec who) (let ([size (fx- (ht-size h) 1)] [n (vector-length vec)]) (ht-size-set! h size) (when (and (fx< size (fxsrl n 2)) (fx> n (ht-minlen h))) - (adjust! h vec (fxsrl n 1) who)))])) + (adjust! h vec (if eqht (fxmin (fxsrl n 1) (vector-length (ht-vec eqht))) (fxsrl n 1)) who)))])) (define adjust! (lambda (h vec1 n2 who) @@ -178,8 +193,11 @@ Documentation notes: (lambda (b) (for-each (lambda (a) - (let ([hc (do-hash hash (car a) mask2 who)]) - (vector-set! vec2 hc (cons a (vector-ref vec2 hc))))) + (let ([k (car a)]) + (if (eq? k #!bwp) + (ht-size-set! h (fx- (ht-size h) 1)) + (let ([hc (do-hash hash k mask2 who)]) + (vector-set! vec2 hc (cons a (vector-ref vec2 hc))))))) b)) vec1) (ht-vec-set! h vec2)))) @@ -191,11 +209,21 @@ Documentation notes: (let ([bucket (vector-ref vec idx)]) (let loop ([b bucket]) (if (null? b) - (begin - (vector-set! vec idx (cons (cons x v) bucket)) - (incr-size! h vec who)) + (let ([eqht (gen-ht-eqht h)]) + (cond + [eqht + (eq-hashtable-set! eqht x v) + (vector-set! vec idx (cons (weak-cons x '()) bucket))] + [else + (vector-set! vec idx (cons (cons x v) bucket))]) + (incr-size! h eqht vec who)) (let ([a (car b)]) - (if (equiv? (car a) x) (set-cdr! a v) (loop (cdr b))))))))))) + (if (equiv? (car a) x) + (let ([eqht (gen-ht-eqht h)]) + (if eqht + (eq-hashtable-set! eqht (car a) v) + (set-cdr! a v))) + (loop (cdr b))))))))))) (define $gen-hashtable-update! (lambda (h x p v who) @@ -204,12 +232,21 @@ Documentation notes: (let ([bucket (vector-ref vec idx)]) (let loop ([b bucket]) (if (null? b) - (begin - (vector-set! vec idx (cons (cons x (p v)) bucket)) - (incr-size! h vec who)) + (let ([eqht (gen-ht-eqht h)]) + (cond + [eqht + (eq-hashtable-set! eqht x (p v)) + (vector-set! vec idx (cons (weak-cons x '()) bucket))] + [else + (vector-set! vec idx (cons (cons x (p v)) bucket))]) + (incr-size! h eqht vec who)) (let ([a (car b)]) (if (equiv? (car a) x) - (set-cdr! a (p (cdr a))) + (let ([eqht (gen-ht-eqht h)]) + (if eqht + (let ([c (eq-hashtable-cell eqht (car a) v)]) + (set-cdr! c (p (cdr c)))) + (set-cdr! a (p (cdr a))))) (loop (cdr b))))))))))) (define $gen-hashtable-cell @@ -219,13 +256,24 @@ Documentation notes: (let ([bucket (vector-ref vec idx)]) (let loop ([b bucket]) (if (null? b) - (let ([a (cons x v)]) - (vector-set! vec idx (cons a bucket)) - (incr-size! h vec who) + (let* ([eqht (gen-ht-eqht h)] + [a (cond + [eqht + (let ([a (eq-hashtable-cell eqht x v)]) + (vector-set! vec idx (cons (weak-cons x '()) bucket)) + a)] + [else + (let ([a (cons x v)]) + (vector-set! vec idx (cons a bucket)) + a)])]) + (incr-size! h eqht vec who) a) (let ([a (car b)]) (if (equiv? (car a) x) - a + (let ([eqht (gen-ht-eqht h)]) + (if eqht + (eq-hashtable-cell eqht (car a) v) + a)) (loop (cdr b))))))))))) (define $gen-hashtable-delete! @@ -236,32 +284,37 @@ Documentation notes: (unless (null? b) (let ([a (car b)]) (if (equiv? (car a) x) - (begin + (let ([eqht (gen-ht-eqht h)]) + (when eqht (eq-hashtable-delete! eqht (car a))) (if p (set-cdr! p (cdr b)) (vector-set! vec idx (cdr b))) - (decr-size! h vec who)) + (decr-size! h eqht vec who)) (loop (cdr b) b)))))))))) (module ($gen-hashtable-copy $symbol-hashtable-copy) (define copy-hashtable-vector - (lambda (h) + (lambda (h eq-ht) (let* ([vec1 (ht-vec h)] [n (vector-length vec1)] [vec2 (make-vector n '())]) (do ([i 0 (fx+ i 1)]) ((fx= i n)) (vector-set! vec2 i - (map (lambda (a) (cons (car a) (cdr a))) - (vector-ref vec1 i)))) + (if eq-ht + (map (lambda (a) (weak-cons (car a) '())) + (vector-ref vec1 i)) + (map (lambda (a) (cons (car a) (cdr a))) + (vector-ref vec1 i))))) vec2))) (define $gen-hashtable-copy (lambda (h mutable?) - (make-gen-ht 'generic mutable? (copy-hashtable-vector h) (ht-minlen h) (ht-size h) - (gen-ht-hash h) (gen-ht-equiv? h)))) + (let ([eq-ht (gen-ht-eqht h)]) + (make-gen-ht 'generic mutable? (copy-hashtable-vector h eq-ht) (ht-minlen h) (ht-size h) + (gen-ht-hash h) (gen-ht-equiv? h) (and eq-ht ($eq-hashtable-copy eq-ht mutable?)))))) (define $symbol-hashtable-copy (lambda (h mutable?) - (make-symbol-ht 'symbol mutable? (copy-hashtable-vector h) (ht-minlen h) (ht-size h) + (make-symbol-ht 'symbol mutable? (copy-hashtable-vector h #f) (ht-minlen h) (ht-size h) (symbol-ht-equiv? h))))) (define $ht-hashtable-clear! @@ -270,6 +323,11 @@ Documentation notes: (ht-minlen-set! h minlen) (ht-size-set! h 0))) + (define $gen-hashtable-clear! + (lambda (h minlen) + (let ([h (gen-ht-eqht h)]) (when h ($eq-hashtable-clear! h minlen))) + ($ht-hashtable-clear! h minlen))) + (define $ht-hashtable-keys (lambda (h max-sz) (let ([size (fxmin max-sz (ht-size h))]) @@ -286,6 +344,13 @@ Documentation notes: (g (cdr b) (fx+ ikey 1)))))))) keys)))) + (define $gen-hashtable-keys + (lambda (h max-sz) + (let ([eqht (gen-ht-eqht h)]) + (if eqht + ($eq-hashtable-keys eqht max-sz) + ($ht-hashtable-keys h max-sz))))) + (define $ht-hashtable-values (lambda (h max-sz) (let ([size (fxmin max-sz (ht-size h))]) @@ -302,6 +367,13 @@ Documentation notes: (g (cdr b) (fx+ ival 1)))))))) vals)))) + (define $gen-hashtable-values + (lambda (h max-sz) + (let ([eqht (gen-ht-eqht h)]) + (if eqht + ($eq-hashtable-values eqht max-sz) + ($ht-hashtable-values h max-sz))))) + (define $ht-hashtable-entries (lambda (h max-sz) (let ([size (fxmin max-sz (ht-size h))]) @@ -320,6 +392,13 @@ Documentation notes: (g (cdr b) (fx+ ikey 1)))))))) (values keys vals))))) + (define $gen-hashtable-entries + (lambda (h max-sz) + (let ([eqht (gen-ht-eqht h)]) + (if eqht + ($eq-hashtable-entries eqht max-sz) + ($ht-hashtable-entries h max-sz))))) + (define $ht-hashtable-cells (lambda (h max-sz) (let ([sz (fxmin max-sz (ht-size h))]) @@ -336,6 +415,13 @@ Documentation notes: (g (cdr b) (fx+ icell 1)))))))) cells)))) + (define $gen-hashtable-cells + (lambda (h max-sz) + (let ([eqht (gen-ht-eqht h)]) + (if eqht + ($eq-hashtable-cells eqht max-sz) + ($ht-hashtable-cells h max-sz))))) + (define eqv-generic? (lambda (x) ; all numbers except fixnums must go through generic hashtable @@ -408,32 +494,55 @@ Documentation notes: (define $eqv-hashtable-keys (lambda (h max-sz) (let* ([keys1 ($eq-hashtable-keys (eqv-ht-eqht h) max-sz)] - [keys2 ($ht-hashtable-keys (eqv-ht-genht h) (fx- max-sz (vector-length keys1)))]) + [keys2 ($gen-hashtable-keys (eqv-ht-genht h) (fx- max-sz (vector-length keys1)))]) (vector-append keys1 keys2)))) (define $eqv-hashtable-values (lambda (h max-sz) (let* ([vals1 ($eq-hashtable-values (eqv-ht-eqht h) max-sz)] - [vals2 ($ht-hashtable-values (eqv-ht-genht h) (fx- max-sz (vector-length vals1)))]) + [vals2 ($gen-hashtable-values (eqv-ht-genht h) (fx- max-sz (vector-length vals1)))]) (vector-append vals1 vals2)))) (define $eqv-hashtable-entries (lambda (h max-sz) (let*-values ([(keys1 vals1) ($eq-hashtable-entries (eqv-ht-eqht h) max-sz)] - [(keys2 vals2) ($ht-hashtable-entries (eqv-ht-genht h) (fx- max-sz (vector-length keys1)))]) + [(keys2 vals2) ($gen-hashtable-entries (eqv-ht-genht h) (fx- max-sz (vector-length keys1)))]) (values (vector-append keys1 keys2) (vector-append vals1 vals2))))) (define $eqv-hashtable-cells (lambda (h max-sz) (let* ([cells1 ($eq-hashtable-cells (eqv-ht-eqht h) max-sz)] - [cells2 ($ht-hashtable-cells (eqv-ht-genht h) (fx- max-sz (vector-length cells1)))]) + [cells2 ($gen-hashtable-cells (eqv-ht-genht h) (fx- max-sz (vector-length cells1)))]) (vector-append cells1 cells2))))) + (define (fixmix x) + ;; Since mutable hash tables tend to use the low bits of a hash code, + ;; make sure higher bits of a fixnum are represented there + (let* ([x1 (constant-case ptr-bits + [(64) (fxxor x (fxand (fxsrl x 32) #xFFFFFFFF))] + [else x])] + [x2 (fxxor x1 (fxand (fxsrl x1 16) #xFFFF))] + [x3 (fxxor x2 (fxand (fxsrl x2 8) #xFF))]) + x3)) + (define number-hash (lambda (z) (cond [(fixnum? z) (if (fx< z 0) (fxnot z) z)] [(flonum? z) ($flhash z)] - [(bignum? z) (modulo z (most-positive-fixnum))] + [(bignum? z) (let ([len (integer-length z)] + [update (lambda (hc k) + (let ([hc2 (fx+/wraparound hc (fxsll/wraparound (fx+/wraparound hc k) 10))]) + (fxlogxor hc2 (fxsrl hc2 6))))]) + (let loop ([i 0] [hc 0]) + (cond + [(fx>= i len) hc] + [else + (let ([next-i (fx+ i (fx- (fixnum-width) 1))]) + (loop next-i + (bitwise-and + (most-positive-fixnum) + (update (bitwise-bit-field z i next-i) + hc))))])))] [(ratnum? z) (number-hash (+ (* (numerator z) 5) (denominator z)))] [else (logxor (lognot (number-hash (real-part z))) (number-hash (imag-part z)))]))) @@ -446,6 +555,11 @@ Documentation notes: (unless (xht? h) ($oops who "~s is not a hashtable" h)) (case (xht-type h) [(eqv) (values (vector-length (ht-vec (eqv-ht-eqht h))) (vector-length (ht-vec (eqv-ht-genht h))))] + [(generic) (let ([eqht (gen-ht-eqht h)] + [len (vector-length (ht-vec h))]) + (if eqht + (values len (vector-length (ht-vec eqht))) + len))] [else (vector-length (ht-vec h))]))) (set-who! $ht-veclen @@ -551,29 +665,45 @@ Documentation notes: (let () (define $make-hashtable - (lambda (minlen hash equiv?) + (lambda (minlen hash equiv? subtype) (if (and (eq? hash symbol-hash) + (eq? subtype (constant eq-hashtable-subtype-normal)) (or (eq? equiv? eq?) (eq? equiv? symbol=?) (eq? equiv? eqv?) (eq? equiv? equal?))) (make-symbol-ht 'symbol #t (make-vector minlen '()) minlen 0 equiv?) - (make-gen-ht 'generic #t (make-vector minlen '()) minlen 0 hash equiv?)))) + (make-gen-ht 'generic #t (make-vector minlen '()) minlen 0 hash equiv? + (cond + [(eq? subtype (constant eq-hashtable-subtype-normal)) #f] + [else ($make-eq-hashtable minlen subtype)]))))) (define $make-eqv-hashtable (lambda (minlen subtype) (make-eqv-ht 'eqv #t ($make-eq-hashtable minlen subtype) - ($make-hashtable minlen number-hash eqv?)))) - (set-who! make-hashtable + ($make-hashtable minlen number-hash eqv? subtype)))) + (define $make-gen-hashtable (case-lambda - [(hash equiv?) + [(who hash equiv? subtype) (unless (procedure? hash) ($oops who "~s is not a procedure" hash)) (unless (procedure? equiv?) ($oops who "~s is not a procedure" equiv?)) - ($make-hashtable (constant hashtable-default-size) hash equiv?)] - [(hash equiv? k) + ($make-hashtable (constant hashtable-default-size) hash equiv? subtype)] + [(who hash equiv? k subtype) (unless (procedure? hash) ($oops who "~s is not a procedure" hash)) (unless (procedure? equiv?) ($oops who "~s is not a procedure" equiv?)) - ($make-hashtable (size->minlen who k) hash equiv?)])) + ($make-hashtable (size->minlen who k) hash equiv? subtype)])) + (set-who! make-hashtable + (case-lambda + [(hash equiv?) ($make-gen-hashtable who hash equiv? (constant eq-hashtable-subtype-normal))] + [(hash equiv? k) ($make-gen-hashtable who hash equiv? k (constant eq-hashtable-subtype-normal))])) + (set-who! make-weak-hashtable + (case-lambda + [(hash equiv?) ($make-gen-hashtable who hash equiv? (constant eq-hashtable-subtype-weak))] + [(hash equiv? k) ($make-gen-hashtable who hash equiv? k (constant eq-hashtable-subtype-weak))])) + (set-who! make-ephemeron-hashtable + (case-lambda + [(hash equiv?) ($make-gen-hashtable who hash equiv? (constant eq-hashtable-subtype-ephemeron))] + [(hash equiv? k) ($make-gen-hashtable who hash equiv? k (constant eq-hashtable-subtype-ephemeron))])) (set-who! make-eqv-hashtable (case-lambda [() ($make-eqv-hashtable (constant hashtable-default-size) (constant eq-hashtable-subtype-normal))] @@ -659,6 +789,8 @@ Documentation notes: (case (xht-type h) [(eq) (eq? (constant eq-hashtable-subtype-weak) (eq-ht-subtype h))] [(eqv) (eq? (constant eq-hashtable-subtype-weak) (eq-ht-subtype (eqv-ht-eqht h)))] + [(generic) (let ([eq-ht (gen-ht-eqht h)]) + (and eq-ht (eq? (constant eq-hashtable-subtype-weak) (eq-ht-subtype eq-ht))))] [else #f]))) (set-who! hashtable-ephemeron? @@ -667,6 +799,8 @@ Documentation notes: (case (xht-type h) [(eq) (eq? (constant eq-hashtable-subtype-ephemeron) (eq-ht-subtype h))] [(eqv) (eq? (constant eq-hashtable-subtype-ephemeron) (eq-ht-subtype (eqv-ht-eqht h)))] + [(generic) (let ([eq-ht (gen-ht-eqht h)]) + (and eq-ht (eq? (constant eq-hashtable-subtype-ephemeron) (eq-ht-subtype eq-ht))))] [else #f]))) (set-who! symbol-hashtable-ref @@ -833,7 +967,8 @@ Documentation notes: [(eq) ($eq-hashtable-clear! h (ht-minlen h))] [(eqv) (let ([h (eqv-ht-eqht h)]) ($eq-hashtable-clear! h (ht-minlen h))) - (let ([h (eqv-ht-genht h)]) ($ht-hashtable-clear! h (ht-minlen h)))] + (let ([h (eqv-ht-genht h)]) ($gen-hashtable-clear! h (ht-minlen h)))] + [(generic) ($gen-hashtable-clear! h (ht-minlen h))] [else ($ht-hashtable-clear! h (ht-minlen h))])] [(h k) (unless (xht? h) @@ -845,7 +980,8 @@ Documentation notes: [(eq) ($eq-hashtable-clear! h minlen)] [(eqv) ($eq-hashtable-clear! (eqv-ht-eqht h) minlen) - ($ht-hashtable-clear! (eqv-ht-genht h) minlen)] + ($gen-hashtable-clear! (eqv-ht-genht h) minlen)] + [(generic) ($gen-hashtable-clear! h minlen)] [else ($ht-hashtable-clear! h minlen)]))]))) (let () @@ -856,13 +992,14 @@ Documentation notes: (define-syntax hashtable-content-dispatch (syntax-rules () - [(_ who $eq-hashtable-content $eqv-hashtable-content $ht-hashtable-content) + [(_ who $eq-hashtable-content $eqv-hashtable-content $gen-hashtable-content $ht-hashtable-content) (let () (define (dispatch h max-sz) (unless (xht? h) (invalid-table who h)) (case (xht-type h) [(eq) ($eq-hashtable-content h max-sz)] [(eqv) ($eqv-hashtable-content h max-sz)] + [(generic) ($gen-hashtable-content h max-sz)] [else ($ht-hashtable-content h max-sz)])) (case-lambda [(h max-sz) @@ -880,6 +1017,7 @@ Documentation notes: (hashtable-content-dispatch who $eq-hashtable-keys $eqv-hashtable-keys + $gen-hashtable-keys $ht-hashtable-keys)) (set-who! #(r6rs: hashtable-keys) @@ -888,18 +1026,21 @@ Documentation notes: (case (xht-type h) [(eq) ($eq-hashtable-keys h (most-positive-fixnum))] [(eqv) ($eqv-hashtable-keys h (most-positive-fixnum))] + [(generic) ($gen-hashtable-keys h (most-positive-fixnum))] [else ($ht-hashtable-keys h (most-positive-fixnum))]))) (set-who! hashtable-values (hashtable-content-dispatch who $eq-hashtable-values $eqv-hashtable-values + $gen-hashtable-values $ht-hashtable-values)) (set-who! hashtable-entries (hashtable-content-dispatch who $eq-hashtable-entries $eqv-hashtable-entries + $gen-hashtable-entries $ht-hashtable-entries)) (set-who! #(r6rs: hashtable-entries) @@ -908,12 +1049,14 @@ Documentation notes: (case (xht-type h) [(eq) ($eq-hashtable-entries h (most-positive-fixnum))] [(eqv) ($eqv-hashtable-entries h (most-positive-fixnum))] + [(generic) ($gen-hashtable-entries h (most-positive-fixnum))] [else ($ht-hashtable-entries h (most-positive-fixnum))]))) (set-who! hashtable-cells (hashtable-content-dispatch who $eq-hashtable-cells $eqv-hashtable-cells + $gen-hashtable-cells $ht-hashtable-cells))) (set-who! hashtable-cells @@ -927,16 +1070,23 @@ Documentation notes: (case (xht-type h) [(eq) ($eq-hashtable-cells h max-sz)] [(eqv) ($eqv-hashtable-cells h max-sz)] + [(generic) ($gen-hashtable-cells h max-sz)] [else ($ht-hashtable-cells h max-sz)]))] [(h) (hashtable-cells h (hashtable-size h))])) (set! hashtable-size - (lambda (h) - (unless (xht? h) ($oops 'hashtable-size "~s is not a hashtable" h)) - (if (eq? (xht-type h) 'eqv) - (fx+ (ht-size (eqv-ht-eqht h)) - (ht-size (eqv-ht-genht h))) - (ht-size h)))) + (let ([$gen-ht-size (lambda (h) + (let ([eqht (gen-ht-eqht h)]) + (if eqht + (ht-size eqht) + (ht-size h))))]) + (lambda (h) + (unless (xht? h) ($oops 'hashtable-size "~s is not a hashtable" h)) + (case (xht-type h) + [(eqv) (fx+ (ht-size (eqv-ht-eqht h)) + ($gen-ht-size (eqv-ht-genht h)))] + [(generic) ($gen-ht-size h)] + [else (ht-size h)])))) (set! hashtable-mutable? (lambda (h) @@ -981,7 +1131,7 @@ Documentation notes: (define (hcabs hc) (if (fx< hc 0) (fxnot hc) hc)) (define (update hc k) - (let ([hc2 (#3%fx+ hc (#3%fxsll (#3%fx+ hc k) 10))]) + (let ([hc2 (fx+/wraparound hc (fxsll/wraparound (fx+/wraparound hc k) 10))]) (fxlogxor hc2 (fxsrl hc2 6)))) (define bytevector-hash @@ -1047,22 +1197,25 @@ Documentation notes: (lambda (x) (define (f x hc i) (let ([i (fx- i 1)]) + (define-syntax (vector-hash stx) + (syntax-case stx () + [(_ base vector-length vector-ref) + #'(let ([n (vector-length x)] [hc (update hc base)]) + (if (fx= n 0) + (values hc i) + (let g ([j 0] [hc hc] [i i]) + (if (or (fx= j n) (fx= i 0)) + (values hc i) + (let ([i/2 (fxsrl (fx+ i 1) 1)]) + (let-values ([(hc i^) (f (vector-ref x j) hc i/2)]) + (g (fx+ j 1) hc (fx+ (fx- i i/2) i^))))))))])) (cond [(fx<= i 0) (values hc 0)] [(pair? x) (let ([i/2 (fxsrl (fx+ i 1) 1)]) (let-values ([(hc i^) (f (car x) (update hc 119001092) i/2)]) (f (cdr x) hc (fx+ (fx- i i/2) i^))))] - [(vector? x) - (let ([n (vector-length x)] [hc (update hc 513566316)]) - (if (fx= n 0) - (values hc i) - (let g ([j 0] [hc hc] [i i]) - (if (or (fx= j n) (fx= i 0)) - (values hc i) - (let ([i/2 (fxsrl (fx+ i 1) 1)]) - (let-values ([(hc i^) (f (vector-ref x j) hc i/2)]) - (g (fx+ j 1) hc (fx+ (fx- i i/2) i^))))))))] + [(vector? x) (vector-hash 513566316 vector-length vector-ref)] [(stencil-vector? x) (let ([n (stencil-vector-length x)] [hc (update hc 517766377)]) (if (fx= n 0) @@ -1096,6 +1249,8 @@ Documentation notes: sub-hc (modulo (abs sub-hc) (greatest-fixnum))))]) (values hc new-i)))))] + [(fxvector? x) (vector-hash 513577316 fxvector-length fxvector-ref)] + [(flvector? x) (vector-hash 513599316 flvector-length flvector-ref)] [else (values (update hc 120634730) i)]))) (let-values ([(hc i) (f x 523658599 64)]) (hcabs hc))))) diff --git a/src/ChezScheme/s/np-languages.ss b/src/ChezScheme/s/np-languages.ss index 7e3e0a90a4..eab5f30c35 100644 --- a/src/ChezScheme/s/np-languages.ss +++ b/src/ChezScheme/s/np-languages.ss @@ -75,7 +75,7 @@ Lsrc Lsrc? Ltype Ltype? unparse-Ltype unparse-Lsrc lookup-primref primref? primref-level primref-name primref-flags primref-arity preinfo-src preinfo-sexpr preinfo-lambda-name preinfo-lambda-flags preinfo-lambda-libspec - preinfo-call? preinfo-call-check? + preinfo-call? preinfo-call-check? preinfo-call-no-return? prelex-name prelex-name-set!) (import (nanopass)) @@ -535,7 +535,9 @@ (declare-primitive c-call effect #f) (declare-primitive c-simple-call effect #f) (declare-primitive c-simple-return effect #f) + (declare-primitive check-stack-align effect #f) ; x86 (declare-primitive deactivate-thread effect #f) ; threaded version only + (declare-primitive debug effect #f) ; x86_64 and arm64 (declare-primitive fldl effect #f) ; x86 (declare-primitive flds effect #f) ; x86 (declare-primitive inc-cc-counter effect #f) @@ -589,6 +591,7 @@ (declare-primitive +/carry value #f) (declare-primitive -/ovfl value #f) (declare-primitive -/eq value #f) + (declare-primitive -/pos value #f) (declare-primitive asmlibcall value #f) (declare-primitive cpuid value #t) ; x86_64 only, actually side-effects ebx/ecx/edx (declare-primitive fstpl value #f) ; x86 only diff --git a/src/ChezScheme/s/pb.ss b/src/ChezScheme/s/pb.ss index 4ad46bcc5b..77ca1fc022 100644 --- a/src/ChezScheme/s/pb.ss +++ b/src/ChezScheme/s/pb.ss @@ -37,6 +37,9 @@ ;; | op | reg reg | immed/reg | ;; ----------------------------------------------- ;; ----------------------------------------------- +;; | op | reg | immed | +;; ----------------------------------------------- +;; ----------------------------------------------- ;; | op | immed | ;; ----------------------------------------------- ;; @@ -211,7 +214,7 @@ ; WARNING: do not assume that if x isn't the same as z then x is independent ; of z, since x might be an mref with z as it's base or index - (define-instruction value (- -/ovfl -/eq) + (define-instruction value (- -/ovfl -/eq -/pos) [(op (z ur) (x ur) (y signed16)) `(set! ,(make-live-info) ,z (asm ,info ,(asm-sub op) ,x ,y))] [(op (z ur) (x ur) (y ur)) @@ -620,6 +623,7 @@ (define-op div bin-op (constant pb-div)) (define-op subz signal-bin-op (constant pb-subz)) ; signals on 0 instead of overflow + (define-op subp signal-bin-op (constant pb-subp)) ; signals on positive (define-op land bin-op (constant pb-and)) (define-op lior bin-op (constant pb-ior)) @@ -942,8 +946,8 @@ (lambda (op dest offset code*) (emit-code (op dest offset code*) (constant pb-adr) - (ax-ea-reg-code dest) - offset))) + (bitwise-ior (ax-ea-reg-code dest) + (bitwise-arithmetic-shift offset 4))))) (define inc-op (lambda (op dest src code*) @@ -1107,9 +1111,13 @@ (lambda (op) (lambda (code* dest src0 src1) (Trivit (dest src0 src1) - (if (eq? op '-/eq) - (emit subz #t dest src0 src1 code*) - (emit sub (eq? op '-/ovfl) dest src0 src1 code*)))))) + (cond + [(eq? op '-/eq) + (emit subz #t dest src0 src1 code*)] + [(eq? op '-/pos) + (emit subp #t dest src0 src1 code*)] + [else + (emit sub (eq? op '-/ovfl) dest src0 src1 code*)]))))) (define asm-mul (lambda (set-cc?) @@ -1396,6 +1404,8 @@ (lambda (offset) (let ([incr-offset (adjust-return-point-offset incr-offset l)]) (let ([disp (fx- next-addr (fx- offset incr-offset))]) + (unless (<= (- (expt 2 19)) disp (sub1 (expt 2 19))) + (sorry! who "displacement to large for adr ~s" disp)) (emit adr `(reg . ,dest) disp '()))))] [else (asm-move '() dest (with-output-language (L16 Triv) `(label-ref ,l ,incr-offset)))])))) @@ -1619,5 +1629,6 @@ (define-who asm-foreign-callable (lambda (info) - (sorry! who "callables are not supported")))) + (sorry! who "callables are not supported") + (values 'c-init 'c-args 'c-result 'c-return)))) ) diff --git a/src/ChezScheme/s/ppc32.def b/src/ChezScheme/s/ppc32.def index 9f24680ff9..51f71c4940 100644 --- a/src/ChezScheme/s/ppc32.def +++ b/src/ChezScheme/s/ppc32.def @@ -7,8 +7,8 @@ (define-constant native-endianness 'big) -(define-constant max-float-alignment 8) -(define-constant max-integer-alignment 8) +(define-constant-default max-float-alignment 8) +(define-constant-default max-integer-alignment 8) (define-constant unaligned-floats #f) (define-constant unaligned-integers #t) diff --git a/src/ChezScheme/s/ppc32.ss b/src/ChezScheme/s/ppc32.ss index fcac03085f..82bf687983 100644 --- a/src/ChezScheme/s/ppc32.ss +++ b/src/ChezScheme/s/ppc32.ss @@ -75,13 +75,14 @@ [ %r19 #t 19 uptr] [ %r25 #t 25 uptr] [ %r30 #t 30 uptr] - [%fpreg1 #f 0 fp] - [%fpreg2 #f 9 fp] + [%fpreg1 #t 14 fp] + [%fpreg2 #t 15 fp] ) (machine-dependent [%sp %Csp #t 1 uptr] [%Ctoc #f 2 uptr] ;; operating system reserved [%Csda #f 13 uptr] ;; might point to small data area, if used + [%fpreg0 %fptmp1 #f 0 fp] [%Cfparg1 %Cfpretval #f 1 fp] [%Cfparg2 #f 2 fp] [%Cfparg3 #f 3 fp] @@ -90,12 +91,12 @@ [%Cfparg6 #f 6 fp] [%Cfparg7 #f 7 fp] [%Cfparg8 #f 8 fp] - [%flreg3 %fptmp1 #f 10 fp] - [%flreg4 #f 11 fp] - [%flreg5 #f 12 fp] - [%flreg6 #f 13 fp] - [%flreg7 #t 14 fp] - [%flreg8 #t 15 fp] + [%Cfparg9 #f 9 fp] + [%Cfparg10 #f 10 fp] + [%Cfparg11 #f 11 fp] + [%Cfparg12 #f 12 fp] + [%Cfparg13 #f 13 fp] + ;; 14 and 15 is are fpreg1 and fpreg2 [%flreg9 #t 16 fp] [%flreg10 #t 17 fp] [%flreg11 #t 18 fp] @@ -295,7 +296,7 @@ [(op (z ur) (x ur) (y ur)) `(set! ,(make-live-info) ,z (asm ,info ,asm-sub-from/ovfl ,y ,x))]) - (define-instruction value (-/eq) + (define-instruction value (-/eq -/pos) [(op (z ur) (x ur) (y ur)) `(set! ,(make-live-info) ,z (asm ,info ,asm-sub-from/eq ,y ,x))]) @@ -1993,7 +1994,8 @@ [(fp<= <=) (i? (r? blt bgt) (r? bge ble))] [(>) (i? (r? bge ble) (r? blt bgt))] [(>=) (i? (r? bgt blt) (r? ble bge))] - [(carry multiply-overflow overflow) (i? bns bso)]) + [(carry multiply-overflow overflow) (i? bns bso)] + [(positive) (i? ble bgt)]) (let ([type (info-condition-code-type info)] [reversed? (info-condition-code-reversed? info)]) (make-cgchunk info l1 l2 next-addr @@ -2122,16 +2124,29 @@ (module (asm-foreign-call asm-foreign-callable) (define align (lambda (b x) (let ([k (- b 1)]) (fxlogand (fx+ x k) (fxlognot k))))) (define gp-parameter-regs (lambda () (list %Carg1 %Carg2 %Carg3 %Carg4 %Carg5 %Carg6 %Carg7 %Carg8))) - (define fp-parameter-regs (lambda () (list %Cfparg1 %Cfparg2 %Cfparg3 %Cfparg4 %Cfparg5 %Cfparg6 %Cfparg7 %Cfparg8))) + (define fp-parameter-regs (lambda () + (constant-case machine-type-name + [(ppc32osx tppc32osx) + (list %Cfparg1 %Cfparg2 %Cfparg3 %Cfparg4 %Cfparg5 %Cfparg6 %Cfparg7 %Cfparg8 + %Cfparg9 %Cfparg10 %Cfparg11 %Cfparg12 %Cfparg13)] + [else + (list %Cfparg1 %Cfparg2 %Cfparg3 %Cfparg4 %Cfparg5 %Cfparg6 %Cfparg7 %Cfparg8)]))) (define fp-result-regs (lambda () (list %Cfpretval))) (define (indirect-result-that-fits-in-registers? result-type) (nanopass-case (Ltype Type) result-type [(fp-ftd& ,ftd) (not ($ftd-compound? ftd))] [else #f])) - (define (indirect-result-to-pointer? result-type) - (nanopass-case (Ltype Type) result-type - [(fp-ftd& ,ftd) ($ftd-compound? ftd)] - [else #f])) + (define (indirect-result-to-pointer result-type arg-type*) + (constant-case machine-type-name + [(ppc32osx tppc32osx) + (nanopass-case (Ltype Type) result-type + [(fp-ftd& ,ftd) (if ($ftd-compound? ftd) + (cons (with-output-language (Ltype Type) + `(fp-integer 32)) + (cdr arg-type*)) + arg-type*)] + [else arg-type*])] + [else arg-type*])) (module (push-registers pop-registers) ;; stack offset must be 8-byte aligned if fp-reg-count is non-zero @@ -2248,150 +2263,440 @@ (%seq (set! ,loreg ,lo) (set! ,hireg ,hi))))) + (define load-int64-reg+stack + (lambda (hi offset) + (lambda (lorhs hirhs) ; requires two rhss + (%seq + (set! ,hi ,hirhs) + (set! ,(%mref ,%sp ,offset) ,lorhs))))) (define load-indirect-int-reg - (lambda (ireg size category) + (lambda (ireg size category offset) (lambda (rhs) ; requires var - (let ([int-type (case category - [(unsigned) (case size - [(1) 'unsigned-8] - [(2) 'unsigned-16] - [else 'unsigned-32])] - [else (case size - [(1) 'integer-8] - [(2) 'integer-16] - [else 'integer-32])])]) - `(set! ,ireg (inline ,(make-info-load int-type #f) ,%load ,rhs ,%zero (immediate ,0))))))) + (load/store-integer 'load ireg size category rhs offset)))) + (define load/store-integer + (lambda (mode reg size category rhs offset) + (cond + [(fx= size 3) + (let ([hi-int-type (if (eq? category 'unsigned) 'unsigned-16 'integer-16)]) + (case mode + [(load) + (let ([tmp %r18]) + (%seq + (set! ,reg (inline ,(make-info-load hi-int-type #f) ,%load ,rhs ,%zero (immediate ,offset))) + (set! ,tmp (inline ,(make-info-load 'unsigned-8 #f) ,%load ,rhs ,%zero (immediate ,(fx+ 2 offset)))) + (set! ,reg ,(%inline sll ,reg (immediate 8))) + (set! ,reg ,(%inline logor ,reg ,tmp))))] + [else + ;; assumes that we can mangle `reg` + (%seq + (inline ,(make-info-load 'unsigned-8 #f) ,%store ,rhs ,%zero (immediate ,(fx+ 2 offset)) ,reg) + (set! ,reg ,(%inline sra ,reg (immediate 8))) + (inline ,(make-info-load hi-int-type #f) ,%store ,rhs ,%zero (immediate ,offset) ,reg))]))] + [else + (let ([int-type (case category + [(unsigned) (case size + [(1) 'unsigned-8] + [(2) 'unsigned-16] + [else 'unsigned-32])] + [else (case size + [(1) 'integer-8] + [(2) 'integer-16] + [else 'integer-32])])]) + (if (eq? mode 'load) + `(set! ,reg (inline ,(make-info-load int-type #f) ,%load ,rhs ,%zero (immediate ,offset))) + `(inline ,(make-info-load int-type #f) ,%store ,rhs ,%zero (immediate ,offset) ,reg)))]))) (define load-indirect-int64-reg (lambda (loreg hireg) (lambda (x) ; requires var `(seq (set! ,hireg ,(%mref ,x 0)) (set! ,loreg ,(%mref ,x 4)))))) - (define do-args - (lambda (types) - ;; NB: start stack pointer at 8 to put arguments above the linkage area - (let loop ([types types] [locs '()] [live* '()] [int* (gp-parameter-regs)] [flt* (fp-parameter-regs)] [isp 8] - ;; needed when adjusting active: - [fp-live-count 0] - ;; configured for `ftd-fp&` unpacking of floats: - [fp-disp #f]) - (if (null? types) - (values isp locs live* fp-live-count) - (nanopass-case (Ltype Type) (car types) - [(fp-double-float) - (if (constant software-floating-point) - (let ([int* (if (even? (length int*)) int* (cdr int*))]) - (if (null? int*) - (let ([isp (align 8 isp)]) - (loop (cdr types) - (cons (load-double-stack isp fp-disp) locs) - live* '() flt* (fx+ isp 8) fp-live-count - #f)) - (loop (cdr types) - (cons (load-soft-double-reg (cadr int*) (car int*) fp-disp) locs) - (cons* (car int*) (cadr int*) live*) (cddr int*) flt* isp fp-live-count - #f))) - (if (null? flt*) - (let ([isp (align 8 isp)]) - (loop (cdr types) - (cons (load-double-stack isp fp-disp) locs) - live* int* '() (fx+ isp 8) fp-live-count - #f)) - (loop (cdr types) - (cons (load-double-reg (car flt*) fp-disp) locs) - live* int* (cdr flt*) isp (fx+ fp-live-count 1) - #f)))] - [(fp-single-float) - (if (constant software-floating-point) - (if (null? int*) - ; NB: ABI says singles are passed as doubles on the stack, but gcc/linux doesn't - (loop (cdr types) - (cons (load-single-stack isp fp-disp) locs) - live* '() flt* (fx+ isp 4) fp-live-count - #f) - (loop (cdr types) - (cons (load-soft-single-reg (car int*) fp-disp) locs) - (cons (car int*) live*) (cdr int*) flt* isp fp-live-count - #f)) - (if (null? flt*) - ; NB: ABI says singles are passed as doubles on the stack, but gcc/linux doesn't - (let ([isp (align 4 isp)]) + (define load-indirect-int64-reg+stack + (lambda (hi offset) + (lambda (rhs) ; requires var + (%seq + (set! ,hi ,(%mref ,rhs 0)) + (set! ,(%mref ,%sp ,offset) ,(%mref ,rhs ,4)))))) + (define load-indirect-stack + (lambda (offset size) + (lambda (rhs) ; requires var + (let ([tmp %r16]) + (let loop ([delta 0] [size size]) + (if (fx<= size 0) + `(nop) + (%seq + ,(load/store-integer 'load tmp (fxmin size 4) 'unsigned rhs delta) + ,(load/store-integer 'store tmp (fxmin size 4) 'unsigned %sp (fx+ offset delta)) + ,(loop (fx+ delta 4) (fx- size 4))))))))) + (define load-double-reg+int-regs + (lambda (fpreg hireg loreg isp indirect?) + (if indirect? + (lambda (x) ; requires var + (%seq + (set! ,fpreg ,(%mref ,x ,%zero 0 fp)) + (set! ,loreg ,(%mref ,x ,4)) + (set! ,hireg ,(%mref ,x ,0)))) + (lambda (x) ; unboxed + (%seq + (set! ,fpreg ,x) + (set! ,(%mref ,%sp ,%zero ,isp fp) ,x) + (set! ,loreg ,(%mref ,%sp ,(fx+ isp 4))) + (set! ,hireg ,(%mref ,%sp ,isp))))))) + (define load-single-reg+int-regs + (lambda (fpreg hireg loreg isp indirect?) + (if indirect? + (lambda (x) ; requires var + (%seq + (set! ,fpreg ,(%inline load-single->double ,(%mref ,x ,%zero 0 fp))) + (set! ,(%mref ,%sp ,%zero ,isp fp) ,fpreg) + (set! ,loreg ,(%mref ,%sp ,(fx+ isp 4))) + (set! ,hireg ,(%mref ,%sp ,isp)))) + (load-double-reg+int-regs fpreg hireg loreg isp indirect?)))) + (define load-double-reg+stack + (lambda (fpreg isp indirect?) + (if indirect? + (lambda (x) ; requires var + (%seq + (set! ,fpreg ,(%mref ,x ,%zero 0 fp)) + (set! ,(%mref ,%sp ,%zero ,isp fp) ,fpreg))) + (lambda (x) ; unboxed + (%seq + (set! ,fpreg ,x) + (set! ,(%mref ,%sp ,%zero ,isp fp) ,fpreg)))))) + (define load-double-reg+int-reg+stack + (lambda (fpreg hireg isp indirect?) + (if indirect? + (lambda (x) ; requires var + (%seq + (set! ,fpreg ,(%mref ,x ,%zero 0 fp)) + (set! ,(%mref ,%sp ,(fx+ isp 4)) ,(%mref ,x 4)) + (set! ,hireg ,(%mref ,x 0)))) + (lambda (x) ; unboxed + (%seq + (set! ,fpreg ,x) + (set! ,(%mref ,%sp ,%zero ,isp fp) ,x) + (set! ,hireg ,(%mref ,%sp ,isp))))))) + (constant-case machine-type-name + [(ppc32osx tppc32osx) + ;; Mac OS X variant of `do-args` + ;; ----------------------------- + ;; On varargs: we can pass arguments in a way that works in both + ;; varargs mode and non-varargs mode, so we do that unless a specific + ;; 'atomic mode is used (for primitve flonum operations) to insists on + ;; a more efficient path + (define register+stack-arguments-starting-offset + ;; after linkage area: + 24) + (define stack-arguments-starting-offset + ;; after inkage area plus parameter area reserved for registers: + (+ register+stack-arguments-starting-offset 32)) + (define (maybe-cdr p) (if (pair? p) (cdr p) p)) + (define (rest-in-fp-regs? types flt* int*) + (cond + [(null? types) #t] + [(or (null? flt*) (null? int*) (null? (cdr int*))) #f] + [else (nanopass-case (Ltype Type) (car types) + [(fp-double-float) (rest-in-fp-regs? (cdr types) (cdr flt*) (cddr int*))] + [(fp-single-float) (rest-in-fp-regs? (cdr types) (cdr flt*) (cddr int*))] + [else #f])])) + (define do-args + (lambda (types varargs?) + ;; NB: start stack pointer at `stack-arguments-starting-offset` to put arguments above the linkage area + (let loop ([types types] [locs '()] [live* '()] [int* (gp-parameter-regs)] [flt* (fp-parameter-regs)] + [isp register+stack-arguments-starting-offset] + ;; needed when adjusting active: + [fp-live-count 0] + ;; configured for `ftd-fp&` unpacking: + [indirect? #f]) + (if (null? types) + (values (fxmax isp stack-arguments-starting-offset) locs live* fp-live-count) + (nanopass-case (Ltype Type) (car types) + [(fp-double-float) + (cond + [(null? flt*) + ;; on stack + (loop (cdr types) + (cons (load-double-stack isp (and indirect? 0)) locs) + live* int* '() (fx+ isp 8) fp-live-count + #f)] + [(not varargs?) + ;; in FP register + (loop (cdr types) + (cons (load-double-reg (car flt*) (and indirect? 0)) locs) + live* (maybe-cdr (maybe-cdr int*)) (cdr flt*) (fx+ isp 8) (fx+ fp-live-count 1) + #f)] + [else ; => varargs + ;; in FP registers but also in integer register or on stack... maybe only halfway + (cond + [(null? int*) + (loop (cdr types) + (cons (load-double-reg+stack (car flt*) isp indirect?) locs) + live* '() (cdr flt*) (fx+ isp 8) (fx+ fp-live-count 1) + #f)] + [(null? (cdr int*)) + (loop (cdr types) + (cons (load-double-reg+int-reg+stack (car flt*) (car int*) isp indirect?) locs) + (cons (car int*) live*) '() (cdr flt*) (fx+ isp 8) (fx+ fp-live-count 1) + #f)] + [else + (loop (cdr types) + (cons (load-double-reg+int-regs (car flt*) (car int*) (cadr int*) isp indirect?) locs) + (cons* (car int*) (cadr int*) live*) (cdr (cdr int*)) (cdr flt*) (fx+ isp 8) (fx+ fp-live-count 1) + #f)])])] + [(fp-single-float) + (cond + [(null? flt*) + ;; on stack + (loop (cdr types) + (cons (load-single-stack isp (and indirect? 0)) locs) + live* int* '() (fx+ isp 4) fp-live-count + #f)] + [(or (not varargs?) + (null? int*) + (null? (cdr int*)) + (not (rest-in-fp-regs? (cdr types) (cdr flt*) (cddr int*)))) + ;; in FP register + (loop (cdr types) + (cons (load-single-reg (car flt*) (and indirect? 0)) locs) + live* (maybe-cdr int*) (cdr flt*) (fx+ isp 4) (fx+ fp-live-count 1) + #f)] + [else ; => varargs + ;; Although the float type is not normally allowed with `__varargs`, + ;; we might be pessimistically setting up for varargs, treating the + ;; float as a double for varargs; this trick is only going to work as + ;; long as it doesn't matter how many integer registers we use + (loop (cdr types) + (cons (load-single-reg+int-regs (car flt*) (car int*) (cadr int*) isp indirect?) locs) + (cons* (car int*) (cadr int*) live*) (cdr (cdr int*)) (cdr flt*) (fx+ isp 8) (fx+ fp-live-count 1) + #f)])] + [(fp-ftd& ,ftd) + (let ([members ($ftd->members ftd)]) + (cond + [(or (not (and (pair? members) + (null? (cdr members)))) + ;; floating-point in a union is passed in integer registers: + (and ($ftd-union? ftd) + (eq? 'float (caar members)))) + ;; compound: use integer registers until we run out; + ;; for simplicity, just put the whole argument (not just + ;; the part after registers) on the stack, too, which + ;; handles things like sizes not divisible by 4 or unions + (let c-loop ([size ($ftd-size ftd)] + [offset 0] + [int* int*] + [live* live*] + [loc (load-indirect-stack isp ($ftd-size ftd))]) + (cond + [(or (fx<= size 0) (null? int*)) + (loop (cdr types) + (cons loc locs) + live* int* flt* (fx+ isp (align 4 ($ftd-size ftd))) fp-live-count + #f)] + [else + (let ([reg-loc (load-indirect-int-reg (car int*) (fxmin size 4) 'integer offset)]) + (c-loop (fx- size 4) + (fx+ offset 4) + (cdr int*) + (cons (car int*) live*) + (lambda (rhs) (%seq ,(reg-loc rhs) ,(loc rhs)))))]))] + [else + ;; single element, so treat as non-compound, including + ;; using floating-point registers, piggy-backing on unboxed handler + (let* ([category (caar members)] + [size (cadar members)] + [unpacked-type (with-output-language (Ltype Type) + (cond + [(eq? category 'float) + (case size + [(4) `(fp-single-float)] + [else `(fp-double-float)])] + [(eq? category 'integer) + `(fp-integer ,(fx* 8 size))] + [else + `(fp-unsigned ,(fx* 8 size))]))]) + (loop (cons unpacked-type (cdr types)) locs live* int* flt* isp fp-live-count + ;; indirect? + #t))]))] + [else + (if (nanopass-case (Ltype Type) (car types) + [(fp-integer ,bits) (fx= bits 64)] + [(fp-unsigned ,bits) (fx= bits 64)] + [else #f]) + ;; 8-byte value + (cond + [(null? int*) (loop (cdr types) - (cons (load-single-stack isp fp-disp) locs) - live* int* '() (fx+ isp 4) fp-live-count - #f)) - (loop (cdr types) - (cons (load-single-reg (car flt*) fp-disp) locs) - live* int* (cdr flt*) isp (fx+ fp-live-count 1) - #f)))] - [(fp-ftd& ,ftd) - (cond - [($ftd-compound? ftd) - ;; pass as pointer - (let ([pointer-type (with-output-language (Ltype Type) `(fp-integer 32))]) - (loop (cons pointer-type (cdr types)) locs live* int* flt* isp fp-live-count - #f))] - [else - ;; extract content and pass that content - (let ([category ($ftd-atomic-category ftd)]) - (cond - [(eq? category 'float) - ;; piggy-back on unboxed handler - (let ([unpacked-type (with-output-language (Ltype Type) - (case ($ftd-size ftd) - [(4) `(fp-single-float)] - [else `(fp-double-float)]))]) - (loop (cons unpacked-type (cdr types)) locs live* int* flt* isp fp-live-count - ;; no floating displacement within pointer: - 0))] - [(and (memq category '(integer unsigned)) - (fx= 8 ($ftd-size ftd))) - (let ([int* (if (even? (length int*)) int* (cdr int*))]) - (if (null? int*) - (let ([isp (align 8 isp)]) - (loop (cdr types) - (cons (load-indirect-int64-stack isp) locs) - live* '() flt* (fx+ isp 8) fp-live-count - #f)) + (cons (if indirect? + (load-indirect-int64-stack isp) + (load-int64-stack isp)) + locs) + live* '() flt* (fx+ isp 8) fp-live-count + #f)] + [(null? (cdr int*)) (loop (cdr types) - (cons (load-indirect-int64-reg (cadr int*) (car int*)) locs) - (cons* (car int*) (cadr int*) live*) (cddr int*) flt* isp fp-live-count - #f)))] - [else - (if (null? int*) - (loop (cdr types) - (cons (load-indirect-int-stack isp ($ftd-size ftd)) locs) - live* '() flt* (fx+ isp 4) fp-live-count - #f) - (loop (cdr types) - (cons (load-indirect-int-reg (car int*) ($ftd-size ftd) category) locs) - (cons (car int*) live*) (cdr int*) flt* isp fp-live-count - #f))]))])] - [else - (if (nanopass-case (Ltype Type) (car types) - [(fp-integer ,bits) (fx= bits 64)] - [(fp-unsigned ,bits) (fx= bits 64)] - [else #f]) - (let ([int* (if (even? (length int*)) int* (cdr int*))]) - (if (null? int*) - (let ([isp (align 8 isp)]) - (loop (cdr types) - (cons (load-int64-stack isp) locs) - live* '() flt* (fx+ isp 8) fp-live-count - #f)) + (cons (if indirect? + (load-indirect-int64-reg+stack (car int*) (fx+ isp 4)) + (load-int64-reg+stack (car int*) (fx+ isp 4))) + locs) + (cons (car int*) live*) (cdr int*) flt* (fx+ isp 8) fp-live-count + #f)] + [else (loop (cdr types) - (cons (load-int64-reg (cadr int*) (car int*)) locs) - (cons* (car int*) (cadr int*) live*) (cddr int*) flt* isp fp-live-count - #f))) - (if (null? int*) - (loop (cdr types) - (cons (load-int-stack isp) locs) - live* '() flt* (fx+ isp 4) fp-live-count - #f) - (loop (cdr types) - (cons (load-int-reg (car int*)) locs) - (cons (car int*) live*) (cdr int*) flt* isp fp-live-count - #f)))]))))) + (cons (if indirect? + (load-indirect-int64-reg (cadr int*) (car int*)) + (load-int64-reg (cadr int*) (car int*))) + locs) + (cons* (car int*) (cadr int*) live*) (cddr int*) flt* (fx+ isp 8) fp-live-count + #f)]) + ;; 4-byte (or smaller) value + (let-values ([(size category) (nanopass-case (Ltype Type) (car types) + [(fp-integer ,bits) (values (fxsra bits 3) 'integer)] + [(fp-unsigned ,bits) (values (fxsra bits 3) 'unsigned)] + [else (values 4 'unsigned)])]) + (if (null? int*) + (loop (cdr types) + (cons (if indirect? + (load-indirect-int-stack isp size) + (load-int-stack isp)) + locs) + live* '() flt* (fx+ isp 4) fp-live-count + #f) + (loop (cdr types) + (cons (if indirect? + (load-indirect-int-reg (car int*) size category 0) + (load-int-reg (car int*))) + locs) + (cons (car int*) live*) (cdr int*) flt* (fx+ isp 4) fp-live-count + #f))))])))))] + [else + ;; Linux variant of `do-args` + ;; -------------------------- + (define stack-arguments-starting-offset 8) + (define do-args + (lambda (types varargs?) + ;; NB: start stack pointer at `stack-arguments-starting-offset` to put arguments above the linkage area + (let loop ([types types] [locs '()] [live* '()] [int* (gp-parameter-regs)] [flt* (fp-parameter-regs)] [isp stack-arguments-starting-offset] + ;; needed when adjusting active: + [fp-live-count 0] + ;; configured for `ftd-fp&` unpacking of floats: + [fp-disp #f]) + (if (null? types) + (values isp locs live* fp-live-count) + (nanopass-case (Ltype Type) (car types) + [(fp-double-float) + (if (constant software-floating-point) + (let ([int* (if (even? (length int*)) int* (cdr int*))]) + (if (null? int*) + (let ([isp (align 8 isp)]) + (loop (cdr types) + (cons (load-double-stack isp fp-disp) locs) + live* '() flt* (fx+ isp 8) fp-live-count + #f)) + (loop (cdr types) + (cons (load-soft-double-reg (cadr int*) (car int*) fp-disp) locs) + (cons* (car int*) (cadr int*) live*) (cddr int*) flt* isp fp-live-count + #f))) + (if (null? flt*) + (let ([isp (align 8 isp)]) + (loop (cdr types) + (cons (load-double-stack isp fp-disp) locs) + live* int* '() (fx+ isp 8) fp-live-count + #f)) + (loop (cdr types) + (cons (load-double-reg (car flt*) fp-disp) locs) + live* int* (cdr flt*) isp (fx+ fp-live-count 1) + #f)))] + [(fp-single-float) + (if (constant software-floating-point) + (if (null? int*) + ; NB: ABI says singles are passed as doubles on the stack, but gcc/linux doesn't + (loop (cdr types) + (cons (load-single-stack isp fp-disp) locs) + live* '() flt* (fx+ isp 4) fp-live-count + #f) + (loop (cdr types) + (cons (load-soft-single-reg (car int*) fp-disp) locs) + (cons (car int*) live*) (cdr int*) flt* isp fp-live-count + #f)) + (if (null? flt*) + ; NB: ABI says singles are passed as doubles on the stack, but gcc/linux doesn't + (let ([isp (align 4 isp)]) + (loop (cdr types) + (cons (load-single-stack isp fp-disp) locs) + live* int* '() (fx+ isp 4) fp-live-count + #f)) + (loop (cdr types) + (cons (load-single-reg (car flt*) fp-disp) locs) + live* int* (cdr flt*) isp (fx+ fp-live-count 1) + #f)))] + [(fp-ftd& ,ftd) + (cond + [($ftd-compound? ftd) + ;; pass as pointer + (let ([pointer-type (with-output-language (Ltype Type) `(fp-integer 32))]) + (loop (cons pointer-type (cdr types)) locs live* int* flt* isp fp-live-count + #f))] + [else + ;; extract content and pass that content + (let ([category ($ftd-atomic-category ftd)]) + (cond + [(eq? category 'float) + ;; piggy-back on unboxed handler + (let ([unpacked-type (with-output-language (Ltype Type) + (case ($ftd-size ftd) + [(4) `(fp-single-float)] + [else `(fp-double-float)]))]) + (loop (cons unpacked-type (cdr types)) locs live* int* flt* isp fp-live-count + ;; no floating displacement within pointer: + 0))] + [(and (memq category '(integer unsigned)) + (fx= 8 ($ftd-size ftd))) + (let ([int* (if (even? (length int*)) int* (cdr int*))]) + (if (null? int*) + (let ([isp (align 8 isp)]) + (loop (cdr types) + (cons (load-indirect-int64-stack isp) locs) + live* '() flt* (fx+ isp 8) fp-live-count + #f)) + (loop (cdr types) + (cons (load-indirect-int64-reg (cadr int*) (car int*)) locs) + (cons* (car int*) (cadr int*) live*) (cddr int*) flt* isp fp-live-count + #f)))] + [else + (if (null? int*) + (loop (cdr types) + (cons (load-indirect-int-stack isp ($ftd-size ftd)) locs) + live* '() flt* (fx+ isp 4) fp-live-count + #f) + (loop (cdr types) + (cons (load-indirect-int-reg (car int*) ($ftd-size ftd) category 0) locs) + (cons (car int*) live*) (cdr int*) flt* isp fp-live-count + #f))]))])] + [else + (if (nanopass-case (Ltype Type) (car types) + [(fp-integer ,bits) (fx= bits 64)] + [(fp-unsigned ,bits) (fx= bits 64)] + [else #f]) + (let ([int* (if (even? (length int*)) int* (cdr int*))]) + (if (null? int*) + (let ([isp (align 8 isp)]) + (loop (cdr types) + (cons (load-int64-stack isp) locs) + live* '() flt* (fx+ isp 8) fp-live-count + #f)) + (loop (cdr types) + (cons (load-int64-reg (cadr int*) (car int*)) locs) + (cons* (car int*) (cadr int*) live*) (cddr int*) flt* isp fp-live-count + #f))) + (if (null? int*) + (loop (cdr types) + (cons (load-int-stack isp) locs) + live* '() flt* (fx+ isp 4) fp-live-count + #f) + (loop (cdr types) + (cons (load-int-reg (car int*)) locs) + (cons (car int*) live*) (cdr int*) flt* isp fp-live-count + #f)))])))))]) (define do-indirect-result-from-registers (lambda (ftd offset) (let ([tmp %Carg8]) @@ -2429,11 +2734,13 @@ ,(save-and-restore result-live* result-fp-live-count (fp-result-regs) `(set! ,%Cretval ,(%inline activate-thread)))))) (lambda (info) (safe-assert (reg-callee-save? %tc)) ; no need to save-restore - (let* ([arg-type* (info-foreign-arg-type* info)] + (let* ([varargs? (not (memq 'atomic (info-foreign-conv* info)))] ; pessimistic for Mac OS + [arg-type* (info-foreign-arg-type* info)] [result-type (info-foreign-result-type info)] [fill-result-here? (indirect-result-that-fits-in-registers? result-type)] [adjust-active? (if-feature pthreads (memq 'adjust-active (info-foreign-conv* info)) #f)]) - (with-values (do-args (if fill-result-here? (cdr arg-type*) arg-type*)) + (with-values (do-args (if fill-result-here? (cdr arg-type*) (indirect-result-to-pointer result-type arg-type*)) + varargs?) (lambda (orig-frame-size locs live* fp-live-count) ;; NB: add 4 to frame size for CR save word (let* ([fill-stash-offset orig-frame-size] @@ -2557,7 +2864,9 @@ +---------------------------+ | | | parameter list | 0-? words (g's stack arguments from f) - sp+n+8: | | + sp+n+{8,24}: | | Mac OS: starts with space for copy of registers + +---------------------------+ + sp+n+8: | Mac OS: +16 bytes linkage | +---------------------------+ | | | lr | 1 word (place for g to store lr) @@ -2586,7 +2895,9 @@ +---------------------------+ | | | | | parameter list | 0-? words (h's stack arguments from g) | - sp+8: | | | + sp+{8,24}: | | | + +---------------------------+ | + sp+8: | Mac OS: +16 bytes linkage | +---------------------------+ | | | | | lr | 1 word (place for h to store lr) | @@ -2609,6 +2920,9 @@ PPC foreign-callable Frame Layout sp+188: +---------------------------+ + | args passed to callback | + | on stack | + +---------------------------+ | | | lr | 1 word sp+X+4: | | @@ -2636,6 +2950,10 @@ | | | integer argument regs | Also used to stash results during unactivate | | + sp+{8,56}: +---------------------------+ <- 8-byte aligned + | | + | Mac OS: +16 bytes linkage | Space expected by further C callees, like get-tc + | +32 arg registers | sp+8: +---------------------------+ <- 8-byte aligned | | | lr | 1 word (place for get-thread-context to store lr) @@ -2700,6 +3018,18 @@ (%seq (set! ,lolvalue ,(%mref ,%sp ,(fx+ offset 4))) (set! ,hilvalue ,(%mref ,%sp ,offset)))))) + (define load-split-int64-stack + (lambda (hioffset looffset) + (lambda (lolvalue hilvalue) + (%seq + (set! ,lolvalue ,(%mref ,%sp ,looffset)) + (set! ,hilvalue ,(%mref ,%sp ,hioffset)))))) + (define load-split-double-stack + (lambda (hioffset looffset) + (lambda (x) ; requires var + (%seq + (set! ,(%mref ,x ,(constant flonum-data-disp)) ,(%mref ,%sp ,hioffset)) + (set! ,(%mref ,x ,(fx+ (constant flonum-data-disp) 4)) ,(%mref ,%sp ,looffset)))))) (define load-stack-address (lambda (offset) (lambda (lvalue) @@ -2713,154 +3043,362 @@ (set! ,%fptmp1 ,(%mref ,%sp ,%zero ,offset fp)) ,(%inline store-double->single ,(%mref ,%sp ,%zero ,offset fp) ,%fptmp1) (set! ,lvalue ,(%inline + ,%sp (immediate ,offset))))))) - (define count-reg-args - (lambda (types gp-reg-count fp-reg-count synthesize-first-argument?) - (let f ([types types] [iint (if synthesize-first-argument? -1 0)] [iflt 0]) - (if (null? types) - (values iint iflt) - (cond - [(and (not (constant software-floating-point)) - (nanopass-case (Ltype Type) (car types) - [(fp-double-float) #t] - [(fp-single-float) #t] - [(fp-ftd& ,ftd) (eq? 'float ($ftd-atomic-category ftd))] - [else #f])) - (f (cdr types) iint (if (fx< iflt fp-reg-count) (fx+ iflt 1) iflt))] - [(or (nanopass-case (Ltype Type) (car types) - [(fp-integer ,bits) (fx= bits 64)] - [(fp-unsigned ,bits) (fx= bits 64)] - [(fp-ftd& ,ftd) (and (not ($ftd-compound? ftd)) - (fx= 8 ($ftd-size ftd)))] - [else #f]) - (and (constant software-floating-point) - (nanopass-case (Ltype Type) (car types) - [(fp-double-float) #t] - [else #f]))) - (let ([iint (align 2 iint)]) - (f (cdr types) (if (fx< iint gp-reg-count) (fx+ iint 2) iint) iflt))] - [else (f (cdr types) (if (fx< iint gp-reg-count) (fx+ iint 1) iint) iflt)]))))) - (define do-stack - ; all of the args are on the stack at this point, though not contiguous since - ; we push all of the int reg args with one push instruction and all of the - ; float reg args with another (v)push instruction - (lambda (types gp-reg-count fp-reg-count int-reg-offset float-reg-offset stack-arg-offset - synthesize-first-argument? return-space-offset) - (let loop ([types (if synthesize-first-argument? (cdr types) types)] - [locs '()] - [iint 0] - [iflt 0] - [int-reg-offset int-reg-offset] - [float-reg-offset float-reg-offset] - [stack-arg-offset stack-arg-offset]) - (if (null? types) - (let ([locs (reverse locs)]) - (if synthesize-first-argument? - (cons (load-stack-address return-space-offset) - locs) - locs)) - (cond - [(and (not (constant software-floating-point)) - (nanopass-case (Ltype Type) (car types) - [(fp-double-float) #t] - [(fp-single-float) #t] - [else #f])) - (if (fx< iflt fp-reg-count) - (loop (cdr types) - (cons (load-double-stack float-reg-offset) locs) - iint (fx+ iflt 1) int-reg-offset (fx+ float-reg-offset 8) stack-arg-offset) - (let ([stack-arg-offset (align 8 stack-arg-offset)]) - (loop (cdr types) - (cons (load-double-stack stack-arg-offset) locs) - iint iflt int-reg-offset float-reg-offset (fx+ stack-arg-offset 8))))] - [(and (constant software-floating-point) - (nanopass-case (Ltype Type) (car types) - [(fp-double-float) #t] - [else #f])) - (let ([iint (align 2 iint)]) - (if (fx< iint gp-reg-count) - (let ([int-reg-offset (align 8 int-reg-offset)]) - (loop (cdr types) - (cons (load-double-stack int-reg-offset) locs) - (fx+ iint 2) iflt (fx+ int-reg-offset 8) float-reg-offset stack-arg-offset)) - (let ([stack-arg-offset (align 8 stack-arg-offset)]) + (constant-case machine-type-name + [(ppc32osx tppc32osx) + (define register+stack-arguments-starting-offset + ;; after linkage area: + 24) + (define stack-arguments-starting-offset + ;; after inkage area plus parameter area reserved for registers: + (+ register+stack-arguments-starting-offset 32)) + ;; Mac OS X variant of `do-stack` + ;; ----------------------------- + (define do-stack + ;; All of the args are on the stack at this point, though not contiguous since + ;; we push all of the int reg args with one push instruction and all of the + ;; float reg args with another (v)push instruction. It's possible for an argument + ;; to be split across a register and the stack --- but in that case, there's + ;; room just before on the stack to copy in the register. + (lambda (types gp-reg-count fp-reg-count init-int-reg-offset float-reg-offset stack-arg-offset + synthesize-first-argument? varargs-after return-space-offset) + (let loop ([types (if synthesize-first-argument? (cdr types) types)] + [locs '()] + [iint 0] + [iflt 0] + [int-reg-offset init-int-reg-offset] + [float-reg-offset float-reg-offset] + [stack-arg-offset (fx- stack-arg-offset (fx- stack-arguments-starting-offset + register+stack-arguments-starting-offset))] + [varargs-after varargs-after]) + (let ([next-varargs-after (and varargs-after (if (fx> varargs-after 0) (fx- varargs-after 1) 0))]) + (if (null? types) + (let ([locs (reverse locs)]) + (if synthesize-first-argument? + (cons (load-stack-address return-space-offset) + locs) + locs)) + (cond + [(nanopass-case (Ltype Type) (car types) + [(fp-double-float) 2] + [(fp-single-float) 1] + [else #f]) + => (lambda (width) + (let ([size (fx* width 4)]) + (cond + [(and (fx< iflt fp-reg-count) + (not (eq? varargs-after 0))) + ;; in FP register + (loop (cdr types) + (cons (load-double-stack float-reg-offset) locs) + (fx+ iint width) (fx+ iflt 1) (fx+ int-reg-offset size) (fx+ float-reg-offset size) + (fx+ stack-arg-offset size) + next-varargs-after)] + [(or (not (eq? varargs-after 0)) + (fx>= iint gp-reg-count)) + ;; on stack + (loop (cdr types) + (cons (load-double-stack stack-arg-offset) locs) + iint iflt int-reg-offset float-reg-offset + (fx+ stack-arg-offset size) + next-varargs-after)] + [else ;; => varargs + ;; in integer register --- but maybe halfway on stack + (loop (cdr types) + (cons (if (fx< (fx+ iint 1) gp-reg-count) + (load-double-stack int-reg-offset) + (load-split-double-stack int-reg-offset (fx+ stack-arg-offset 4))) + locs) + (fx+ iint width) iflt (fx+ int-reg-offset size) float-reg-offset + (fx+ stack-arg-offset size) + next-varargs-after)])))] + [(nanopass-case (Ltype Type) (car types) + [(fp-ftd& ,ftd) ftd] + [else #f]) + => + (lambda (ftd) + (let ([members ($ftd->members ftd)]) + (cond + [(and (not ($ftd-union? ftd)) + (pair? members) + (null? (cdr members)) + (eq? 'float (caar members)) + (fx< iflt fp-reg-count)) + ;; single member as float => in register + (let ([load-address (case ($ftd-size ftd) + [(4) load-stack-address/convert-float] + [else load-stack-address])] + [size ($ftd-size ftd)]) + (loop (cdr types) + (cons (load-address float-reg-offset) locs) + (fx+ iint (fxsrl size 2)) (fx+ iflt 1) (fx+ int-reg-offset size) (fx+ float-reg-offset 8) + (fx+ stack-arg-offset size) + next-varargs-after))] + [(memv ($ftd-size ftd) '(1 2)) + ;; byte or word; need to load address into middle + (loop (cdr types) + (cons (load-stack-address (fx+ (fx- 4 ($ftd-size ftd)) + (if (< iint gp-reg-count) + int-reg-offset + stack-arg-offset))) + locs) + (fx+ iint 1) iflt (fx+ int-reg-offset 4) float-reg-offset + (fx+ stack-arg-offset 4) + next-varargs-after)] + [else + ;; in registers until they run out; copy the registers + ;; to the reserved space just before arguments that + ;; are only on the stack, and then we have a contiguous + ;; object on the stack; except that sizes not a multiple + ;; of 4 are always on the stack and no copying is needed + (let* ([size ($ftd-size ftd)] + [words (fxsrl (align 4 size) 2)] + [loc + (cond + [(not (fx= size (fx* words 4))) + (load-stack-address stack-arg-offset)] + [else + (let c-loop ([size size] [iint iint] [offset 0]) + (cond + [(or (fx<= size 0) + (fx>= iint gp-reg-count)) + (load-stack-address stack-arg-offset)] + [else + (let ([loc (c-loop (fx- size 4) (fx+ iint 1) (fx+ offset 4))] + [tmp %Carg8]) + (lambda (lvalue) + (%seq + (set! ,tmp ,(%mref ,%sp ,(fx+ int-reg-offset offset))) + (set! ,(%mref ,%sp ,(fx+ stack-arg-offset offset)) ,tmp) + ,(loc lvalue))))]))])]) + (loop (cdr types) + (cons loc locs) + (fx+ iint words) iflt (fx+ int-reg-offset (fx* 4 words)) float-reg-offset + (fx+ stack-arg-offset (fx* 4 words)) + next-varargs-after))])))] + [(nanopass-case (Ltype Type) (car types) + [(fp-integer ,bits) (fx= bits 64)] + [(fp-unsigned ,bits) (fx= bits 64)] + [else #f]) + (cond + [(fx< (fx+ iint 1) gp-reg-count) (loop (cdr types) - (cons (load-double-stack stack-arg-offset) locs) - iint iflt int-reg-offset float-reg-offset (fx+ stack-arg-offset 8)))))] - [(and (constant software-floating-point) - (nanopass-case (Ltype Type) (car types) - [(fp-single-float) #t] - [else #f])) - (if (fx< iint gp-reg-count) - (loop (cdr types) - (cons (load-soft-single-stack int-reg-offset) locs) - (fx+ iint 1) iflt (fx+ int-reg-offset 4) float-reg-offset stack-arg-offset) - (loop (cdr types) - (cons (load-soft-single-stack stack-arg-offset) locs) - iint iflt int-reg-offset float-reg-offset (fx+ stack-arg-offset 4)))] - [(nanopass-case (Ltype Type) (car types) - [(fp-ftd& ,ftd) (not ($ftd-compound? ftd))] - [else #f]) - ;; load pointer to address on the stack - (let ([ftd (nanopass-case (Ltype Type) (car types) - [(fp-ftd& ,ftd) ftd])]) - (case (and (not (constant software-floating-point)) - ($ftd-atomic-category ftd)) - [(float) - (let ([load-address (case ($ftd-size ftd) - [(4) load-stack-address/convert-float] - [else load-stack-address])]) - (if (fx< iflt fp-reg-count) - (loop (cdr types) - (cons (load-address float-reg-offset) locs) - iint (fx+ iflt 1) int-reg-offset (fx+ float-reg-offset 8) stack-arg-offset) - (let ([stack-arg-offset (align 8 stack-arg-offset)]) - (loop (cdr types) - (cons (load-address stack-arg-offset) locs) - iint iflt int-reg-offset float-reg-offset (fx+ stack-arg-offset 8)))))] - [else - (case ($ftd-size ftd) - [(8) - (let ([iint (align 2 iint)]) - (if (fx< iint gp-reg-count) - (let ([int-reg-offset (align 8 int-reg-offset)]) - (loop (cdr types) - (cons (load-stack-address int-reg-offset) locs) - (fx+ iint 2) iflt (fx+ int-reg-offset 8) float-reg-offset stack-arg-offset)) - (let ([stack-arg-offset (align 8 stack-arg-offset)]) - (loop (cdr types) - (cons (load-stack-address stack-arg-offset) locs) - iint iflt int-reg-offset float-reg-offset (fx+ stack-arg-offset 8)))))] - [else - (let ([byte-offset (- 4 ($ftd-size ftd))]) - (if (fx< iint gp-reg-count) - (loop (cdr types) - (cons (load-stack-address (+ int-reg-offset byte-offset)) locs) - (fx+ iint 1) iflt (fx+ int-reg-offset 4) float-reg-offset stack-arg-offset) - (loop (cdr types) - (cons (load-stack-address (+ stack-arg-offset byte-offset)) locs) - iint iflt int-reg-offset float-reg-offset (fx+ stack-arg-offset 4))))])]))] - [(nanopass-case (Ltype Type) (car types) - [(fp-integer ,bits) (fx= bits 64)] - [(fp-unsigned ,bits) (fx= bits 64)] - [else #f]) - (let ([iint (align 2 iint)]) - (if (fx< iint gp-reg-count) - (let ([int-reg-offset (align 8 int-reg-offset)]) + (cons (load-int64-stack int-reg-offset) locs) + (fx+ iint 2) iflt (fx+ int-reg-offset 8) float-reg-offset (fx+ stack-arg-offset 8) + next-varargs-after)] + [(fx< iint gp-reg-count) + ;; split across a register and the stack (loop (cdr types) - (cons (load-int64-stack int-reg-offset) locs) - (fx+ iint 2) iflt (fx+ int-reg-offset 8) float-reg-offset stack-arg-offset)) - (let ([stack-arg-offset (align 8 stack-arg-offset)]) + (cons (load-split-int64-stack int-reg-offset stack-arg-offset) locs) + (fx+ iint 1) iflt (fx+ int-reg-offset 4) float-reg-offset (fx+ stack-arg-offset 8) + next-varargs-after)] + [else (loop (cdr types) - (cons (load-int64-stack stack-arg-offset) locs) - iint iflt int-reg-offset float-reg-offset (fx+ stack-arg-offset 8)))))] - [else - (if (fx< iint gp-reg-count) - (loop (cdr types) - (cons (load-int-stack (car types) int-reg-offset) locs) - (fx+ iint 1) iflt (fx+ int-reg-offset 4) float-reg-offset stack-arg-offset) - (loop (cdr types) - (cons (load-int-stack (car types) stack-arg-offset) locs) - iint iflt int-reg-offset float-reg-offset (fx+ stack-arg-offset 4)))]))))) + (cons (load-int64-stack stack-arg-offset) locs) + iint iflt int-reg-offset float-reg-offset (fx+ stack-arg-offset 8) + next-varargs-after)])] + [else + (if (fx< iint gp-reg-count) + (loop (cdr types) + (cons (load-int-stack (car types) int-reg-offset) locs) + (fx+ iint 1) iflt (fx+ int-reg-offset 4) float-reg-offset (fx+ stack-arg-offset 4) + next-varargs-after) + (loop (cdr types) + (cons (load-int-stack (car types) stack-arg-offset) locs) + iint iflt int-reg-offset float-reg-offset (fx+ stack-arg-offset 4) + next-varargs-after))])))))) + (define count-reg-args + (lambda (types gp-reg-count fp-reg-count synthesize-first-argument?) + (let f ([types types] [iint (if synthesize-first-argument? -1 0)] [iflt 0]) + (if (null? types) + (values iint iflt) + (nanopass-case (Ltype Type) (car types) + [(fp-double-float) + (f (cdr types) + (fxmin gp-reg-count (fx+ iint 2)) + (fxmin fp-reg-count (fx+ iflt 1)))] + [(fp-single-float) + (f (cdr types) + (fxmin gp-reg-count (fx+ iint 1)) + (fxmin fp-reg-count (fx+ iflt 1)))] + [(fp-ftd& ,ftd) + (let ([words (fxsra (align 4 ($ftd-size ftd)) 2)] + [members ($ftd->members ftd)]) + (cond + [(and (not ($ftd-union? ftd)) + (pair? members) + (null? (cdr members)) + (eq? 'float (caar members))) + (f (cdr types) + (fxmin gp-reg-count (fx+ iint words)) + (fxmin fp-reg-count (fx+ iflt 1)))] + [else + (f (cdr types) + (fxmin gp-reg-count (fx+ iint words)) + iflt)]))] + [(fp-integer ,bits) + (f (cdr types) + (fxmin gp-reg-count (fx+ iint (fxsra (align 8 bits) 3))) + iflt)] + [(fp-unsigned ,bits) + (f (cdr types) + (fxmin gp-reg-count (fx+ iint (fxsra (align 8 bits) 3))) + iflt)] + [else + (f (cdr types) + (fxmin gp-reg-count (fx+ iint 1)) + iflt)])))))] + [else + ;; Linux variant of `do-stack` + ;; ----------------------------- + (define stack-arguments-starting-offset 8) + (define do-stack + ;; all of the args are on the stack at this point, though not contiguous since + ;; we push all of the int reg args with one push instruction and all of the + ;; float reg args with another (v)push instruction + (lambda (types gp-reg-count fp-reg-count int-reg-offset float-reg-offset stack-arg-offset + synthesize-first-argument? varargs-after return-space-offset) + (let loop ([types (if synthesize-first-argument? (cdr types) types)] + [locs '()] + [iint 0] + [iflt 0] + [int-reg-offset int-reg-offset] + [float-reg-offset float-reg-offset] + [stack-arg-offset stack-arg-offset]) + (if (null? types) + (let ([locs (reverse locs)]) + (if synthesize-first-argument? + (cons (load-stack-address return-space-offset) + locs) + locs)) + (cond + [(and (not (constant software-floating-point)) + (nanopass-case (Ltype Type) (car types) + [(fp-double-float) #t] + [(fp-single-float) #t] + [else #f])) + (if (fx< iflt fp-reg-count) + (loop (cdr types) + (cons (load-double-stack float-reg-offset) locs) + iint (fx+ iflt 1) int-reg-offset (fx+ float-reg-offset 8) stack-arg-offset) + (let ([stack-arg-offset (align 8 stack-arg-offset)]) + (loop (cdr types) + (cons (load-double-stack stack-arg-offset) locs) + iint iflt int-reg-offset float-reg-offset (fx+ stack-arg-offset 8))))] + [(and (constant software-floating-point) + (nanopass-case (Ltype Type) (car types) + [(fp-double-float) #t] + [else #f])) + (let ([iint (align 2 iint)]) + (if (fx< iint gp-reg-count) + (let ([int-reg-offset (align 8 int-reg-offset)]) + (loop (cdr types) + (cons (load-double-stack int-reg-offset) locs) + (fx+ iint 2) iflt (fx+ int-reg-offset 8) float-reg-offset stack-arg-offset)) + (let ([stack-arg-offset (align 8 stack-arg-offset)]) + (loop (cdr types) + (cons (load-double-stack stack-arg-offset) locs) + iint iflt int-reg-offset float-reg-offset (fx+ stack-arg-offset 8)))))] + [(and (constant software-floating-point) + (nanopass-case (Ltype Type) (car types) + [(fp-single-float) #t] + [else #f])) + (if (fx< iint gp-reg-count) + (loop (cdr types) + (cons (load-soft-single-stack int-reg-offset) locs) + (fx+ iint 1) iflt (fx+ int-reg-offset 4) float-reg-offset stack-arg-offset) + (loop (cdr types) + (cons (load-soft-single-stack stack-arg-offset) locs) + iint iflt int-reg-offset float-reg-offset (fx+ stack-arg-offset 4)))] + [(nanopass-case (Ltype Type) (car types) + [(fp-ftd& ,ftd) (not ($ftd-compound? ftd))] + [else #f]) + ;; load pointer to address on the stack + (let ([ftd (nanopass-case (Ltype Type) (car types) + [(fp-ftd& ,ftd) ftd])]) + (case (and (not (constant software-floating-point)) + ($ftd-atomic-category ftd)) + [(float) + (let ([load-address (case ($ftd-size ftd) + [(4) load-stack-address/convert-float] + [else load-stack-address])]) + (if (fx< iflt fp-reg-count) + (loop (cdr types) + (cons (load-address float-reg-offset) locs) + iint (fx+ iflt 1) int-reg-offset (fx+ float-reg-offset 8) stack-arg-offset) + (let ([stack-arg-offset (align 8 stack-arg-offset)]) + (loop (cdr types) + (cons (load-address stack-arg-offset) locs) + iint iflt int-reg-offset float-reg-offset (fx+ stack-arg-offset 8)))))] + [else + (case ($ftd-size ftd) + [(8) + (let ([iint (align 2 iint)]) + (if (fx< iint gp-reg-count) + (let ([int-reg-offset (align 8 int-reg-offset)]) + (loop (cdr types) + (cons (load-stack-address int-reg-offset) locs) + (fx+ iint 2) iflt (fx+ int-reg-offset 8) float-reg-offset stack-arg-offset)) + (let ([stack-arg-offset (align 8 stack-arg-offset)]) + (loop (cdr types) + (cons (load-stack-address stack-arg-offset) locs) + iint iflt int-reg-offset float-reg-offset (fx+ stack-arg-offset 8)))))] + [else + (let ([byte-offset (- 4 ($ftd-size ftd))]) + (if (fx< iint gp-reg-count) + (loop (cdr types) + (cons (load-stack-address (+ int-reg-offset byte-offset)) locs) + (fx+ iint 1) iflt (fx+ int-reg-offset 4) float-reg-offset stack-arg-offset) + (loop (cdr types) + (cons (load-stack-address (+ stack-arg-offset byte-offset)) locs) + iint iflt int-reg-offset float-reg-offset (fx+ stack-arg-offset 4))))])]))] + [(nanopass-case (Ltype Type) (car types) + [(fp-integer ,bits) (fx= bits 64)] + [(fp-unsigned ,bits) (fx= bits 64)] + [else #f]) + (let ([iint (align 2 iint)]) + (if (fx< iint gp-reg-count) + (let ([int-reg-offset (align 8 int-reg-offset)]) + (loop (cdr types) + (cons (load-int64-stack int-reg-offset) locs) + (fx+ iint 2) iflt (fx+ int-reg-offset 8) float-reg-offset stack-arg-offset)) + (let ([stack-arg-offset (align 8 stack-arg-offset)]) + (loop (cdr types) + (cons (load-int64-stack stack-arg-offset) locs) + iint iflt int-reg-offset float-reg-offset (fx+ stack-arg-offset 8)))))] + [else + (if (fx< iint gp-reg-count) + (loop (cdr types) + (cons (load-int-stack (car types) int-reg-offset) locs) + (fx+ iint 1) iflt (fx+ int-reg-offset 4) float-reg-offset stack-arg-offset) + (loop (cdr types) + (cons (load-int-stack (car types) stack-arg-offset) locs) + iint iflt int-reg-offset float-reg-offset (fx+ stack-arg-offset 4)))]))))) + (define count-reg-args + (lambda (types gp-reg-count fp-reg-count synthesize-first-argument?) + (let f ([types types] [iint (if synthesize-first-argument? -1 0)] [iflt 0]) + (if (null? types) + (values iint iflt) + (cond + [(and (not (constant software-floating-point)) + (nanopass-case (Ltype Type) (car types) + [(fp-double-float) #t] + [(fp-single-float) #t] + [(fp-ftd& ,ftd) (eq? 'float ($ftd-atomic-category ftd))] + [else #f])) + (f (cdr types) iint (if (fx< iflt fp-reg-count) (fx+ iflt 1) iflt))] + [(or (nanopass-case (Ltype Type) (car types) + [(fp-integer ,bits) (fx= bits 64)] + [(fp-unsigned ,bits) (fx= bits 64)] + [(fp-ftd& ,ftd) (and (not ($ftd-compound? ftd)) + (fx= 8 ($ftd-size ftd)))] + [else #f]) + (and (constant software-floating-point) + (nanopass-case (Ltype Type) (car types) + [(fp-double-float) #t] + [else #f]))) + (let ([iint (align 2 iint)]) + (f (cdr types) (if (fx< iint gp-reg-count) (fx+ iint 2) iint) iflt))] + [else (f (cdr types) (if (fx< iint gp-reg-count) (fx+ iint 1) iint) iflt)])))))]) (define save-regs (lambda (regs offset) (if (null? regs) @@ -2891,6 +3429,16 @@ (if (null? regs) inline (%seq ,inline ,(f regs (fx+ offset 4)))))))))) + (define restore-fp-regs + (lambda (regs offset) + (if (null? regs) + `(nop) + (let f ([regs regs] [offset offset]) + (let ([inline `(set! ,(car regs) ,(%mref ,%Csp ,%zero ,offset fp))]) + (let ([regs (cdr regs)]) + (if (null? regs) + inline + (%seq ,inline ,(f regs (fx+ offset 8)))))))))) (define do-result (lambda (result-type return-space-offset int-reg-offset) (nanopass-case (Ltype Type) result-type @@ -2968,23 +3516,28 @@ e)))) (lambda (info) (define callee-save-regs (list %r14 %r15 %r16 %r17 %r18 %r19 %r20 %r21 %r22 %r23 %r24 %r25 %r26 %r27 %r28 %r29 %r30 %r31)) + (define callee-save-fp-regs (list %fpreg1 %fpreg2)) (define isaved (length callee-save-regs)) + (define fpsaved (length callee-save-fp-regs)) (let ([arg-type* (info-foreign-arg-type* info)] [result-type (info-foreign-result-type info)] [gp-reg-count (length (gp-parameter-regs))] [fp-reg-count (length (fp-parameter-regs))]) (let-values ([(iint iflt) (count-reg-args arg-type* gp-reg-count fp-reg-count (indirect-result-that-fits-in-registers? result-type))]) - (let* ([int-reg-offset 8] ; initial offset for calling conventions + (let* ([int-reg-offset stack-arguments-starting-offset] ; leave space for next callee, such as get-tc [float-reg-offset (align 8 (fx+ (fx* gp-reg-count 4) int-reg-offset))] [callee-save-offset (if (constant software-floating-point) float-reg-offset (fx+ (fx* fp-reg-count 8) float-reg-offset))] + [callee-save-fp-offset (fx+ (fx* isaved 4) callee-save-offset)] [synthesize-first-argument? (indirect-result-that-fits-in-registers? result-type)] [adjust-active? (if-feature pthreads (memq 'adjust-active (info-foreign-conv* info)) #f)] - [unactivate-mode-offset (fx+ (fx* isaved 4) callee-save-offset)] + [varargs-after (ormap (lambda (conv) (and (pair? conv) (eq? 'varargs (car conv)) (cdr conv))) + (info-foreign-conv* info))] + [unactivate-mode-offset (fx+ (fx* fpsaved 8) callee-save-fp-offset)] [return-space-offset (align 8 (fx+ unactivate-mode-offset (if adjust-active? 4 0)))] [stack-size (align 16 (fx+ return-space-offset (if synthesize-first-argument? 8 0)))] - [stack-arg-offset (fx+ stack-size 8)]) + [stack-arg-offset (fx+ stack-size stack-arguments-starting-offset)]) (let-values ([(get-result result-regs result-num-fp-regs) (do-result result-type return-space-offset int-reg-offset)]) (values (lambda () @@ -2993,9 +3546,8 @@ ,(%inline store-with-update ,%Csp ,%Csp (immediate ,(fx- stack-size))) ,(save-regs (list-head (gp-parameter-regs) iint) int-reg-offset) ,(save-fp-regs (list-head (fp-parameter-regs) iflt) float-reg-offset) - ; not bothering with callee-save floating point regs right now - ; not bothering with cr, because we don't update nonvolatile fields ,(save-regs callee-save-regs callee-save-offset) + ,(save-fp-regs callee-save-fp-regs callee-save-fp-offset) ,(if-feature pthreads ((lambda (e) (if adjust-active? @@ -3010,8 +3562,9 @@ `(set! ,%tc (literal ,(make-info-literal #f 'entry (lookup-c-entry thread-context) 0)))))) ; list of procedures that marshal arguments from their C stack locations ; to the Scheme argument locations - (do-stack arg-type* gp-reg-count fp-reg-count int-reg-offset float-reg-offset stack-arg-offset - synthesize-first-argument? return-space-offset) + (do-stack (indirect-result-to-pointer result-type arg-type*) + gp-reg-count fp-reg-count int-reg-offset float-reg-offset stack-arg-offset + synthesize-first-argument? varargs-after return-space-offset) get-result (lambda () (in-context Tail @@ -3026,8 +3579,10 @@ (inline ,null-info ,%restore-lr (immediate ,(fx+ stack-size 4))) ; restore the callee save registers ,(restore-regs callee-save-regs callee-save-offset) + ,(restore-fp-regs callee-save-fp-regs callee-save-fp-offset) ; deallocate space for pad & arg reg values (set! ,%Csp ,(%inline + ,%Csp (immediate ,stack-size))) ; done - (asm-c-return ,null-info ,callee-save-regs ... ,result-regs ...))))))))))))))) + (asm-c-return ,null-info ,callee-save-regs ... ,callee-save-fp-regs ... + ,result-regs ... ,(list-head (fp-result-regs) result-num-fp-regs) ...))))))))))))))) ) diff --git a/src/ChezScheme/s/ppc32osx.def b/src/ChezScheme/s/ppc32osx.def new file mode 100644 index 0000000000..a326b247f0 --- /dev/null +++ b/src/ChezScheme/s/ppc32osx.def @@ -0,0 +1,9 @@ +;;; ppc32osx.def + +(define-constant machine-type (constant machine-type-ppc32osx)) +(features iconv expeditor) +(define-constant max-float-alignment 4) +(define-constant max-integer-alignment 4) +(define-constant special-initial-field-alignment? #t) +(include "ppc32.def") +(include "default.def") diff --git a/src/ChezScheme/s/pretty.ss b/src/ChezScheme/s/pretty.ss index 3127334d94..0adcd36541 100644 --- a/src/ChezScheme/s/pretty.ss +++ b/src/ChezScheme/s/pretty.ss @@ -308,6 +308,17 @@ (make-prty `(read-macro ,s x) (+ (string-length s) (prty-len p)) p))))] + [(flvector? x) + (let ([n (flvector-length x)]) + (if (= n 0) + (if (print-vector-length) + (make-prty '() 4 "#0vfl()") + (make-prty '() 3 "#vfl()")) + (let ([p (mk-prty-vector flvector-length flvector-ref x lev len)] + [s (if (print-vector-length) (format "#~dvfl" n) "#vfl")]) + (make-prty `(read-macro ,s x) + (+ (string-length s) (prty-len p)) + p))))] [(bytevector? x) (let ([n (bytevector-length x)]) (if (= n 0) diff --git a/src/ChezScheme/s/primdata.ss b/src/ChezScheme/s/primdata.ss index a1dec8f61d..2c65a56cbf 100644 --- a/src/ChezScheme/s/primdata.ss +++ b/src/ChezScheme/s/primdata.ss @@ -45,7 +45,7 @@ (fx=? [sig [(fixnum fixnum fixnum ...) -> (boolean)]] [flags pure cp02 safeongoodargs]) ; restricted to 2+ arguments (fx>? [sig [(fixnum fixnum fixnum ...) -> (boolean)]] [flags pure cp02 safeongoodargs]) ; restricted to 2+ arguments (fx>=? [sig [(fixnum fixnum fixnum ...) -> (boolean)]] [flags pure cp02 safeongoodargs]) ; restricted to 2+ arguments - (fxzero? [sig [(fixnum) -> (boolean)]] [flags pure cp02 safeongoodargs]) + (fxzero? [sig [(fixnum) -> (boolean)]] [flags pure cp02 safeongoodargs cptypes2]) (fxnegative? [sig [(fixnum) -> (boolean)]] [flags pure cp02 safeongoodargs]) (fxpositive? [sig [(fixnum) -> (boolean)]] [flags pure cp02 safeongoodargs]) (fxeven? [sig [(fixnum) -> (boolean)]] [flags pure cp02 safeongoodargs]) @@ -201,7 +201,7 @@ ((r6rs: =) [sig [(number number number ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs]) ; restricted to 2+ arguments ((r6rs: >) [sig [(real real real ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs]) ; restricted to 2+ arguments ((r6rs: >=) [sig [(real real real ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs]) ; restricted to 2+ arguments - (zero? [sig [(number) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs]) + (zero? [sig [(number) -> (boolean)]] [flags pure mifoldable discard safeongoodargs cptypes2 ieee r5rs]) (positive? [sig [(real) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs]) (negative? [sig [(real) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs]) (odd? [sig [(integer) -> (boolean)]] [flags pure mifoldable discard safeongoodargs ieee r5rs]) @@ -1044,10 +1044,12 @@ ) (define-symbol-flags* ([libraries] [flags keyword]) + ($lambda/lift-barrier [flags]) ($system [flags library-uid]) (add-prefix [flags]) (alias [flags]) (annotation-options [flags]) + (begin-unsafe [flags]) (case [flags]) (constructor [flags]) (critical-section [flags]) @@ -1334,12 +1336,21 @@ (fl<= [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs unboxed-arguments]) ; not restricted to 2+ arguments (fl> [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs unboxed-arguments]) ; not restricted to 2+ arguments (fl>= [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs unboxed-arguments]) ; not restricted to 2+ arguments + (flvector [sig [(flonum ...) -> (flvector)]] [flags alloc cp02 safeongoodargs]) + (flvector->list [sig [(flvector) -> (list)]] [flags alloc safeongoodargs]) + (flvector-copy [sig [(flvector) -> (flvector)]] [flags alloc safeongoodargs]) + (flvector-fill! [sig [(flvector flonum) -> (void)]] [flags true]) + (flvector-length [sig [(flvector) -> (length)]] [flags pure mifoldable discard true safeongoodargs]) + (flvector-ref [sig [(flvector sub-index) -> (flonum)]] [flags mifoldable discard cp02]) + (flvector-set! [sig [(flvector sub-index flonum) -> (void)]] [flags true]) + (flvector? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) (flush-output-port [sig [() (output-port) -> (void)]] [flags true]) ; not restricted to 1 argument (foreign-entry? [sig [(string) -> (boolean)]] [flags discard]) (foreign-entry [sig [(string) -> (uptr)]] [flags discard true]) (foreign-address-name [sig [(uptr/iptr) -> (maybe-string)]] [flags discard]) (foreign-callable-entry-point [sig [(code) -> (uint)]] [flags discard]) (foreign-callable-code-object [sig [(sint) -> (code)]] [flags discard]) + (foreign-alignof [sig [(sub-symbol) -> (fixnum)]] [flags pure true cp02]) (foreign-alloc [sig [(pfixnum) -> (uint)]] [flags discard true]) (foreign-free [sig [(sub-uint) -> (void)]] [flags true]) (foreign-ref [sig [(sub-symbol uptr/iptr uptr/iptr) -> (ptr)]] [flags]) @@ -1356,8 +1367,11 @@ (ftype-pointer-null? [sig [(ftype-pointer) -> (boolean)]] [flags pure mifoldable discard]) (ftype-pointer->sexpr [sig [(ftype-pointer) -> (ptr)]] [flags]) (fx* [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder]) ; not restricted to 2 arguments + (fx*/wraparound [sig [(fixnum fixnum) -> (fixnum)]] [flags arith-op partial-folder safeongoodargs]) (fx+ [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder]) ; not restricted to 2 arguments + (fx+/wraparound [sig [(fixnum fixnum) -> (fixnum)]] [flags arith-op partial-folder safeongoodargs]) (fx- [sig [(fixnum fixnum ...) -> (fixnum)]] [flags arith-op partial-folder]) ; not restricted to 1 or 2 arguments + (fx-/wraparound [sig [(fixnum fixnum) -> (fixnum)]] [flags arith-op partial-folder safeongoodargs]) (fx/ [sig [(fixnum fixnum ...) -> (fixnum)]] [flags arith-op partial-folder]) ; not restricted to 1 or 2 arguments (fx1+ [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02]) (fx1- [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02]) @@ -1385,13 +1399,13 @@ (fxquotient [sig [(fixnum fixnum ...) -> (fixnum)]] [flags arith-op partial-folder]) (fxremainder [sig [(fixnum fixnum) -> (fixnum)]] [flags arith-op cp02]) (fxsll [sig [(fixnum sub-ufixnum) -> (fixnum)]] [flags arith-op cp02]) + (fxsll/wraparound [sig [(fixnum sub-ufixnum) -> (fixnum)]] [flags arith-op cp02]) (fxsra [sig [(fixnum sub-ufixnum) -> (fixnum)]] [flags arith-op cp02]) (fxsrl [sig [(fixnum sub-ufixnum) -> (fixnum)]] [flags arith-op cp02]) (fxvector [sig [(fixnum ...) -> (fxvector)]] [flags alloc cp02 safeongoodargs]) (fxvector->list [sig [(fxvector) -> (list)]] [flags alloc safeongoodargs]) (fxvector-copy [sig [(fxvector) -> (fxvector)]] [flags alloc safeongoodargs]) (fxvector-fill! [sig [(fxvector fixnum) -> (void)]] [flags true]) - (fxvector->immutable-fxvector [sig [(fxvector) -> (fxvector)]] [flags alloc safeongoodargs]) (fxvector-length [sig [(fxvector) -> (length)]] [flags pure mifoldable discard true safeongoodargs]) (fxvector-ref [sig [(fxvector sub-index) -> (fixnum)]] [flags mifoldable discard cp02]) (fxvector-set! [sig [(fxvector sub-index fixnum) -> (void)]] [flags true]) @@ -1427,7 +1441,6 @@ (immutable-string? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) (immutable-box? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) (immutable-vector? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) - (immutable-fxvector? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) (immutable-bytevector? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) (initial-bytes-allocated [sig [() -> (uint)]] [flags unrestricted alloc]) (input-port-ready? [sig [(input-port) -> (boolean)]] [flags]) @@ -1440,6 +1453,7 @@ (isqrt [sig [(uinteger) -> (integer)]] [flags arith-op mifoldable discard]) (last-pair [sig [(pair) -> ((ptr . ptr))]] [flags mifoldable discard]) (list* [sig [(ptr) -> (ptr)] [(ptr ptr ptr ...) -> ((ptr . ptr))]] [flags unrestricted discard cp02]) + (list->flvector [sig [(sub-list) -> (flvector)]] [flags alloc]) (list->fxvector [sig [(sub-list) -> (fxvector)]] [flags alloc]) (list-assuming-immutable? [sig [(ptr) -> (boolean)]] [flags unrestricted mifoldable discard]) (list-copy [sig [(list) -> (list)]] [flags alloc]) @@ -1475,8 +1489,10 @@ (make-source-table [sig [() -> (source-table)]] [flags unrestricted alloc]) (make-ephemeron-eq-hashtable [sig [() (uint) -> (eq-hashtable)]] [flags alloc]) (make-ephemeron-eqv-hashtable [sig [() (uint) -> (hashtable)]] [flags alloc]) + (make-ephemeron-hashtable [sig [(procedure procedure) (procedure procedure uint) -> (hashtable)]] [flags alloc]) (make-engine [sig [(procedure) -> (engine)]] [flags pure alloc]) (make-format-condition [sig [() -> (condition)]] [flags pure unrestricted mifoldable discard]) + (make-flvector [sig [(length) (length flonum) -> (flvector)]] [flags alloc]) (make-fxvector [sig [(length) (length fixnum) -> (fxvector)]] [flags alloc]) (make-guardian [sig [() (ptr) -> (procedure)]] [flags alloc cp02]) (make-hash-table [sig [() (ptr) -> (old-hash-table)]] [flags unrestricted alloc]) @@ -1500,6 +1516,7 @@ (make-thread-parameter [feature pthreads] [sig [(ptr) (ptr procedure) -> (thread-parameter)]] [flags true cp02 cp03]) (make-weak-eq-hashtable [sig [() (uint) -> (eq-hashtable)]] [flags alloc]) (make-weak-eqv-hashtable [sig [() (uint) -> (hashtable)]] [flags alloc]) + (make-weak-hashtable [sig [(procedure procedure) (procedure procedure uint) -> (hashtable)]] [flags alloc]) (make-wrapper-procedure [sig [(procedure sint ptr) -> (procedure)]] [flags pure true mifoldable discard]) (mark-port-closed! [sig [(port) -> (void)]] [flags true]) (maximum-memory-bytes [sig [() -> (uint)]] [flags alloc]) @@ -1514,7 +1531,6 @@ (multibyte->string [feature windows] [sig [(sub-uint bytevector) -> (string)]] [flags true discard]) (mutable-box? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) (mutable-string? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) - (mutable-fxvector? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) (mutable-bytevector? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) (mutable-vector? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) (mutex-acquire [feature pthreads] [sig [(mutex) (mutex ptr) -> (ptr)]] [flags]) ; can return #f if optional block? arg is #f @@ -1765,6 +1781,8 @@ (textual-port-output-size [sig [(textual-output-port) -> (length)]] [flags discard]) (thread? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) (thread-condition? [feature pthreads] [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) + (thread-join [feature pthreads] [sig [(ptr) -> (void)]] [flags true]) + (thread-preserve-ownership! [feature pthreads] [sig [() -> (void)] [(ptr) -> (void)]] [flags true]) (top-level-bound? [sig [(symbol) (symbol environment) -> (boolean)]] [flags discard]) (top-level-mutable? [sig [(symbol) (symbol environment) -> (boolean)]] [flags discard]) (top-level-syntax [sig [(symbol) (symbol environment) -> (ptr)]] [flags discard]) @@ -1810,7 +1828,8 @@ (with-profile-tracker [sig [(procedure) (ptr procedure) -> (ptr ptr ...)]] [flags]) (with-source-path [sig [(maybe-who pathname procedure) -> (ptr ...)]] [flags]) (wrapper-procedure? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) - (wrapper-procedure-data [sig [(ptr) -> (ptr)]] [flags discard]) + (wrapper-procedure-data [sig [(ptr) -> (ptr)]] [flags]) + (wrapper-procedure-procedure [sig [(ptr) -> (procedure)]] [flags true]) ) @@ -1821,6 +1840,8 @@ ($allocate-thread-parameter [feature pthreads] [flags single-valued alloc]) ($app [flags]) ($app/no-inline [flags]) + ($app/no-return [flags]) + ($app/value [flags]) ($apply [sig [(procedure exact-integer list) -> (ptr ...)]] [flags cptypes2x]) ($assembly-output [flags single-valued]) ($assert-continuation [sig [(ptr) -> (void)] [(ptr ptr) -> (void)]] [flags]) @@ -1902,10 +1923,12 @@ ($current-stack-link [flags single-valued]) ($current-winders [flags single-valued]) ($dequeue-scheme-signals [flags]) + ($describe-fasl-from-port [sig [(input-port) (input-port vector) -> (ptr)]] [flags]) ($distinct-bound-ids? [sig [(list) -> (boolean)]] [flags discard]) ($dofmt [flags single-valued]) ($do-wind [flags single-valued]) ($dynamic-closure-counts [flags single-valued alloc]) ; added for closure instrumentation + ($emit-boot-header [flags single-valued]) ($enum-set-members [flags single-valued]) ($eol-style? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable]) ($eq-hashtable-cells [flags single-valued discard]) @@ -1929,15 +1952,19 @@ ($expeditor [feature expeditor] [flags]) ($fasl-base-rtd [flags single-valued]) ($fasl-bld-graph [flags single-valued]) + ($fasl-can-combine? [flags single-valued]) ($fasl-enter [flags single-valued]) ($fasl-file-equal? [sig [(pathname pathname) (pathname pathname ptr) -> (boolean)]] [flags discard]) ($fasl-out [flags single-valued]) ($fasl-start [flags single-valued]) ($fasl-table [flags single-valued]) + ($fasl-to-vfasl [flags single-valued]) ($fasl-wrf-graph [flags single-valued]) ($filter-conv [flags single-valued]) ($filter-foreign-type [flags single-valued]) ($fixed-path? [sig [(string) -> (boolean)]] [flags pure safeongoodargs]) + ($flvector-ref-check? [sig [(ptr ptr) -> (boolean)]] [flags unrestricted pure]) + ($flvector-set!-check? [sig [(ptr ptr) -> (boolean)]] [flags unrestricted discard]) ($<= [flags single-valued]) ($< [flags single-valued]) ($= [flags single-valued]) @@ -2111,6 +2138,7 @@ ($ftd-atomic-category [flags single-valued]) ($ftd-compound? [sig [(sub-ptr) -> (boolean)]] [flags discard]) ($ftd-size [flags single-valued]) + ($ftd-union? [sig [(sub-ptr) -> (boolean)]] [flags discard]) ($ftd-unsigned? [flags single-valued]) ($ftd->members [flags single-valued]) ($ftype-guardian-oops [flags]) @@ -2123,7 +2151,6 @@ ($fxu< [flags single-valued pure cp02]) ($fxvector-ref-check? [sig [(ptr ptr) -> (boolean)]] [flags unrestricted pure]) ($fxvector-set!-check? [sig [(ptr ptr) -> (boolean)]] [flags unrestricted discard]) - ($fxvector-set-immutable! [sig [(fxvector) -> (void)]] [flags true]) ($gc-cpu-time [flags true]) ($gc-real-time [flags true]) ($generation [flags single-valued]) @@ -2275,6 +2302,7 @@ ($raw-collect-cond [feature pthreads] [flags single-valued]) ($raw-collect-thread0-cond [feature pthreads] [flags single-valued]) ($raw-tc-mutex [feature pthreads] [flags single-valued]) + ($raw-terminated-cond [feature pthreads] [flags single-valued]) ($read-performance-monitoring-counter [flags single-valued]) ($read-time-stamp-counter [flags single-valued]) ($real->flonum [flags single-valued arith-op mifoldable discard]) @@ -2426,6 +2454,7 @@ ($enable-pass-timing [flags single-valued]) ($expeditor-history-file [feature expeditor] [flags single-valued]) ($fasl-target [flags single-valued]) + ($lift-closures [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted]) ($optimize-closures [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted]) ($suppress-primitive-inlining [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted]) ($sfd [flags single-valued]) @@ -2450,6 +2479,7 @@ ($session-key [flags]) ($symbol-ht-rtd [flags]) ($tc-mutex [feature pthreads] [flags]) + ($terminated-cond [feature pthreads] [flags]) ) (define-symbol-flags* ([libraries] [flags system-keyword]) ; condition types diff --git a/src/ChezScheme/s/prims.ss b/src/ChezScheme/s/prims.ss index 22909f79fb..bfde6f4ed7 100644 --- a/src/ChezScheme/s/prims.ss +++ b/src/ChezScheme/s/prims.ss @@ -286,6 +286,8 @@ "~s is not a character")) (set! fxvector (frob-proc fxvector make-fxvector fxvector-set! fixnum? "~s is not a fixnum")) + (set! flvector (frob-proc flvector make-flvector flvector-set! flonum? + "~s is not a flonum")) (set! bytevector (let ([fill? (lambda (k) (and (fixnum? k) (fx<= -128 k 255)))]) (frob-proc bytevector make-bytevector $bytevector-set! fill? @@ -360,6 +362,28 @@ ($oops who "~s is not a valid fxvector length" n)) (make-fxvector n)])) +(define-who make-flvector + (case-lambda + [(n x) + (unless (and (fixnum? n) (not ($fxu< (constant maximum-flvector-length) n))) + ($oops who "~s is not a valid flvector length" n)) + (unless (flonum? x) + ($oops who "~s is not a flonum" x)) + (if (eqv? x 0.0) + (make-flvector n) + ;; Room for improvement: vector is filled with 0.0, then with `x`: + (let ([flv (make-flvector n)]) + (let loop ([i 0]) + (if (fx= i n) + flv + (begin + (flvector-set! flv i x) + (loop (fx+ i 1)))))))] + [(n) + (unless (and (fixnum? n) (not ($fxu< (constant maximum-flvector-length) n))) + ($oops who "~s is not a valid flvector length" n)) + (make-flvector n)])) + (define string-fill! (lambda (s c) (unless (mutable-string? s) @@ -370,12 +394,24 @@ (define fxvector-fill! (lambda (v n) - (unless (mutable-fxvector? v) - ($oops 'fxvector-fill! "~s is not a mutable fxvector" v)) + (unless (fxvector? v) + ($oops 'fxvector-fill! "~s is not a fxvector" v)) (unless (fixnum? n) - ($oops 'fxvector-fill! "~s is not a fixnum" n)) + ($oops 'fxvector-fill! "~s is not a fixnum" n)) (fxvector-fill! v n))) +(define flvector-fill! + (lambda (v x) + (unless (flvector? v) + ($oops 'flvector-fill! "~s is not a flvector" v)) + (unless (flonum? x) + ($oops 'flvector-fill! "~s is not a flonum" x)) + (let ([n (flvector-length v)]) + (let loop ([i 0]) + (unless (fx= i n) + (flvector-set! v i x) + (loop (fx+ i 1))))))) + ;;; multiple return values stuff (define values ($hand-coded 'values-procedure)) @@ -397,6 +433,17 @@ (lambda (f . args) (#2%apply f args))) +;; Implies no-inline, and in unsafe mode, asserts that the +;; application will not return +(define $app/no-return + (lambda (f . args) + (#2%apply f args))) + +;; In unsafe mode, asserts that the applicaiton returns a single value +(define $app/value + (lambda (f . args) + (#2%apply f args))) + (define call-with-values (lambda (producer consumer) (unless (procedure? producer) @@ -700,6 +747,9 @@ (define $fxvector-ref-check? (lambda (v i) ($fxvector-ref-check? v i))) (define $fxvector-set!-check? (lambda (v i) ($fxvector-set!-check? v i))) +(define $flvector-ref-check? (lambda (v i) ($flvector-ref-check? v i))) +(define $flvector-set!-check? (lambda (v i) ($flvector-set!-check? v i))) + (define $ratio-numerator (lambda (q) (if (ratnum? q) @@ -1272,19 +1322,17 @@ (lambda (v i x) (#2%fxvector-set! v i x))) -(define-who $fxvector-set-immutable! - (lambda (s) - (unless (fxvector? s) - ($oops who "~s is not a fxvector" s)) - (#3%$fxvector-set-immutable! s))) +(define flvector-length + (lambda (v) + (#2%flvector-length v))) -(define mutable-fxvector? - (lambda (s) - (#3%mutable-fxvector? s))) +(define flvector-ref + (lambda (v i) + (#2%flvector-ref v i))) -(define immutable-fxvector? - (lambda (s) - (#3%immutable-fxvector? s))) +(define flvector-set! + (lambda (v i x) + (#2%flvector-set! v i x))) (define stencil-vector-mask (lambda (v) @@ -1386,6 +1434,8 @@ (define fxvector? (lambda (x) (fxvector? x))) +(define flvector? (lambda (x) (flvector? x))) + (define stencil-vector? (lambda (x) (stencil-vector? x))) (define procedure? (lambda (x) (procedure? x))) @@ -1755,12 +1805,17 @@ ($oops '$thread-tc "~s is not a thread" thread)) ($thread-tc thread))) +) + (when-feature pthreads (define $raw-collect-cond (lambda () ($raw-collect-cond))) (define $raw-collect-thread0-cond (lambda () ($raw-collect-thread0-cond))) (define $raw-tc-mutex (lambda () ($raw-tc-mutex))) +(define $raw-terminated-cond (lambda () ($raw-terminated-cond))) (define fork-thread) +(define thread-join) +(define thread-preserve-ownership!) (define make-mutex) (define mutex?) (define mutex-name) @@ -1776,6 +1831,7 @@ (define $tc-mutex) (define $collect-cond) (define $collect-thread0-cond) +(define $terminated-cond) (define get-initial-thread) (let () ; scheme-object's below are mutex and condition addresses, which are @@ -1837,6 +1893,29 @@ (t) (void)))))))) +(set-who! thread-join + (lambda (t) + (unless (thread? t) + ($oops who "~a is not a thread" t)) + (with-tc-mutex + (let f () + (unless (eq? ($thread-tc t) 0) + (condition-wait $terminated-cond $tc-mutex) + (f)))))) + +(set-who! thread-preserve-ownership! + (let ([preserve! (foreign-procedure "(cs)thread_preserve_ownership" (ptr) void)]) + (case-lambda + [(t) + (unless (thread? t) + ($oops who "~a is not a thread" t)) + (with-tc-mutex + (let ([tc ($thread-tc t)]) + (unless (eq? tc 0) + (preserve! tc))))] + [() + (with-tc-mutex (preserve! ($tc)))]))) + (set-who! make-mutex (case-lambda [() (make-mutex-no-check #f)] @@ -1953,12 +2032,13 @@ (set! $tc-mutex ($make-mutex ($raw-tc-mutex) '$tc-mutex)) (set! $collect-cond ($make-condition ($raw-collect-cond) '$collect-cond)) (set! $collect-thread0-cond ($make-condition ($raw-collect-thread0-cond) '$collect-thread0-cond)) +(set! $terminated-cond ($make-condition ($raw-terminated-cond) '$terminated-cond)) (set! get-initial-thread (let ([thread (car (ts))]) (lambda () thread))) )) - +(begin (let () (define-syntax define-tc-parameter (lambda (x) @@ -2691,6 +2771,11 @@ ;; Indirect way of distinguishing from `$make-wrapper-procedure` result: ($code-mutable-closure? c)))))) +(define-who wrapper-procedure-procedure + (lambda (x) + (unless (wrapper-procedure? x) ($oops who "~s is not a wrapper procedure" x)) + ($closure-ref x 0))) + (define-who set-wrapper-procedure! (lambda (x proc) (unless (wrapper-procedure? x) ($oops who "~s is not a wrapper procedure" x)) diff --git a/src/ChezScheme/s/print.ss b/src/ChezScheme/s/print.ss index ffa5f50f68..1c20fad73d 100644 --- a/src/ChezScheme/s/print.ss +++ b/src/ChezScheme/s/print.ss @@ -105,6 +105,7 @@ (box? x) (and ($record? x) (not (eq? x #!base-rtd))) (fxvector? x) + (flvector? x) (string? x) (bytevector? x) (gensym? x)))))) @@ -679,6 +680,7 @@ floating point returns with (1 0 -1 ...). (string-append "stencil[" (number->string (stencil-vector-mask x) 16) "]") x r lev len d? env p)] [(fxvector?) (wrvector fxvector-length fxvector-ref "vfx" x r lev len d? env p)] + [(flvector?) (wrvector flvector-length flvector-ref "vfl" x r lev len d? env p)] [(bytevector?) (wrvector bytevector-length bytevector-u8-ref "vu8" x r lev len d? env p)] [(flonum?) (wrflonum #f x r d? p)] ; catch before record? case @@ -755,12 +757,13 @@ floating point returns with (1 0 -1 ...). [(let ([info ($code-info x)]) (and (code-info? info) (code-info-src info))) => (lambda (src) - (fprintf p " at ~a:~a" - (let ([fn (source-file-descriptor-name (source-sfd src))]) - (if (string? fn) (path-last fn) fn)) - (if (source-2d? src) - (format "~a.~a" (source-2d-line src) (source-2d-column src)) - (source-bfp src))))]))) + (let ([fn (source-file-descriptor-name (source-sfd src))]) + (when (or (string? fn) (symbol? fn)) + (fprintf p " at ~a:~a" + (if (string? fn) (path-last fn) fn) + (if (source-2d? src) + (format "~a.~a" (source-2d-line src) (source-2d-column src)) + (source-bfp src))))))]))) (define wrprocedure (lambda (x p) diff --git a/src/ChezScheme/s/read.ss b/src/ChezScheme/s/read.ss index 7e4b4b4e34..bd94ae714d 100644 --- a/src/ChezScheme/s/read.ss +++ b/src/ChezScheme/s/read.ss @@ -732,6 +732,7 @@ [#\( ;) (cond [(string=? s "fx") (nonstandard "#vfx(...) fxvector") (state-return vfxparen #f)] + [(string=? s "fl") (nonstandard "#vfl(...) flvector") (state-return vflparen #f)] [(string=? s "u8") (state-return vu8paren #f)] [else (xcall rd-error #f #t "invalid syntax #v~a(" s)])] ;) [else @@ -753,6 +754,7 @@ [#\( ;) (cond [(string=? s "fx") (nonstandard "#<n>vfx(...) fxvector") (state-return vfxnparen nelts)] + [(string=? s "fl") (nonstandard "#<n>vfl(...) flvector") (state-return vflnparen nelts)] [(string=? s "u8") (nonstandard "#<n>vu8(...) bytevector") (state-return vu8nparen nelts)] [else (xcall rd-error #f #t "invalid syntax #~v,'0dv~a(" (- preflen 1) nelts s)])] ;) [else @@ -1178,6 +1180,8 @@ [(vnparen) (xcall rd-sized-vector value)] [(vfxparen) (xmvlet ((v) (xcall rd-fxvector bfp 0)) (xvalues v v))] [(vfxnparen) (xmvlet ((v) (xcall rd-sized-fxvector value)) (xvalues v v))] + [(vflparen) (xmvlet ((v) (xcall rd-flvector bfp 0)) (xvalues v v))] + [(vflnparen) (xmvlet ((v) (xcall rd-sized-flvector value)) (xvalues v v))] [(vu8paren) (xmvlet ((v) (xcall rd-bytevector bfp 0)) (xvalues v v))] [(vu8nparen) (xmvlet ((v) (xcall rd-sized-bytevector value)) (xvalues v v))] [(box) (xcall rd-box)] @@ -1434,6 +1438,48 @@ (fxvector-set! v i value) (xcall rd-fill-fxvector expr-bfp v (fx+ i 1) n)]))) +;; an flvector contains a sequence of flonum tokens. we don't handle +;; graph marks and references because to do so generally, we'd have to +;; put non-flonums (insert records) into the flonum or perhaps +;; somehow generalize delayed records to handle flonums +(xdefine (rd-flvector expr-bfp i) + (with-token (type value) + (case type + [(rparen) (xvalues (make-flvector i))] + [(eof) (let ([bfp expr-bfp]) (xcall rd-eof-error "flvector"))] + [else + (unless (and (eq? type 'atomic) (flonum? value)) + (xcall rd-error #f #t "non-fixnum found in flvector")) + (xmvlet ((v) (xcall rd-flvector expr-bfp (fx+ i 1))) + (flvector-set! v i value) + (xvalues v))]))) + +(xdefine (rd-sized-flvector n) + (unless (and (fixnum? n) (fxnonnegative? n)) + (let ([bfp (and bfp (+ bfp 1))] [fp (and fp (- fp 1))]) + (xcall rd-error #f #t "invalid flvector length ~s" n))) + (xcall rd-fill-flvector bfp (make-flvector n) 0 n)) + +(xdefine (rd-fill-flvector expr-bfp v i n) + (with-token (type value) + (case type + [(rparen) + (when (fx< 0 i n) + (let ((prev (flvector-ref v (fx- i 1)))) + (do ([i i (fx+ i 1)]) + ((fx= i n)) + (flvector-set! v i prev)))) + (xvalues v)] + [(eof) (let ([bfp expr-bfp]) (xcall rd-eof-error "flvector"))] + [else + (unless (and (eq? type 'atomic) (flonum? value)) + (xcall rd-error #f #t "non-fixnum found in flvector")) + (unless (fx< i n) + (let ([bfp expr-bfp]) + (xcall rd-error #f #t "too many flvector elements supplied"))) + (flvector-set! v i value) + (xcall rd-fill-flvector expr-bfp v (fx+ i 1) n)]))) + ;; a bytevector contains a sequence of fixnum tokens. we don't handle ;; graph marks and references because to do so generally, we'd have to ;; put non-fixnums (insert records) into the bytevector or perhaps diff --git a/src/ChezScheme/s/record.ss b/src/ChezScheme/s/record.ss index 71537ece10..53bb7f2a39 100644 --- a/src/ChezScheme/s/record.ss +++ b/src/ChezScheme/s/record.ss @@ -25,7 +25,8 @@ ;;; include size of tag in record size OR don't include tag in record offsets (let () - (define (rtd-parent x) ($object-ref 'scheme-object x (constant record-type-parent-disp))) + (define (rtd-ancestry x) ($object-ref 'scheme-object x (constant record-type-ancestry-disp))) + (define (rtd-parent x) (vector-ref (rtd-ancestry x) 0)) (define (rtd-size x) ($object-ref 'scheme-object x (constant record-type-size-disp))) (define (rtd-pm x) ($object-ref 'scheme-object x (constant record-type-pm-disp))) (define (rtd-mpm x) ($object-ref 'scheme-object x (constant record-type-mpm-disp))) @@ -509,6 +510,21 @@ (record-datatype cases (filter-foreign-type ty) size ($oops who "invalid foreign type specifier ~s" ty)))) + (set-who! foreign-alignof + (lambda (ty) + (define-syntax size + (syntax-rules () + [(_ type bytes pred) + ;; rely on cp0 expansion: + (case 'type + [(double-float) (foreign-alignof 'double)] + [(single-float) (foreign-alignof 'float)] + [(integer-64) (foreign-alignof 'integer-64)] + [(unsigned-64) (foreign-alignof 'unsigned-64)] + [else bytes])])) + (record-datatype cases (filter-foreign-type ty) size + ($oops who "invalid foreign type specifier ~s" ty)))) + (set-who! #(csv7: record-type-descriptor) (lambda (r) (unless (record? r) ($oops who "~s is not a record" r)) @@ -603,10 +619,16 @@ (unless (eq? (rtd-size rtd) size) (squawk "different size"))) rtd)] [else - (let ([rtd (apply #%$record base-rtd parent size pm mpm name - (if (pair? flds) (cdr flds) (fx- flds 1)) flags uid #f extras)]) - (with-tc-mutex ($sputprop uid '*rtd* rtd)) - rtd)])))) + (let* ([len (if (not parent) 0 (vector-length (rtd-ancestry parent)))] + [ancestry (make-vector (fx+ 1 len) parent)]) + (let loop ([i 0]) + (unless (fx= i len) + (vector-set! ancestry (fx+ i 1) (vector-ref (rtd-ancestry parent) i)) + (loop (fx+ i 1)))) + (let ([rtd (apply #%$record base-rtd ancestry size pm mpm name + (if (pair? flds) (cdr flds) (fx- flds 1)) flags uid #f extras)]) + (with-tc-mutex ($sputprop uid '*rtd* rtd)) + rtd))])))) (set-who! $remake-rtd (lambda (rtd compute-field-offsets) @@ -614,7 +636,7 @@ (assert (not (eq? key (machine-type)))) (or ($sgetprop uid key #f) (let ([base-rtd ($record-type-descriptor rtd)] - [parent (rtd-parent rtd)] + [ancestry (rtd-ancestry rtd)] [name (rtd-name rtd)] [flags (rtd-flags rtd)] [flds (rtd-flds rtd)]) @@ -627,7 +649,7 @@ (compute-field-offsets who (constant record-type-disp) (cons `(immutable scheme-object ,uid) fields))))]) - (let ([rtd (apply #%$record base-rtd parent size pm mpm name + (let ([rtd (apply #%$record base-rtd ancestry size pm mpm name (if (pair? flds) (cdr flds) (fx- flds 1)) flags uid #f (let* ([n (length (rtd-flds ($record-type-descriptor base-rtd)))] [ls (list-tail (rtd-flds base-rtd) n)]) diff --git a/src/ChezScheme/s/strip-types.ss b/src/ChezScheme/s/strip-types.ss new file mode 100644 index 0000000000..094a70d79a --- /dev/null +++ b/src/ChezScheme/s/strip-types.ss @@ -0,0 +1,30 @@ +(define-datatype #{fasl striprur0zx3-fasl} + (#{entry striprur0zx3-0} situation fasl) + (#{header striprur0zx3-1} version machine dependencies) + (#{pair striprur0zx3-2} vfasl) + (#{tuple striprur0zx3-3} ty vfasl) + (#{string striprur0zx3-4} ty string) + (#{gensym striprur0zx30-5} pname uname) + (#{vector striprur0zx3-6} ty vfasl) + (#{fxvector striprur0zx3-7} viptr) + (#{bytevector striprur0zx3-9} ty bv) + (#{stencil-vector striprur0zx3-sv} mask vfasl) + (#{record striprur0zx3-10} maybe-uid size nflds rtd pad-ty* fld*) ; maybe-uid => rtd + (#{rtd-ref striprur0zx3-11} uid) ; field info not recorded + (#{closure striprur0zx3-12} offset c) + (#{flonum striprur0zx3-13} high low) + (#{small-integer striprur0zx3-14} iptr) + (#{large-integer striprur0zx3-15} sign vuptr) + (#{eq-hashtable striprur0zx3-16} mutable? subtype minlen veclen vpfasl) + (#{symbol-hashtable striprur0zx3-17} mutable? minlen equiv veclen vpfasl) + (#{code striprur0zx3-18} flags free name arity-mask info pinfo* bytes m vreloc) + (#{atom striprur0zx3-19} ty uptr) + (#{reloc striprur0zx3-20} type-etc code-offset item-offset fasl) + (#{indirect striprur0zx3-21} g i)) + +(define-datatype #{field stripfur0zx3-field} + (#{ptr stripfur0zx3-0} fasl) + (#{byte stripfur0zx3-1} n) + (#{iptr stripfur0zx3-2} n) + (#{single stripfur0zx3-3} n) + (#{double stripfur0zx3-4} high low)) diff --git a/src/ChezScheme/s/strip.ss b/src/ChezScheme/s/strip.ss index d9e3dd9e1d..cb4ceb48ba 100644 --- a/src/ChezScheme/s/strip.ss +++ b/src/ChezScheme/s/strip.ss @@ -1,4 +1,4 @@ -;;; strip.ss +;; strip.ss ;;; Copyright 1984-2017 Cisco Systems, Inc. ;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); @@ -13,39 +13,17 @@ ;;; See the License for the specific language governing permissions and ;;; limitations under the License. +;; The `strip-fasl-file` and related functions use a fasl reader and +;; writer that are completely separate from the ones in "fasl.ss" and +;; "fasl.c", so changes made in those places must be duplicated here. +;; The vfasl writer uses this fasl reader. + (let () ; per file (define-threaded fasl-who) (define-threaded fasl-count) - (define-datatype fasl - (entry situation fasl) - (header version machine dependencies) - (pair vfasl) - (tuple ty vfasl) - (string ty string) - (gensym pname uname) - (vector ty vfasl) - (fxvector ty viptr) - (bytevector ty bv) - (record maybe-uid size nflds rtd pad-ty* fld*) ; maybe-uid => rtd - (closure offset c) - (flonum high low) - (small-integer iptr) - (large-integer sign vuptr) - (eq-hashtable mutable? subtype minlen veclen vpfasl) - (symbol-hashtable mutable? minlen equiv veclen vpfasl) - (code flags free name arity-mask info pinfo* bytes m vreloc) - (atom ty uptr) - (reloc type-etc code-offset item-offset fasl) - (indirect g i)) - - (define-datatype field - (ptr fasl) - (byte n) - (iptr n) - (single n) - (double high low)) + (include "strip-types.ss") (define follow-indirect (lambda (x) @@ -123,7 +101,7 @@ ((= i n)) (string-set! s i (integer->char (read-uptr p)))) s)))) - (define (read-entry p) + (define (read-entry p init-g) (let ([ty (read-byte-or-eof p)]) (if (eof-object? ty) ty @@ -145,8 +123,8 @@ (if (eqv? compressed-flag (constant fasl-type-gzip)) (constant COMPRESS-GZIP) (constant COMPRESS-LZ4)))]) - (fasl-entry situation (read-fasl (open-bytevector-input-port bv) #f))))] - [(fasl-type-uncompressed) (fasl-entry situation (read-fasl p #f))] + (fasl-entry situation (read-fasl (open-bytevector-input-port bv) init-g))))] + [(fasl-type-uncompressed) (fasl-entry situation (read-fasl p init-g))] [else (bogus "expected compression flag in ~a" (port-name p))]))] [else (bogus "expected header or situation in ~a" (port-name p))])))) (define (read-header p) @@ -199,8 +177,8 @@ (vector-set! v i (let ([key (read-fasl p g)]) (cons key (read-fasl p g)))))))) - (define (read-record p g maybe-uid) - (let* ([size (read-uptr p)] [nflds (read-uptr p)] [rtd (read-fasl p g)]) + (define (read-record p g maybe-uid size) + (let* ([nflds (read-uptr p)] [rtd (read-fasl p g)]) (let loop ([n nflds] [rpad-ty* '()] [rfld* '()]) (if (fx= n 0) (fasl-record maybe-uid size nflds rtd (reverse rpad-ty*) (reverse rfld*)) @@ -215,13 +193,14 @@ [(fasl-type-gensym) (let* ([pname (read-string p)] [uname (read-string p)]) (fasl-gensym pname uname))] - [(fasl-type-ratnum fasl-type-exactnum fasl-type-inexactnum fasl-type-weak-pair) + [(fasl-type-ratnum fasl-type-exactnum fasl-type-inexactnum + fasl-type-weak-pair fasl-type-ephemeron) (let ([first (read-fasl p g)]) (fasl-tuple ty (vector first (read-fasl p g))))] - [(fasl-type-vector fasl-type-immutable-vector) (fasl-vector ty (read-vfasl p g (read-uptr p)))] - [(fasl-type-fxvector fasl-type-immutable-fxvector) + [(fasl-type-vector fasl-type-immutable-vector fasl-type-flvector) + (fasl-vector ty (read-vfasl p g (read-uptr p)))] + [(fasl-type-fxvector) (fasl-fxvector - ty (let ([n (read-uptr p)]) (let ([v (make-vector n)]) (do ([i 0 (fx+ i 1)]) @@ -229,9 +208,16 @@ (vector-set! v i (read-iptr p))))))] [(fasl-type-bytevector fasl-type-immutable-bytevector) (fasl-bytevector ty (read-bytevector p (read-uptr p)))] + [(fasl-type-stencil-vector) + (let ([mask (read-uptr p)]) + (fasl-stencil-vector mask (read-vfasl p g (bitwise-bit-count mask))))] [(fasl-type-base-rtd) (fasl-tuple ty '#())] - [(fasl-type-rtd) (read-record p g (read-fasl p g))] - [(fasl-type-record) (read-record p g #f)] + [(fasl-type-rtd) (let* ([uid (read-fasl p g)] + [size (read-uptr p)]) + (if (eqv? size 0) + (fasl-rtd-ref uid) + (read-record p g uid size)))] + [(fasl-type-record) (read-record p g #f (read-uptr p))] [(fasl-type-closure) (let* ([offset (read-uptr p)] [c (read-fasl p g)]) @@ -285,11 +271,19 @@ [item-offset (if (fxlogtest type-etc 2) (read-uptr p) 0)]) (loop (fx+ n (if (fxlogtest type-etc 1) 3 1)) - (cons (fasl-reloc type-etc code-offset item-offset (read-fasl p g)) rls)))))]) + (cons (fasl-reloc type-etc code-offset item-offset (read-fasl p g)) rls)))))] + ) (fasl-code flags free name arity-mask info pinfo* bytes m vreloc))] [(fasl-type-immediate fasl-type-entry fasl-type-library fasl-type-library-code) (fasl-atom ty (read-uptr p))] - [(fasl-type-graph) (read-fasl p (make-vector (read-uptr p) #f))] + [(fasl-type-graph) (read-fasl p (let ([new-g (make-vector (read-uptr p) #f)]) + (when g + (let ([delta (fx- (vector-length new-g) (vector-length g))]) + (let loop ([i 0]) + (unless (fx= i (vector-length g)) + (vector-set! new-g (fx+ i delta) (vector-ref g i)) + (loop (fx+ i 1)))))) + new-g))] [(fasl-type-graph-def) (let ([n (read-uptr p)]) (let ([x (read-fasl p g)]) @@ -300,6 +294,14 @@ (let ([n (read-uptr p)]) (or (vector-ref g n) (fasl-indirect g n)))] + [(fasl-type-begin) + (let loop ([n (read-uptr p)]) + (if (fx= n 1) + (read-fasl p g) + (begin + ;; will set graph definitions: + (read-fasl p g) + (loop (fx- n 1)))))] [else (bogus "unexpected fasl code ~s in ~a" ty (port-name p))])))) (define read-script-header @@ -419,8 +421,9 @@ [string (ty string) (build-graph! x t void)] [gensym (pname uname) (build-graph! x t void)] [vector (ty vfasl) (build-graph! x t (build-vfasl! vfasl))] - [fxvector (ty viptr) (build-graph! x t void)] + [fxvector (viptr) (build-graph! x t void)] [bytevector (ty viptr) (build-graph! x t void)] + [stencil-vector (mask vfasl) (build-graph! x t (build-vfasl! vfasl))] [record (maybe-uid size nflds rtd pad-ty* fld*) (if (and strip-source-annotations? (fasl-annotation? x)) (build! (fasl-annotation-stripped x) t) @@ -433,6 +436,7 @@ [ptr (fasl) (build! fasl t)] [else (void)])) fld*))))] + [rtd-ref (uid) (build-graph! x t (lambda () (build! uid #t)))] [closure (offset c) (build-graph! x t (lambda () (build! c t)))] [flonum (high low) (build-graph! x t void)] [small-integer (iptr) (void)] @@ -467,24 +471,35 @@ (include "fasl-helpers.ss") - (define write-entry - (lambda (p x) + (define handle-entry + (lambda (x header-k entry-k) (fasl-case x [header (version machine dependencies) - (emit-header p version machine dependencies)] + (header-k (lambda (p) (emit-header p version machine dependencies)))] [entry (situation fasl) - (let ([t (make-table)]) - (build! fasl t) - (let-values ([(bv* size) - (let-values ([(p extractor) ($open-bytevector-list-output-port)]) - (let ([n (table-count t)]) - (unless (fx= n 0) - (put-u8 p (constant fasl-type-graph)) - (put-uptr p n))) - (write-fasl p t fasl) - (extractor))]) - ($write-fasl-bytevectors p bv* size situation (constant fasl-type-fasl))))] - [else (sorry! "unrecognized top-level fasl-record-type ~s" x)]))) + (entry-k situation fasl)] + [else + (sorry! "unrecognized top-level fasl-record-type ~s" x)]))) + + (define (write-one-entry p situation fasl) + (let ([t (make-table)]) + (build! fasl t) + (let-values ([(bv* size) + (let-values ([(p extractor) ($open-bytevector-list-output-port)]) + (let ([n (table-count t)]) + (unless (fx= n 0) + (put-u8 p (constant fasl-type-graph)) + (put-uptr p n))) + (write-fasl p t fasl) + (extractor))]) + ($write-fasl-bytevectors p bv* size situation (constant fasl-type-fasl))))) + + (define write-entry + (lambda (p x) + (handle-entry + x + (lambda (write-k) (write-k p)) + (lambda (situation fasl) (write-one-entry p situation fasl))))) (define write-graph (lambda (p t x th) @@ -533,10 +548,10 @@ (put-u8 p ty) (put-uptr p (vector-length vfasl)) (vector-for-each (lambda (fasl) (write-fasl p t fasl)) vfasl)))] - [fxvector (ty viptr) + [fxvector (viptr) (write-graph p t x (lambda () - (put-u8 p ty) + (put-u8 p (constant fasl-type-fxvector)) (put-uptr p (vector-length viptr)) (vector-for-each (lambda (iptr) (put-iptr p iptr)) viptr)))] [bytevector (ty bv) @@ -545,6 +560,12 @@ (put-u8 p ty) (put-uptr p (bytevector-length bv)) (put-bytevector p bv)))] + [stencil-vector (mask vfasl) + (write-graph p t x + (lambda () + (put-u8 p (constant fasl-type-stencil-vector)) + (put-uptr p mask) + (vector-for-each (lambda (fasl) (write-fasl p t fasl)) vfasl)))] [record (maybe-uid size nflds rtd pad-ty* fld*) (if (and strip-source-annotations? (fasl-annotation? x)) (write-fasl p t (fasl-annotation-stripped x)) @@ -569,6 +590,11 @@ (put-uptr p high) (put-uptr p low)])) pad-ty* fld*))))] + [rtd-ref (uid) + (write-graph p t x + (lambda () + (put-uptr p 0) + (write-fasl p t uid)))] [closure (offset c) (write-graph p t x (lambda () @@ -673,46 +699,278 @@ [header (version machine dependencies) x] [else (sorry! "expected entry or header, got ~s" x)]))) + ;; Almost the same as fasl-read, but in a rawer form that exposes + ;; more of the encoding's structure + (define describe + (lambda (x) + (define-syntax constant-value-case + (syntax-rules (else) + [(_ e0 [(k ...) e1 e2 ...] ... [else ee1 ee2 ...]) + (let ([x e0]) + (cond + [(memv x (list (constant k) ...)) e1 e2 ...] + ... + [else ee1 ee2 ...]))])) + (let ([ht (make-eq-hashtable)]) + (define (build-flonum high low) + (let ([bv (make-bytevector 8)]) + (bytevector-u64-native-set! bv 0 (bitwise-ior low (bitwise-arithmetic-shift high 32))) + (bytevector-ieee-double-native-ref bv 0))) + (define (describe x) + (cond + [(not (fasl? x)) + ;; Preumably from the vector of externals + x] + [else + (let ([p (eq-hashtable-cell ht x #f)]) + (or (cdr p) + (let ([self (vector 'CYCLE #f)]) + (set-cdr! p self) + (let ([v (describe-next x)]) + (vector-set! self 1 v) + (set-cdr! p v) + v))))])) + (define (describe-next x) + (fasl-case x + [entry (situation fasl) + (vector 'ENTRY + situation + (describe fasl))] + [header (version machine dependencies) + (vector 'HEADER + version + machine + dependencies)] + [pair (vfasl) + (let ([len (vector-length vfasl)]) + (let loop ([i 0]) + (let ([e (describe (vector-ref vfasl i))] + [i (fx+ i 1)]) + (if (fx= i len) + e + (cons e (loop i))))))] + [tuple (ty vfasl) + (constant-value-case ty + [(fasl-type-box fasl-type-immutable-box) + (box (describe (vector-ref vfasl 0)))] + [(fasl-type-ratnum) + (/ (describe (vector-ref vfasl 0)) + (describe (vector-ref vfasl 1)))] + [(fasl-type-exactnum) + (make-rectangular (describe (vector-ref vfasl 0)) + (describe (vector-ref vfasl 1)))] + [(fasl-type-inexactnum) + (make-rectangular (describe (vector-ref vfasl 0)) + (describe (vector-ref vfasl 1)))] + [(fasl-type-weak-pair) + (weak-cons (describe (vector-ref vfasl 0)) + (describe (vector-ref vfasl 1)))] + [(fasl-type-ephemeron) + (ephemeron-cons (describe (vector-ref vfasl 0)) + (describe (vector-ref vfasl 1)))] + [(fasl-type-base-rtd) + #!base-rtd] + [else + 'unknown])] + [string (ty string) + (constant-value-case ty + [(fasl-type-symbol) (string->symbol string)] + [else string])] + [gensym (pname uname) (gensym pname uname)] + [vector (ty vfasl) (vector-map describe vfasl)] + [fxvector (viptr) viptr] + [bytevector (ty bv) bv] + [stencil-vector (ty vfasl) (vector-map describe vfasl)] + [record (maybe-uid size nflds rtd pad-ty* fld*) + (vector 'RECORD + (and maybe-uid (describe maybe-uid)) + size + nflds + (describe rtd) + (map (lambda (fld) + (field-case fld + [ptr (fasl) (describe fasl)] + [byte (n) n] + [iptr (n) n] + [single (n) n] + [double (high low) (build-flonum high low)])) + fld*))] + [rtd-ref (uid) (vector 'RTD (describe uid))] + [closure (offset c) + (vector 'CLOSURE + offset + (describe c))] + [flonum (high low) (build-flonum high low)] + [large-integer (sign vuptr) + (let loop ([v 0] [i 0]) + (cond + [(fx= i (vector-length vuptr)) + (if (eqv? sign 1) (- v) v)] + [else (loop (bitwise-ior (bitwise-arithmetic-shift v (constant bigit-bits)) + (vector-ref vuptr i)) + (fx+ i 1))]))] + [eq-hashtable (mutable? subtype minlen veclen vpfasl) + (let ([ht (make-eq-hashtable)]) + (vector-for-each + (lambda (pfasl) + (eq-hashtable-set! ht (car pfasl) (cdr pfasl))) + vpfasl) + ht)] + [symbol-hashtable (mutable? minlen equiv veclen vpfasl) + (let ([ht (make-eq-hashtable)]) + (vector-for-each + (lambda (pfasl) + (eq-hashtable-set! ht (car pfasl) (cdr pfasl))) + vpfasl) + ht)] + [code (flags free name arity-mask info pinfo* bytes m vreloc) + (vector 'CODE + flags + free + (describe name) + (describe arity-mask) + (describe info) + (describe pinfo*) + bytes + m + (vector-map describe vreloc))] + [small-integer (iptr) iptr] + [atom (ty uptr) + (constant-value-case ty + [(fasl-type-immediate) + (constant-value-case uptr + [(snil) '()] + [(sfalse) #f] + [(strue) #f] + [(seof) #!eof] + [(sbwp) #!bwp] + [(svoid) (void)] + [else (vector 'IMMEDIATE uptr)])] + [(fasl-type-entry) (vector 'ENTRY uptr)] + [(fasl-type-library) (vector 'LIBRARY uptr)] + [(fasl-type-library-code) (vector 'LIBRARY-CODE uptr)] + [else x])] + [reloc (type-etc code-offset item-offset fasl) + (vector 'RELOC + type-etc + code-offset + item-offset + (describe fasl))] + [indirect (g i) (describe (vector-ref g i))] + [else x])) + (describe x)))) + (set-who! $fasl-strip-options (make-enumeration '(inspector-source profile-source source-annotations compile-time-information))) (set-who! $make-fasl-strip-options (enum-set-constructor $fasl-strip-options)) (let () + (define read-and-strip-from-port + (lambda (ip ifn init-g) + (let* ([script-header (read-script-header ip)] + [mode (and script-header ifn (unless-feature windows (get-mode ifn)))]) + (let loop ([rentry* '()]) + (set! fasl-count (fx+ fasl-count 1)) + (let ([entry (read-entry ip init-g)]) + (if (eof-object? entry) + (begin + (close-port ip) + (values script-header mode (reverse rentry*))) + (let ([entry (if strip-compile-time-information? (keep-revisit-info entry) entry)]) + (loop (if entry (cons entry rentry*) rentry*))))))))) (define read-and-strip-file (lambda (ifn) (let ([ip ($open-file-input-port fasl-who ifn)]) (on-reset (close-port ip) - (let* ([script-header (read-script-header ip)] - [mode (and script-header (unless-feature windows (get-mode ifn)))]) - (let loop ([rentry* '()]) - (set! fasl-count (fx+ fasl-count 1)) - (let ([entry (read-entry ip)]) - (if (eof-object? entry) - (begin - (close-port ip) - (values script-header mode (reverse rentry*))) - (let ([entry (if strip-compile-time-information? (keep-revisit-info entry) entry)]) - (loop (if entry (cons entry rentry*) rentry*))))))))))) - (set-who! strip-fasl-file - (rec strip-fasl-file - (lambda (ifn ofn options) - (unless (string? ifn) ($oops who "~s is not a string" ifn)) - (unless (string? ofn) ($oops who "~s is not a string" ofn)) - (unless (and (enum-set? options) (enum-set-subset? options $fasl-strip-options)) - ($oops who "~s is not a fasl-strip-options object" options)) - (fluid-let ([strip-inspector-information? (enum-set-subset? (fasl-strip-options inspector-source) options)] - [strip-profile-information? (enum-set-subset? (fasl-strip-options profile-source) options)] - [strip-source-annotations? (enum-set-subset? (fasl-strip-options source-annotations) options)] - [strip-compile-time-information? (enum-set-subset? (fasl-strip-options compile-time-information) options)] + (read-and-strip-from-port ip ifn #f))))) + (define convert-fasl-file + (lambda (who ifn ofn options write) + (unless (string? ifn) ($oops who "~s is not a string" ifn)) + (unless (string? ofn) ($oops who "~s is not a string" ofn)) + (unless (and (enum-set? options) (enum-set-subset? options $fasl-strip-options)) + ($oops who "~s is not a fasl-strip-options object" options)) + (fluid-let ([strip-inspector-information? (enum-set-subset? (fasl-strip-options inspector-source) options)] + [strip-profile-information? (enum-set-subset? (fasl-strip-options profile-source) options)] + [strip-source-annotations? (enum-set-subset? (fasl-strip-options source-annotations) options)] + [strip-compile-time-information? (enum-set-subset? (fasl-strip-options compile-time-information) options)] + [fasl-who who] + [fasl-count 0]) + (let-values ([(script-header mode entry*) (read-and-strip-file ifn)]) + (let ([op ($open-file-output-port who ofn (file-options replace))]) + (on-reset (delete-file ofn #f) + (on-reset (close-port op) + (write script-header mode entry* op) + (close-port op) + (unless-feature windows (when mode (chmod ofn mode)))))))))) + (set-who! $describe-fasl-from-port + (rec $describe-fasl-from-port + (case-lambda + [(ip) ($describe-fasl-from-port ip '#())] + [(ip externals) + (unless (input-port? ip) ($oops who "~s is not an input port" ip)) + (fluid-let ([strip-inspector-information? #f] + [strip-profile-information? #f] + [strip-source-annotations? #f] + [strip-compile-time-information? #f] [fasl-who who] [fasl-count 0]) - (let-values ([(script-header mode entry*) (read-and-strip-file ifn)]) - (let ([op ($open-file-output-port who ofn (file-options replace))]) - (on-reset (delete-file ofn #f) - (on-reset (close-port op) - (when script-header (put-bytevector op script-header)) - (for-each (lambda (entry) (write-entry op entry)) entry*) - (close-port op) - (unless-feature windows (when mode (chmod ofn mode))))))))))))) + (let-values ([(script-header mode entry*) (read-and-strip-from-port ip #f externals)]) + (list (and script-header (describe script-header)) + (map describe entry*))))]))) + (set-who! strip-fasl-file + (lambda (ifn ofn options) + (convert-fasl-file who ifn ofn options + (lambda (script-header mode entry* op) + (when script-header (put-bytevector op script-header)) + (for-each (lambda (entry) (write-entry op entry)) entry*))))) + (set-who! vfasl-convert-file + (lambda (ifn ofn bootfile*) + (convert-fasl-file who ifn ofn (fasl-strip-options) + (lambda (script-header mode entry* op) + (when bootfile* + ($emit-boot-header op (constant machine-type-name) bootfile*)) + (let* ([write-out + (lambda (x situation) + (let ([bv ($fasl-to-vfasl x)]) + ($write-fasl-bytevectors op (list bv) (bytevector-length bv) + ;; see "promoting" below: + (constant fasl-type-visit-revisit) + (constant fasl-type-vfasl))))] + [write-out-accum (lambda (accum situation) + (unless (null? accum) + (if (null? (cdr accum)) + (write-out (car accum) situation) + (write-out (fasl-vector (constant fasl-type-vector) + (list->vector (reverse accum))) + situation))))]) + (let loop ([ignore-header? #f] [accum '()] [accum-situation #f] [entry* entry*]) + (cond + [(null? entry*) + (write-out-accum accum accum-situation)] + [else + (handle-entry + (car entry*) + (lambda (write-k) + (unless ignore-header? + (write-k op)) + (loop #t accum accum-situation (cdr entry*))) + (lambda (situation x) + (cond + [(vector? x) + (loop #t + (append (reverse (vector->list x)) accum) + situation + (cdr entry*))] + [(or (not ($fasl-can-combine? x)) + ;; improve sharing by promiting everyting to visit-revisit, + ;; instead of comparing situations + #; + (and accum-situation + (not (eqv? accum-situation situation)))) + (write-out-accum accum accum-situation) + (write-out x situation) + (loop #t '() #f (cdr entry*))] + [else + (loop #t (cons x accum) situation (cdr entry*))])))]))))))))) (let () ; per file @@ -786,8 +1044,9 @@ (hashtable-set! gensym-table uname1 uname2) (string=? x uname2))))] [vector (ty vfasl) (and (eqv? ty1 ty2) (vandmap fasl=? vfasl1 vfasl2))] - [fxvector (ty viptr) (and (eqv? ty1 ty2) (vandmap = viptr1 viptr2))] + [fxvector (viptr) (vandmap = viptr1 viptr2)] [bytevector (ty bv) (and (eqv? ty1 ty2) (bytevector=? bv1 bv2))] + [stencil-vector (mask vfasl) (and (eqv? mask1 mask2) (vandmap fasl=? vfasl1 vfasl2))] [record (maybe-uid size nflds rtd pad-ty* fld*) (and (if maybe-uid1 (and maybe-uid2 (fasl=? maybe-uid1 maybe-uid2)) @@ -797,6 +1056,7 @@ (fasl=? rtd1 rtd2) (andmap eqv? pad-ty*1 pad-ty*2) (andmap fld=? fld*1 fld*2))] + [rtd-ref (uid) (eq? uid1 uid2)] [closure (offset c) (and (eqv? offset1 offset2) (fasl=? c1 c2))] [flonum (high low) (and (eqv? high1 high2) @@ -881,7 +1141,7 @@ (if (equal? script-header1 script-header2) (let loop () (set! fasl-count (fx+ fasl-count 1)) - (let ([entry1 (read-entry ip1)] [entry2 (read-entry ip2)]) + (let ([entry1 (read-entry ip1 #f)] [entry2 (read-entry ip2 #f)]) (if (eof-object? entry1) (or (eof-object? entry2) (and error? (bogus "~a has fewer fasl entries than ~a" ifn1 ifn2))) diff --git a/src/ChezScheme/s/syntax.ss b/src/ChezScheme/s/syntax.ss index e6d385ee6c..aa007026e3 100644 --- a/src/ChezScheme/s/syntax.ss +++ b/src/ChezScheme/s/syntax.ss @@ -501,7 +501,7 @@ (if src `(seq (profile ,src) ,e) e)) e))) -(module (build-lambda build-library-case-lambda build-case-lambda) +(module (build-lambda build-lambda/lift-barrier build-library-case-lambda build-case-lambda) (define build-clause (lambda (fmls body) (let f ((ids fmls) (n 0)) @@ -528,6 +528,12 @@ `(case-lambda ,(make-preinfo-lambda (ae->src ae)) ,(build-clause vars exp))))) + (define build-lambda/lift-barrier + (lambda (ae vars exp) + (build-profile ae + `(case-lambda ,(make-preinfo-lambda (ae->src ae) #f #f #f (constant code-flag-lift-barrier)) + ,(build-clause vars exp))))) + (define build-case-lambda (lambda (ae clauses) (build-profile ae @@ -2704,7 +2710,7 @@ (make-ctdesc import-req* visit-visit-req* visit-req* #t #t '() #f #f) (make-rtdesc invoke-req* #t (top-level-eval-hook - (build-lambda no-source '() + (build-lambda/lift-barrier no-source '() (build-library-body no-source dl* db* dv* de* (build-sequence no-source `(,@inits ,(build-void))))))))) @@ -5614,7 +5620,7 @@ (lambda (uid dl* db* dv* de* body) (build-primcall no-source 3 '$install-library/rt-code (build-data no-source uid) - (build-lambda no-source '() + (build-lambda/lift-barrier no-source '() (build-library-body no-source dl* db* dv* de* body))))) (let () @@ -6216,6 +6222,13 @@ (let-values ([(vars body) (chi-lambda-clause (source-wrap e w ae) (syntax c) r w)]) (build-lambda ae vars body)))))) +(global-extend 'core '$lambda/lift-barrier + (lambda (e r w ae) + (syntax-case e () + ((_ . c) + (let-values ([(vars body) (chi-lambda-clause (source-wrap e w ae) (syntax c) r w)]) + (build-lambda/lift-barrier ae vars body)))))) + (global-extend 'core 'case-lambda (lambda (e r w ae) (syntax-case e () @@ -6377,6 +6390,13 @@ (unless (source-object? src) (syntax-error src "profile subform is not a source object")) (build-input-profile src))]))) +(global-extend 'core 'begin-unsafe + (lambda (e r w ae) + (syntax-case e () + ((_ e1 e2 ...) + (parameterize ([optimize-level 3]) + (chi-sequence #'(e1 e2 ...) r w no-source)))))) + (global-extend 'set! 'set! '()) (global-extend 'alias 'alias '()) @@ -8914,10 +8934,14 @@ [else ($oops '$fp-type->pred "unrecognized type ~s" type)])]))) (define $filter-conv - (lambda (who conv*) + (lambda (who conv* num-args) (define squawk (lambda (x) (syntax-error x (format "invalid ~s convention" who)))) + (define check-arg-count + (lambda (n orig-c) + (unless (<= n num-args) + (syntax-error orig-c (format "invalid ~s convention with ~a arguments" who num-args))))) (let loop ([conv* conv*] [selected #f] [accum '()] [keep-accum '()]) (cond [(null? conv*) (datum->syntax #'filter-conv keep-accum)] @@ -8928,7 +8952,17 @@ (cond [(not c) (values #f #f)] [(eq? c '__collect_safe) (values 'adjust-active #f)] - [(eq? c '__varargs) (values 'varargs #f)] + [(eq? c '__varargs) + (check-arg-count 1 orig-c) + (values (cons 'varargs 1) #f)] + [(and (pair? c) (eq? (car c) '__varargs_after) + (pair? (cdr c)) (null? (cddr c)) + (let ([i (cadr c)]) + (and (integer? i) + (exact? i) + (positive? i)))) + (check-arg-count (cadr c) orig-c) + (values (cons 'varargs (cadr c)) #f)] [else (values (case ($target-machine) @@ -8944,7 +8978,8 @@ [else (squawk orig-c)])] [else (squawk orig-c)]) #t)])]) - (when (member c accum) + (when (or (member c accum) + (and (pair? c) (ormap pair? accum))) (syntax-error orig-c (format "redundant ~s convention" who))) (when (and select? selected) (syntax-error orig-c (format "conflicting ~s convention" who))) @@ -8959,16 +8994,18 @@ (define (check-strings-allowed) (when (memq 'adjust-active (syntax->datum conv*)) ($oops who "string argument not allowed with __collect_safe procedure"))) - (define (check-floats-allowed) - (when (memq 'varargs (syntax->datum conv*)) - ($oops who "float argument not allowed for __varargs procedure"))) + (define (check-floats-allowed pos) + (let ([va-n (ormap (lambda (conv) (and (pair? conv) (eq? (car conv) 'varargs) (cdr conv))) + (syntax->datum conv*))]) + (when (and va-n (>= pos va-n)) + ($oops who "single-float varargs argument not allowed")))) (with-syntax ([conv* conv*] [foreign-name foreign-name] [?foreign-addr ?foreign-addr] [(t ...) (generate-temporaries type*)]) (with-syntax ([(((check ...) (actual ...) (arg ...)) ...) (map - (lambda (type x) + (lambda (type x pos) (with-syntax ([x x]) (or (case type [(boolean) @@ -9059,7 +9096,7 @@ (err ($moi) x))))) (u32*))] [(single-float) - (check-floats-allowed) + (check-floats-allowed pos) #f] [else #f]) (if (or ($ftd? type) ($ftd-as-box? type)) @@ -9072,7 +9109,7 @@ #`(#,(if unsafe? #'() #'((unless (pred x) (err ($moi) x)))) (x) (type))))))) - type* #'(t ...))] + type* #'(t ...) (enumerate type*))] [(result-filter result) (case result-type [(boolean) #`((lambda (x) (not (eq? x 0))) @@ -9140,7 +9177,7 @@ [(_ c ... ?name (arg ...) result) (lambda (r) ($make-foreign-procedure 'foreign-procedure - ($filter-conv 'foreign-procedure #'(c ...)) + ($filter-conv 'foreign-procedure #'(c ...) (length #'(arg ...))) (let ([x (datum ?name)]) (and (string? x) x)) #'($foreign-entry ?name) (map (lambda (x) (filter-type r x #f)) #'(arg ...)) @@ -9156,13 +9193,15 @@ (define (check-strings-allowed) (when (memq 'adjust-active (syntax->datum conv*)) ($oops who "string result not allowed with __collect_safe callable"))) - (define (check-floats-allowed) - (when (memq 'varargs (syntax->datum conv*)) - ($oops who "float argument not allowed for __varargs procedure"))) + (define (check-floats-allowed pos) + (let ([va-n (ormap (lambda (conv) (and (pair? conv) (eq? (car conv) 'varargs) (cdr conv))) + (syntax->datum conv*))]) + (when (and va-n (>= pos va-n)) + ($oops who "single-float argument not allowed for __varargs procedure")))) (with-syntax ([conv* conv*] [?proc ?proc]) (with-syntax ([((actual (t ...) (arg ...)) ...) (map - (lambda (type) + (lambda (type pos) (or (case type [(boolean) (with-syntax ([(x) (generate-temporaries #'(*))]) @@ -9249,12 +9288,12 @@ (x) (unsigned-64)))] [(single-float) - (check-floats-allowed) + (check-floats-allowed pos) #f] [else #f]) (with-syntax ([(x) (generate-temporaries #'(*))]) #`(x (x) (#,(datum->syntax #'foreign-callable type)))))) - type*)] + type* (enumerate type*))] [(result-filter result [extra-arg ...] [extra ...]) (case result-type [(boolean) #`((lambda (x) (if x 1 0)) @@ -9403,7 +9442,7 @@ [(_ c ... ?proc (arg ...) result) (lambda (r) ($make-foreign-callable 'foreign-callable - ($filter-conv 'foreign-callable #'(c ...)) + ($filter-conv 'foreign-callable #'(c ...) (length #'(arg ...))) #'?proc (map (lambda (x) (filter-type r x #f)) #'(arg ...)) (filter-type r #'result #t)))]))) diff --git a/src/ChezScheme/s/tarm64osx.def b/src/ChezScheme/s/tarm64osx.def new file mode 100644 index 0000000000..07f98341c5 --- /dev/null +++ b/src/ChezScheme/s/tarm64osx.def @@ -0,0 +1,6 @@ +;;; tarm64osx.def + +(define-constant machine-type (constant machine-type-tarm64osx)) +(features iconv expeditor pthreads) +(include "arm64.def") +(include "default.def") diff --git a/src/ChezScheme/s/tppc32osx.def b/src/ChezScheme/s/tppc32osx.def new file mode 100644 index 0000000000..a8ac498945 --- /dev/null +++ b/src/ChezScheme/s/tppc32osx.def @@ -0,0 +1,9 @@ +;;; tppc32le.def + +(define-constant machine-type (constant machine-type-tppc32osx)) +(features iconv expeditor pthreads) +(define-constant max-float-alignment 4) +(define-constant max-integer-alignment 4) +(define-constant special-initial-field-alignment? #t) +(include "ppc32.def") +(include "default.def") diff --git a/src/ChezScheme/s/vfasl.ss b/src/ChezScheme/s/vfasl.ss new file mode 100644 index 0000000000..befc436ee1 --- /dev/null +++ b/src/ChezScheme/s/vfasl.ss @@ -0,0 +1,1092 @@ +;; vfasl conversion uses the + + +(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)])])) + +;; ************************************************************ +;; Encode-time data structures */ + +;; During encoding, we use a bytevector per vspace on first pass, +;; single shared bytevector on the second pass +(define-record-type vfasl-chunk + (fields (mutable bv) + (mutable offset) ; offset into bv + (mutable alloc) ; allocation pointer; implies size + limit) ; #f or a sanity-check limit + (nongenerative)) + +(define-record-type vfasl-info + (fields (mutable bv) + + (mutable base-addr) ; index within bv to make pointers and relocations relative to + + (mutable sym-count) + + (mutable symref-count) + (mutable symrefs) ; offset into bv + + (mutable rtdref-count) + (mutable rtdrefs) ; offset into bv + + (mutable singletonref-count) + (mutable singletonrefs) ; offset into bv + + spaces ; vector of vfasl-chunk + + (mutable ptr-bitmap) ; #f or offset into bv + + (mutable graph) + (mutable base-rtd) ; write base-rtd only once + + (mutable symbols) ; intern symbols (because multiple fasl blocks may be combined) + (mutable rtds) ; intern rtds (same reason) + (mutable strings) ; intern certain strings (for code names) + + (mutable installs-library-entry?)) ; to determine whether vfasls can be combined + (nongenerative)) + +(define (new-vfasl-info) + (make-vfasl-info #f + + 0 + 0 ; sym-count + + 0 ;symref-count + #f + + 0 ; rtdref-count + #f + + 0 ; singletonref-count + #f + + (list->vector + (let loop ([i 0]) + (if (fx= i (constant vspaces-count)) + '() + (cons (make-vfasl-chunk '#vu8() 0 0 #f) + (loop (fx+ i 1)))))) + #f ; ptr-bitmap + + (make-eq-hashtable) + #f + (make-eq-hashtable) + (make-eq-hashtable) + (make-hashtable string-hash string=?) + + #f)) ; installs-library-entry? + +;; Creates a vfasl image for the fasl content `v` (as read by "strip.ss") +(define (to-vfasl v) + (let ([v (ensure-reference v)] + [vfi (new-vfasl-info)]) + ;; First pass: determine sizes + (copy v vfi) + + ;; Setup for second pass: allocate to contiguous bytes + (let* ([data-size (let loop ([i 0]) + (if (fx= i (constant vspaces-count)) + 0 + (fx+ (vfasl-chunk-alloc + (vector-ref (vfasl-info-spaces vfi) i)) + (loop (fx+ i 1)))))] + [table-size (fx+ (fx* (vfasl-info-symref-count vfi) (constant ptr-bytes)) + (fx* (vfasl-info-rtdref-count vfi) (constant ptr-bytes)) + (fx* (vfasl-info-singletonref-count vfi) (constant ptr-bytes)))] + [bitmap-size (fxsra (fx+ data-size (fx- (constant byte-bits) 1)) (constant log2-byte-bits))] + [size (fx+ (constant size-vfasl-header) + data-size + table-size + bitmap-size)] + [bv (make-bytevector size 0)]) + (vfasl-info-bv-set! vfi bv) + + ;; write header, except for result offset and table size: + (set-uptr! bv (constant vfasl-header-data-size-disp) data-size) + (let loop ([i 1] [offset (vfasl-chunk-alloc + (vector-ref (vfasl-info-spaces vfi) 0))]) + (unless (fx= i (constant vspaces-count)) + (set-uptr! bv + (fx+ (constant vfasl-header-vspace-rel-offsets-disp) + (fx* (fx- i 1) (constant ptr-bytes))) + offset) + (loop (fx+ i 1) (fx+ offset (vfasl-chunk-alloc + (vector-ref (vfasl-info-spaces vfi) i)))))) + (set-uptr! bv (constant vfasl-header-symref-count-disp) (vfasl-info-symref-count vfi)) + (set-uptr! bv (constant vfasl-header-rtdref-count-disp) (vfasl-info-rtdref-count vfi)) + (set-uptr! bv (constant vfasl-header-singletonref-count-disp) (vfasl-info-singletonref-count vfi)) + + (let ([base-addr (constant size-vfasl-header)]) + (vfasl-info-base-addr-set! vfi base-addr) + + (let* ([p + ;; Set pointers to vspaces based on sizes from first pass + (let loop ([i 0] [p base-addr]) + (if (fx= i (constant vspaces-count)) + p + (let ([len (vfasl-chunk-alloc + (vector-ref (vfasl-info-spaces vfi) i))]) + (vector-set! (vfasl-info-spaces vfi) i (make-vfasl-chunk bv p 0 len)) + (loop (fx+ i 1) (fx+ p len)))))] + [p (begin + (vfasl-info-symrefs-set! vfi p) + (fx+ p (fx* (vfasl-info-symref-count vfi) (constant ptr-bytes))))] + [p (begin + (vfasl-info-rtdrefs-set! vfi p) + (fx+ p (fx* (vfasl-info-rtdref-count vfi) (constant ptr-bytes))))] + [p (begin + (vfasl-info-singletonrefs-set! vfi p) + (fx+ p (fx* (vfasl-info-singletonref-count vfi) (constant ptr-bytes))))] + [bm p]) + (vfasl-info-ptr-bitmap-set! vfi bm) + + (vfasl-info-sym-count-set! vfi 0) + (vfasl-info-symref-count-set! vfi 0) + (vfasl-info-rtdref-count-set! vfi 0) + (vfasl-info-singletonref-count-set! vfi 0) + (vfasl-info-graph-set! vfi (make-eq-hashtable)) + (vfasl-info-base-rtd-set! vfi #f) + + ;; Write data + (let ([v (copy v vfi)]) + (let-values ([(bv offset) (vptr->bytevector+offset v vfi)]) + (set-iptr! bv (constant vfasl-header-result-offset-disp) (- offset base-addr))) + + ;; We can ignore trailing zeros in the bitmap: + (let* ([zeros (let loop ([bmp (fx+ bm bitmap-size)] [zeros 0]) + (cond + [(fx= bmp bm) zeros] + [(fx= 0 (bytevector-u8-ref bv (fx- bmp 1))) + (loop (fx- bmp 1) (fx+ zeros 1))] + [else zeros]))] + [table-size (fx+ table-size (fx- bitmap-size zeros))]) + (set-uptr! bv (constant vfasl-header-table-size-disp) table-size) + ;; Truncate bytevector to match end of bitmaps + (bytevector-truncate! bv (fx- size zeros))) + + (sort-offsets! bv (vfasl-info-symrefs vfi) (vfasl-info-symref-count vfi)) + (sort-offsets! bv (vfasl-info-rtdrefs vfi) (vfasl-info-rtdref-count vfi)) + (sort-offsets! bv (vfasl-info-singletonrefs vfi) (vfasl-info-singletonref-count vfi)) + + bv)))))) + +;; If compiled code uses `$install-library-entry`, then it can't be +;; combined into a single vfasled object, because the installation +;; needs to be evaluated for laster vfasls. Recognize a non-combinable +;; value as anything that references the C entry or even mentions the +;; symbol `$install-library-entry` (as defined in "library.ss"). If +;; non-boot code mentions the symbol `$install-library-entry`, it just +;; isn't as optimal. +;; +;; This is an expensive test, since we perform half of a vfasl +;; encoding to look for `$install-library-entry`. */ +(define (fasl-can-combine? v) + (let ([vfi (new-vfasl-info)]) + ;; Run a "first pass" + (copy v vfi) + (not (vfasl-info-installs-library-entry? vfi)))) + +;; Box certain kinds of values (including singletons) where the vfasl +;; process needs a pointer into data +(define (ensure-reference v) + (define (enbox v) + (fasl-tuple (constant fasl-type-box) (vector v))) + (define (enbox-fixnum n) + (if (<= (constant most-negative-fixnum) n (constant most-positive-fixnum)) + (enbox v) + v)) + (fasl-case* v + [(atom ty uptr) + (constant-case* ty + [(fasl-type-immediate fasl-type-base-rtd) (enbox v)] + [else v])] + [(small-integer iptr) (enbox-fixnum iptr)] + [(large-integer sign vuptr) (enbox-fixnum (build-exact-integer sign vuptr))] + [(tuple ty vec) + (constant-case* ty + [(fasl-type-box) (enbox v)] + [else v])] + [(string ty string) + (constant-case* ty + [(fasl-type-symbol) (enbox v)] + [else + (if (fx= 0 (string-length string)) + (enbox v) + v)])] + [(vector ty vec) + (if (fx= 0 (vector-length vec)) + (enbox v) + v)] + [(fxvector vec) + (if (fx= 0 (vector-length vec)) + (enbox v) + v)] + [(bytevector ty bv) + (if (fx= 0 (bytevector-length bv)) + (enbox v) + v)] + [(record maybe-uid size nflds rtd pad-ty* fld*) + (enbox v)] + [else v])) + +;; quicksort on uptrs within a bytevector +(define (sort-offsets! bv offset len) + (define (uref i) + (ref-uptr bv (fx+ offset (fx* i (constant ptr-bytes))))) + (define (uset! i v) + (set-uptr! bv (fx+ offset (fx* i (constant ptr-bytes))) v)) + (when (fx> len 1) + (let* ([mid (fxsra len 1)] + [tmp (uref mid)]) + (uset! mid (uref 0)) + (uset! 0 tmp)) + (let ([p-val (uref 0)]) + (let loop ([i 1] [pivot 0]) + (cond + [(fx= i len) + (uset! pivot p-val) + (sort-offsets! bv offset pivot) + (sort-offsets! bv (fx+ offset (fx* (fx+ pivot 1) (constant ptr-bytes))) (fx- len pivot 1))] + [(< (uref i) p-val) + (uset! pivot (uref i)) + (let ([pivot (fx+ pivot 1)]) + (uset! i (uref pivot)) + (loop (fx+ i 1) pivot))] + [else + (loop (fx+ i 1) pivot)]))))) + +;; ---------------------------------------- + +;; A vptr represents a pointer to an object allocated in a vfasl image. +;; A vsingleton represents a pointer to a single (not in the image). +;; A number a pointer represents a literal pointer, such as a fixnum or immediate. + +(define (make-vptr v vspace) (cons v vspace)) +(define (make-vsingleton n) (cons n 'singleton)) + +(define (vptr? v) (and (pair? v) (not (eq? (cdr v) 'singleton)))) +(define (vptr-v v) (car v)) +(define (vptr-vspace v) (cdr v)) +(define (vptr+ v offset) (make-vptr (fx+ (vptr-v v) offset) (vptr-vspace v))) + +(define (vsingleton? v) (and (pair? v) (eq? (cdr v) 'singleton))) +(define (vsingleton-index v) (car v)) + +(define (segment-start? sz) + (fxzero? (fxand sz (fx- (constant bytes-per-segment) 1)))) +(define (segment-truncate sz) + (fxand sz (fxnot (fx- (constant bytes-per-segment) 1)))) + +;; Allocate into the given vspace in a vfasl image. The result +;; is just the `v` part of a vptr (because it's easier to do arithmetic +;; with that to initialize the item). +(define (find-room who vfi vspc n type) + (let ([n (c-alloc-align n)] + [vc (vector-ref (vfasl-info-spaces vfi) vspc)]) + (constant-case* vspc + [(vspace-symbol vspace-impure-record) + ;; For these spaces, in case they will be loaded into the static + ;; generation, objects must satisfy an extra constraint: an object + ;; must not span segments unless it's at the start of a + ;; segment + (let ([sz (vfasl-chunk-alloc vc)]) + (unless (segment-start? sz) + ;; Since we're not at the start of a segment, don't let an + ;; object span a segment + (when (and (not (fx= (segment-truncate sz) (segment-truncate (fx+ sz n)))) + (not (segment-start? (fx+ sz n)))) + ;; Skip to next segment + (vfasl-chunk-alloc-set! vc (segment-truncate (fx+ sz n))))))] + [else (void)]) + (let* ([sz (vfasl-chunk-alloc vc)] + [new-sz (fx+ sz n)] + [limit (vfasl-chunk-limit vc)]) + (when (and limit + (fx> new-sz limit)) + ($oops 'vfasl "allocation overrun")) + (when (fx< (bytevector-length (vfasl-chunk-bv vc)) new-sz) + (let ([bv (make-bytevector (fx+ (if (fxzero? sz) + (constant bytes-per-segment) + (fx* 2 (bytevector-length (vfasl-chunk-bv vc)))) + (segment-truncate n)))]) + (bytevector-copy! (vfasl-chunk-bv vc) 0 bv 0 sz) + (vfasl-chunk-bv-set! vc bv))) + (vfasl-chunk-alloc-set! vc new-sz) + (make-vptr (fx- sz (fx- (constant typemod) type)) + vspc)))) + +(define vptr->bytevector+offset + (case-lambda + [(p vfi) (vptr->bytevector+offset p 0 vfi)] + [(p delta vfi) + (let ([vc (vector-ref (vfasl-info-spaces vfi) (vptr-vspace p))]) + (values (vfasl-chunk-bv vc) (fx+ (vfasl-chunk-offset vc) (vptr-v p) delta)))])) + +;; Overloaded to either set in a bytevector or set in a vfasl image: +(define set-uptr! + (case-lambda + [(bv i uptr) + (constant-case ptr-bytes + [(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))])) + +;; Overloaded in the same way as `set-uptr!` +(define ref-uptr + (case-lambda + [(bv i) + (constant-case ptr-bytes + [(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))])) + +;; Overloaded in the same way as `set-uptr!` +(define set-iptr! + (case-lambda + [(bv i uptr) + (constant-case ptr-bytes + [(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))])) + +;; Overloaded in the same way as `set-uptr!` +(define set-double! + (case-lambda + [(bv i dbl) + (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))])) + +;; Overloaded in the same way as `set-uptr!` +(define set-char! + (case-lambda + [(bv i char) + (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 (constant native-endianness))]))] + [(p delta char vfi) + (let-values ([(bv offset) (vptr->bytevector+offset p delta vfi)]) + (set-char! bv offset char))])) + +(define set-u8! + (case-lambda + [(p delta u8 vfi) + (let-values ([(bv offset) (vptr->bytevector+offset p delta vfi)]) + (bytevector-u8-set! bv offset u8))])) + +(define (copy-u8s! p delta bv bv-off len vfi) + (let-values ([(dest-bv offset) (vptr->bytevector+offset p delta vfi)]) + (bytevector-copy! bv bv-off dest-bv offset len))) + +;; Overloaded in the same way as `set-uptr!` +(define set-bigit! + (case-lambda + [(bv i bigit) + (constant-case bigit-bytes + [(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))])) + +;; Sets a pointer in a vfasl image, and optionally records the reference. +;; The pointer is written as a relative offset, and then it will get +;; adjusted when the vfasl image is loaded. +(define (do-set-ptr! at-p delta p vfi record?) + (let* ([vc (vector-ref (vfasl-info-spaces vfi) (vptr-vspace at-p))] + [rel-v (fx- (fx+ (vptr-v at-p) delta (vfasl-chunk-offset vc)) + (vfasl-info-base-addr vfi))]) + (define (register! vfasl-info-ref-count + vfasl-info-ref-count-set! + vfasl-info-refs) + (unless record? ($oops 'vfasl "expected to record ptr")) + (let ([c (vfasl-info-ref-count vfi)] + [refs (vfasl-info-refs vfi)]) + (vfasl-info-ref-count-set! vfi (fx+ c 1)) + (when refs + (set-uptr! (vfasl-info-bv vfi) (fx+ refs (fx* c (constant ptr-bytes))) rel-v)))) + (let ([val (cond + [(vptr? p) + (let* ([p-vspc (vptr-vspace p)] + [p-vc (vector-ref (vfasl-info-spaces vfi) p-vspc)]) + (constant-case* p-vspc + [(vspace-symbol) + (when record? + (register! vfasl-info-symref-count + vfasl-info-symref-count-set! + vfasl-info-symrefs)) + ;; symbol reference are not registered in the bitmap, + ;; and the reference is as an index instead of address offset + (fix (symbol-vptr->index p vfi))] + [else + (when record? + (when (eqv? p-vspc (constant vspace-rtd)) + (register! vfasl-info-rtdref-count + vfasl-info-rtdref-count-set! + vfasl-info-rtdrefs)) + (let ([bm (vfasl-info-ptr-bitmap vfi)]) + (when bm + (safe-assert (fxzero? (fxand rel-v (fx- (constant ptr-bytes) 1)))) + (let* ([w-rel-b (fxsra rel-v (constant log2-ptr-bytes))] + [i (fx+ bm (fxsra w-rel-b (constant log2-byte-bits)))] + [bit (fxsll 1 (fxand w-rel-b (fx- (constant byte-bits) 1)))] + [bv (vfasl-info-bv vfi)]) + (bytevector-u8-set! bv i (fxior (bytevector-u8-ref bv i) bit)))))) + (fx- (fx+ (vptr-v p) (vfasl-chunk-offset p-vc)) + (vfasl-info-base-addr vfi))]))] + [(vsingleton? p) + (register! vfasl-info-singletonref-count + vfasl-info-singletonref-count-set! + vfasl-info-singletonrefs) + (fix (vsingleton-index p))] + [else p])]) + (set-iptr! at-p delta val vfi)))) + +(define (set-ptr! at-p delta p vfi) (do-set-ptr! at-p delta p vfi #t)) +(define (set-ptr!/no-record at-p delta p vfi) (do-set-ptr! at-p delta p vfi #f)) + +(define (symbol-vptr->index p vfi) + ;; There may be leftover space at the end of each segment containing symbols, + ;; we we have to compensate for that + (let* ([vc (vector-ref (vfasl-info-spaces vfi) (constant vspace-symbol))] + [offset (fx+ (vptr-v p) (fx- (constant typemod) (constant type-symbol)))] + [seg (quotient offset (constant bytes-per-segment))]) + (fx+ (fx* seg (quotient (constant bytes-per-segment) (constant size-symbol))) + (fxquotient (fx- offset (fx* seg (constant bytes-per-segment))) (constant size-symbol))))) + +(define (build-exact-integer sign vuptr) + (let loop ([v 0] [i 0]) + (cond + [(fx= i (vector-length vuptr)) + (if (eqv? sign 1) (- v) v)] + [else (loop (bitwise-ior (bitwise-arithmetic-shift v (constant bigit-bits)) + (vector-ref vuptr i)) + (fx+ i 1))]))) + +(define (build-flonum high low) + (let ([bv (make-bytevector 8)]) + (bytevector-u64-native-set! bv 0 (bitwise-ior low (bitwise-arithmetic-shift high 32))) + (bytevector-ieee-double-native-ref bv 0))) + +(define (unpack-flonum v) + (fasl-case* v + [(flonum high low) (build-flonum high low)] + [else ($oops 'vfasl "expected a flonum")])) + +(define (unpack-symbol v) + (or (fasl-case* v + [(string ty string) + (if (eq? ty (constant fasl-type-symbol)) + (string->symbol string) + #f)] + [(gensym pname uname) (gensym pname uname)] + [else #f]) + (error 'vfasl "expected a symbol: ~s" v))) + +;; ---------------------------------------- + +(define rtd-flds (csv7:record-field-accessor #!base-rtd 'flds)) + +(define (fix v) + (bitwise-arithmetic-shift-left v (constant fixnum-offset))) +(define (fixed? v) + (fxzero? (bitwise-and v (sub1 (fxsll 1 (constant fixnum-offset)))))) + +(define (graph! v new-p vfi) + (eq-hashtable-set! (vfasl-info-graph vfi) v new-p)) + +(define (copy v vfi) + (or (eq-hashtable-ref (vfasl-info-graph vfi) v #f) + (do-copy v vfi))) + +(define (do-copy v vfi) + (fasl-case* v + [(atom ty uptr) + (constant-case* ty + [(fasl-type-immediate) uptr] + [(fasl-type-entry fasl-type-library fasl-type-library-code) + ($oops 'vfasl "expected only in a relocation: ~s" v)] + [else ($oops 'vfasl "unknown atom: ~s" v)])] + [(small-integer iptr) (exact-integer-copy v iptr vfi)] + [(large-integer sign vuptr) + (exact-integer-copy v (build-exact-integer sign vuptr) vfi)] + [(flonum high low) + (let ([new-p (find-room 'flonum vfi + (constant vspace-data) + (constant size-flonum) + (constant type-flonum))]) + (graph! v new-p vfi) + (set-double! new-p (constant flonum-data-disp) (build-flonum high low) vfi) + new-p)] + [(pair vec) + (let ([len (vector-length vec)] + [vspc (constant vspace-impure)]) + (cond + [(fx= len 1) (copy (vector-ref vec 0) vfi)] + [else + ;; can't just use `pair-copy` for initial pair, because we need + ;; to set up the graph: + (let ([new-p (find-room 'pair vfi + (constant vspace-impure) + (constant size-pair) + (constant type-pair))]) + (graph! v new-p vfi) + (set-ptr! new-p (constant pair-car-disp) (copy (vector-ref vec 0) vfi) vfi) + (let ([d (let loop ([i 1]) + (let ([e (copy (vector-ref vec i) vfi)] + [i (fx+ i 1)]) + (if (fx= i len) + e + (pair-copy e (loop i) vfi))))]) + (set-ptr! new-p (constant pair-cdr-disp) d vfi) + new-p))]))] + [(tuple ty vec) + (constant-case* ty + [(fasl-type-base-rtd) (base-rtd-copy v vfi)] + [(fasl-type-box fasl-type-immutable-box) + (let ([new-p (find-room 'box vfi + (constant vspace-impure) + (constant size-box) + (constant type-typed-object))]) + (graph! v new-p vfi) + (set-uptr! new-p (constant box-type-disp) + (if (eqv? ty (constant fasl-type-immutable-box)) + (constant type-immutable-box) + (constant type-box)) + vfi) + (set-ptr! new-p (constant box-ref-disp) (copy (vector-ref vec 0) vfi) vfi) + new-p)] + [(fasl-type-ratnum) + (let ([new-p (find-room 'ratnum vfi + (constant vspace-impure) + (constant size-ratnum) + (constant type-typed-object))]) + (graph! v new-p vfi) + (set-uptr! new-p (constant ratnum-type-disp) (constant type-ratnum) vfi) + (set-ptr! new-p (constant ratnum-numerator-disp) (copy (vector-ref vec 0) vfi) vfi) + (set-ptr! new-p (constant ratnum-denominator-disp) (copy (vector-ref vec 1) vfi) vfi) + new-p)] + [(fasl-type-exactnum) + (let ([new-p (find-room 'exactnum vfi + (constant vspace-impure) + (constant size-exactnum) + (constant type-typed-object))]) + (graph! v new-p vfi) + (set-uptr! new-p (constant exactnum-type-disp) (constant type-exactnum) vfi) + (set-ptr! new-p (constant exactnum-real-disp) (copy (vector-ref vec 0) vfi) vfi) + (set-ptr! new-p (constant exactnum-imag-disp) (copy (vector-ref vec 1) vfi) vfi) + new-p)] + [(fasl-type-inexactnum) + (let ([new-p (find-room 'inexactnum vfi + (constant vspace-data) + (constant size-inexactnum) + (constant type-typed-object))]) + (graph! v new-p vfi) + (set-uptr! new-p (constant inexactnum-type-disp) (constant type-inexactnum) vfi) + (set-double! new-p (constant inexactnum-real-disp) (unpack-flonum (vector-ref vec 0)) vfi) + (set-double! new-p (constant inexactnum-imag-disp) (unpack-flonum (vector-ref vec 1)) vfi) + new-p)] + [(fasl-type-weak-pair) + ($oops 'vfasl "weak pair not supported")] + [(fasl-type-ephemeron) + ($oops 'vfasl "ephemeron pair not supported")] + [else + ($oops 'vfasl "unrecognized tuple type")])] + [(string ty string) + (constant-case* ty + [(fasl-type-symbol) + (when (string=? string "$install-library-entry") + (vfasl-info-installs-library-entry?-set! vfi #t)) + (symbol-copy v + (string-copy string vfi) + (string->symbol string) + vfi)] + [else + (let ([immutable? (eqv? ty (constant fasl-type-immutable-string))]) + (cond + [(fx= 0 (string-length string)) + (make-vsingleton (if immutable? + (constant singleton-null-immutable-string) + (constant singleton-null-string)))] + [else + (vector-copy v string vfi + string-length + vspace-data + header-size-string string-data-disp + string-char-bytes + (bitwise-ior (bitwise-arithmetic-shift-left (string-length string) (constant string-length-offset)) + (if immutable? + (constant string-immutable-flag) + 0) + (constant type-string)) + string-type-disp + set-char! + string-ref)]))])] + [(gensym pname uname) + (symbol-copy v (pair-copy (string-copy uname vfi) (string-copy pname vfi) vfi) (gensym pname uname) vfi)] + [(vector ty vec) + (cond + [(fx= 0 (vector-length vec)) + (make-vsingleton (constant-case* ty + [(fasl-type-vector) + (constant singleton-null-vector)] + [(fasl-type-immutable-vector) + (constant singleton-null-immutable-vector)] + [(fasl-type-flvector) + (constant singleton-null-flvector)]))] + [else + (constant-case* ty + [(fasl-type-vector fasl-type-immutable-vector) + (vector-copy v vec vfi + vector-length + vspace-impure + header-size-vector vector-data-disp + ptr-bytes + (bitwise-ior (bitwise-arithmetic-shift-left (vector-length vec) (constant vector-length-offset)) + (if (eqv? ty (constant fasl-type-immutable-vector)) + (constant vector-immutable-flag) + 0) + (constant type-vector)) + vector-type-disp + set-ptr! + (lambda (vec i) (copy (vector-ref vec i) vfi)))] + [(fasl-type-flvector) + (vector-copy v vec vfi + vector-length + vspace-data + header-size-flvector flvector-data-disp + double-bytes + (bitwise-ior (bitwise-arithmetic-shift-left (vector-length vec) (constant flvector-length-offset)) + (constant type-flvector)) + flvector-type-disp + set-double! + (lambda (v i) (unpack-flonum (vector-ref v i))))])])] + [(fxvector vec) + (cond + [(fx= 0 (vector-length vec)) + (make-vsingleton (constant singleton-null-fxvector))] + [else + (vector-copy v vec vfi + vector-length + vspace-data + header-size-fxvector fxvector-data-disp + ptr-bytes + (bitwise-ior (bitwise-arithmetic-shift-left (vector-length v) (constant fxvector-length-offset)) + (constant type-fxvector)) + fxvector-type-disp + set-iptr! + (lambda (v i) (fix (vector-ref v i))))])] + [(bytevector ty bv) + (cond + [(fx= 0 (bytevector-length bv)) + (make-vsingleton (if (eqv? ty (constant fasl-type-immutable-bytevector)) + (constant singleton-null-immutable-bytevector) + (constant singleton-null-bytevector)))] + [else + (vector-copy v bv vfi + bytevector-length + vspace-data + header-size-bytevector bytevector-data-disp + byte-bytes + (bitwise-ior (bitwise-arithmetic-shift-left (bytevector-length bv) (constant bytevector-length-offset)) + (if (eqv? ty (constant fasl-type-immutable-bytevector)) + (constant bytevector-immutable-flag) + 0) + (constant type-bytevector)) + bytevector-type-disp + set-u8! + bytevector-u8-ref)])] + [(stencil-vector mask vec) + (vector-copy v vec vfi + vector-length + vspace-impure + header-size-stencil-vector stencil-vector-data-disp + ptr-bytes + (bitwise-ior (bitwise-arithmetic-shift-left mask (constant stencil-vector-mask-offset)) + (constant type-stencil-vector)) + stencil-vector-type-disp + set-ptr! + (lambda (v i) (copy (vector-ref v i) vfi)))] + [(record maybe-uid size nflds rtd pad-ty* fld*) + (cond + [(refers-back-to-self? v rtd) + (base-rtd-copy v vfi)] + [(and maybe-uid + (let ([v2 (eq-hashtable-ref (vfasl-info-rtds vfi) (unpack-symbol maybe-uid) v)]) + (and (not (eq? v2 v)) + v2))) + => (lambda (v2) + (copy v2 vfi))] + [else + (let ([rtd-p (copy rtd vfi)]) + (when maybe-uid + (eq-hashtable-set! (vfasl-info-rtds vfi) (unpack-symbol maybe-uid) v) + ;; make sure parent type is earlier + (for-each (lambda (fld) + (field-case (car fld*) + [ptr (elem) (copy elem vfi)] + [else (void)])) + fld*)) + (let* ([vspc (cond + [maybe-uid + (constant vspace-rtd)] + [(eqv? 0 (let-values ([(bv offset) (vptr->bytevector+offset rtd-p vfi)]) + (ref-uptr bv (fx+ offset (constant record-type-mpm-disp))))) + (constant vspace-pure-typed)] + [else + (constant vspace-impure-record)])] + [new-p (find-room 'record vfi vspc size (constant type-typed-object))]) + (graph! v new-p vfi) + (set-ptr! new-p (constant record-type-disp) rtd-p vfi) + (let loop ([addr (constant record-data-disp)] + [pad-ty* pad-ty*] + [fld* fld*]) + (unless (null? pad-ty*) + (let* ([pad-ty (car pad-ty*)] + [addr (fx+ addr (fxsrl pad-ty 4))] + [addr (field-case (car fld*) + [ptr (elem) + (safe-assert (eqv? (fxand pad-ty #xF) (constant fasl-fld-ptr))) + (set-ptr! new-p addr (copy elem vfi) vfi) + (fx+ addr (constant ptr-bytes))] + [iptr (elem) + (set-iptr! new-p addr elem vfi) + (fx+ addr (constant ptr-bytes))] + [double (high low) + (safe-assert (eqv? (fxand pad-ty #xF) (constant fasl-fld-double))) + (set-double! new-p addr + (build-flonum high low) + vfi) + (fx+ addr (constant double-bytes))] + [else + (error 'vfasl "unsupported field: ~s" (car fld*))])]) + (loop addr (cdr pad-ty*) (cdr fld*))))) + new-p))])] + [(closure offset c) + (let* ([c-v (copy c vfi)] + [new-p (find-room 'closure vfi + (constant vspace-closure) + (constant header-size-closure) + (constant type-closure))]) + (graph! v new-p vfi) + (set-ptr!/no-record new-p (constant closure-code-disp) (vptr+ c-v offset) vfi) + new-p)] + [(code flags free name arity-mask info pinfo* bytes m vreloc) + (let* ([len (bytevector-length bytes)] + [new-p (find-room 'code vfi + (constant vspace-code) + (fx+ (constant header-size-code) len) + (constant type-typed-object))]) + (graph! v new-p vfi) + (set-uptr! new-p (constant code-type-disp) + (bitwise-ior (bitwise-arithmetic-shift-left flags (constant code-flags-offset)) + (constant type-code)) + vfi) + (set-uptr! new-p (constant code-length-disp) len vfi) + (set-ptr! new-p (constant code-name-disp) + (fasl-case* name + [(string ty string) + ;; imitate string interning that fasl read performs: + (if (or (eqv? ty (constant fasl-type-string)) + (eqv? ty (constant fasl-type-immutable-string))) + (string-copy string vfi) + (copy name vfi))] + [else (copy name vfi)]) + vfi) + (set-ptr! new-p (constant code-arity-mask-disp) (copy arity-mask vfi) vfi) + (set-uptr! new-p (constant code-closure-length-disp) free vfi) + (set-ptr! new-p (constant code-info-disp) (copy info vfi) vfi) + (set-ptr! new-p (constant code-pinfo*-disp) (copy pinfo* vfi) vfi) + (copy-u8s! new-p (constant code-data-disp) bytes 0 len vfi) + ;; must be after code is copied into place: + (set-ptr!/no-record new-p (constant code-reloc-disp) (copy-reloc m vreloc new-p vfi) vfi) + new-p)] + [(symbol-hashtable mutable? minlen subtype veclen vpfasl) + (let* ([flds (rtd-flds $symbol-ht-rtd)] + [len (fx* (length flds) (constant ptr-bytes))] + [new-p (find-room 'symbol-ht vfi + (constant vspace-impure) + (fx+ (constant header-size-record) len) + (constant type-typed-object))] + [vec-p (find-room 'symbol-ht-vector vfi + (constant vspace-impure) + (fx+ (constant header-size-vector) (fx* veclen (constant ptr-bytes))) + (constant type-typed-object))] + [equiv (case subtype + [(0) (make-vsingleton (constant singleton-eq))] + [(1) (make-vsingleton (constant singleton-eqv))] + [(2) (make-vsingleton (constant singleton-equal))] + [(3) (make-vsingleton (constant singleton-symbol=?))] + [else ($oops 'vfasl "unrecognized symbol table subtype ~s" subtype)])]) + (define (field-offset name) + (let loop ([flds flds] [addr (constant record-data-disp)]) + (cond + [(null? flds) ($oops 'vfasl "could not find symbol hash table field ~s" name)] + [(eq? (fld-name (car flds)) name) addr] + [else (loop (cdr flds) (fx+ addr (constant ptr-bytes)))]))) + (graph! v new-p vfi) + (set-ptr! new-p (constant record-type-disp) (make-vsingleton (constant singleton-symbol-ht-rtd)) vfi) + (set-ptr! new-p (field-offset 'type) (make-vsingleton (constant singleton-symbol-symbol)) vfi) + (set-ptr! new-p (field-offset 'mutable?) (if mutable? (constant strue) (constant sfalse)) vfi) + (set-ptr! new-p (field-offset 'vec) vec-p vfi) + (set-ptr! new-p (field-offset 'minlen) (fix minlen) vfi) + (set-ptr! new-p (field-offset 'size) (fix (vector-length vpfasl)) vfi) + (set-ptr! new-p (field-offset 'equiv?) equiv vfi) + (set-uptr! vec-p (constant vector-type-disp) + (bitwise-ior (bitwise-arithmetic-shift-left veclen (constant vector-length-offset)) + (constant type-vector)) + vfi) + (let ([to-vec (make-vector veclen (constant snil))]) + ;; first, determine what goes in each vector slot, building up + ;; pair copies for the vector slots: + (vector-for-each (lambda (p) + (let* ([a (copy (car p) vfi)] + [b (copy (cdr p) vfi)] + [hc (or (fasl-case* (car p) + [(string ty string) + (and (eqv? ty (constant fasl-type-symbol)) + (target-symbol-hash (string->symbol string)))] + [(gensym pname uname) + (target-symbol-hash (gensym pname uname))] + [else #f]) + ($oops 'vfasl "symbol table key not a symbol ~s" (car p)))] + [i (fxand hc (fx- veclen 1))]) + (vector-set! to-vec i (pair-copy (pair-copy a b vfi) (vector-ref to-vec i) vfi)))) + vpfasl) + ;; install the vector slots: + (let loop ([i 0]) + (unless (fx= i veclen) + (set-ptr! vec-p (fx+ (constant vector-data-disp) (fx* i (constant ptr-bytes))) + (vector-ref to-vec i) + vfi) + (loop (fx+ i 1))))) + new-p)] + [(indirect g i) (copy (vector-ref g i) vfi)] + [else + ($oops 'vfasl "unsupported ~s" v)])) + +(define-syntax (vector-copy stx) + (syntax-case stx () + [(_ v vec vfi + vec-length + vspace + header-size-vec data-disp + elem-bytes + tag + vec-type-disp + set-elem! + vec-ref) + #'(let* ([len (vec-length vec)] + [new-p (find-room 'vec-type-disp vfi + (constant vspace) + (fx+ (constant header-size-vec) (fx* len (constant elem-bytes))) + (constant type-typed-object))]) + (graph! v new-p vfi) + (set-uptr! new-p (constant vec-type-disp) tag vfi) + (let loop ([i 0]) + (unless (fx= i len) + (set-elem! new-p (fx+ (constant data-disp) (fx* i (constant elem-bytes))) + (vec-ref vec i) + vfi) + (loop (fx+ i 1)))) + new-p)])) + +(define (symbol-copy v name sym vfi) + (let ([v2 (eq-hashtable-ref (vfasl-info-symbols vfi) sym v)]) + (cond + [(not (eq? v v2)) + (copy v2 vfi)] + [else + (eq-hashtable-set! (vfasl-info-symbols vfi) sym v) + (let ([new-p (find-room 'symbol vfi + (constant vspace-symbol) + (constant size-symbol) + (constant type-symbol))]) + (graph! v new-p vfi) + (set-uptr! new-p (constant symbol-value-disp) + ;; use value slot to store symbol index + (fix (symbol-vptr->index new-p vfi)) + vfi) + (set-uptr! new-p (constant symbol-pvalue-disp) (constant snil) vfi) + (set-uptr! new-p (constant symbol-plist-disp) (constant snil) vfi) + (set-ptr! new-p (constant symbol-name-disp) name vfi) + (set-uptr! new-p (constant symbol-splist-disp) (constant snil) vfi) + (set-iptr! new-p (constant symbol-hash-disp) (fix (target-symbol-hash sym)) vfi) + new-p)]))) + +(define target-symbol-hash + (let ([symbol-hashX (constant-case ptr-bits + [(32) (foreign-procedure "(cs)symbol_hash32" (ptr) integer-32)] + [(64) (foreign-procedure "(cs)symbol_hash64" (ptr) integer-64)])]) + (lambda (s) + (bitwise-and (symbol-hashX (if (gensym? s) + (gensym->unique-string s) + (symbol->string s))) + (constant most-positive-fixnum))))) + +(define (string-copy name vfi) + ;; interns `name` so that symbols and code share + (let ([s (or (hashtable-ref (vfasl-info-strings vfi) name #f) + (let ([s (fasl-string (constant fasl-type-immutable-string) name)]) + (hashtable-set! (vfasl-info-strings vfi) name s) + s))]) + (copy s vfi))) + +(define (pair-copy a d vfi) + (let* ([new-p (find-room 'pair vfi + (constant vspace-impure) + (constant size-pair) + (constant type-pair))]) + (set-ptr! new-p (constant pair-car-disp) a vfi) + (set-ptr! new-p (constant pair-cdr-disp) d vfi) + new-p)) + +(define (exact-integer-copy v n vfi) + (if (<= (constant most-negative-fixnum) n (constant most-positive-fixnum)) + (fix n) + (let ([len (fxquotient (fx+ (integer-length n) (fx- (constant bigit-bits) 1)) (constant bigit-bits))]) + (vector-copy v n vfi + (lambda (n) len) + vspace-data + header-size-bignum bignum-data-disp + bigit-bytes + (bitwise-ior (bitwise-arithmetic-shift-left len (constant bignum-length-offset)) + (if (negative? n) + (constant type-negative-bignum) + (constant type-positive-bignum))) + bignum-type-disp + set-bigit! + (lambda (n i) + (let ([i (- len i 1)]) + (let ([i (fx* i (constant bigit-bits))]) + (bitwise-bit-field n i (fx+ i (constant bigit-bits)))))))))) + +(define (base-rtd-copy v vfi) + (let ([new-p (or (vfasl-info-base-rtd vfi) + (find-room 'base-rtd vfi + (constant vspace-rtd) + (constant size-record-type) + (constant type-typed-object)))]) + ;; this is a placeholder, and there's no need to write any content + (graph! v new-p vfi) + (vfasl-info-base-rtd-set! vfi new-p) + new-p)) + +(define (refers-back-to-self? v rtd) + (or (eq? v rtd) + (fasl-case* rtd + [(indirect g i) (refers-back-to-self? v (vector-ref g i))] + [else #f]))) + +(define (reloc-addr n) + (fx+ (constant reloc-table-data-disp) (fx* n (constant ptr-bytes)))) + +(define (make-short-reloc type code-offset item-offset) + (bitwise-ior (bitwise-arithmetic-shift-left type (constant reloc-type-offset)) + (bitwise-arithmetic-shift-left code-offset (constant reloc-code-offset-offset)) + (bitwise-arithmetic-shift-left item-offset (constant reloc-item-offset-offset)))) + +(define (build-vfasl-reloc tag pos) + (fix (bitwise-ior tag (bitwise-arithmetic-shift-left pos (constant vfasl-reloc-tag-bits))))) + +(define (copy-reloc m vreloc code-p vfi) + (let* ([new-p (find-room 'reloc vfi + (constant vspace-reloc) + (fx+ (constant header-size-reloc-table) (fx* m (constant ptr-bytes))) + (constant typemod))]) + (set-uptr! new-p (constant reloc-table-size-disp) m vfi) + (set-ptr!/no-record new-p (constant reloc-table-code-disp) code-p vfi) + (let loop ([n 0] [a 0] [i 0]) + (unless (fx= n m) + (fasl-case* (vector-ref vreloc i) + [(reloc type-etc code-offset item-offset elem) + (let* ([type (fxsra type-etc 2)] + [n (cond + [(fxlogtest type-etc 1) + (set-uptr! new-p (reloc-addr n) + (bitwise-ior (fxsll type (constant reloc-type-offset)) + (constant reloc-extended-format)) + vfi) + (set-uptr! new-p (reloc-addr (fx+ n 1)) item-offset vfi) + (set-uptr! new-p (reloc-addr (fx+ n 2)) code-offset vfi) + (fx+ n 3)] + [else + (set-uptr! new-p (reloc-addr n) + (make-short-reloc type code-offset item-offset) + vfi) + (fx+ n 1)])] + [a (fx+ a code-offset)] + [new-elem (or (fasl-case* elem + [(atom ty uptr) + (constant-case* ty + [(fasl-type-entry) + (when (eqv? uptr (lookup-c-entry install-library-entry)) + (vfasl-info-installs-library-entry?-set! vfi #t)) + (build-vfasl-reloc (constant vfasl-reloc-c-entry-tag) uptr)] + [(fasl-type-library) + (build-vfasl-reloc (constant vfasl-reloc-library-entry-tag) uptr)] + [(fasl-type-library-code) + (build-vfasl-reloc (constant vfasl-reloc-library-entry-code-tag) uptr)] + [else #f])] + [else #f]) + (let ([elem-addr (copy elem vfi)]) + (cond + [(vsingleton? elem-addr) + (build-vfasl-reloc (constant vfasl-reloc-singleton-tag) + (vsingleton-index elem-addr))] + [(vptr? elem-addr) + (cond + [(eqv? (vptr-vspace elem-addr) (constant vspace-symbol)) + (build-vfasl-reloc (constant vfasl-reloc-symbol-tag) + (symbol-vptr->index elem-addr vfi))] + [else + (let-values ([(bv offset) (vptr->bytevector+offset elem-addr vfi)]) + (safe-assert (not (fixed? offset))) + (fx- offset (vfasl-info-base-addr vfi)))])] + [else + ;; an immediate value; for fixnums, we can only allow 0 + (unless (or (eqv? elem-addr 0) + (not (fixed? elem-addr))) + ($oops 'vfasl "unexpected fixnum in relocation ~s" elem-addr)) + elem-addr])))]) + ;; overwrites constant-loading instructions in the code, so the + ;; linking protocol needs to be able to deal with that, possibly using + ;; later instructions to infer the right repair: + (set-iptr! code-p a new-elem vfi) + (loop n a (fx+ i 1)))] + [else ($oops 'vfasl "expected a relocation")]))) + new-p)) + +(set! $fasl-to-vfasl to-vfasl) +(set! $fasl-can-combine? fasl-can-combine?)) diff --git a/src/ChezScheme/s/x86.ss b/src/ChezScheme/s/x86.ss index 4289bc3086..3ddea50662 100644 --- a/src/ChezScheme/s/x86.ss +++ b/src/ChezScheme/s/x86.ss @@ -261,7 +261,7 @@ `(set! ,(make-live-info) ,t (asm ,info ,asm-sub ,t ,y)) `(set! ,(make-live-info) ,z ,t)))]) - (define-instruction value (-/ovfl -/eq) ; must set condition codes, so can't use lea or sub-negate + (define-instruction value (-/ovfl -/eq -/pos) ; must set condition codes, so can't use lea or sub-negate [(op (z mem) (x z) (y ur imm32)) `(set! ,(make-live-info) ,z (asm ,info ,asm-sub ,x ,y))] [(op (z mem) (x zero) (y z)) @@ -728,6 +728,9 @@ (define-instruction effect (push) [(op (x ur)) `(asm ,info ,asm-push ,x)]) + (define-instruction effect (check-stack-align) + [(op) `(asm ,info ,asm-check-stack-align)]) + (define-instruction effect save-flrv [(op) `(asm ,info ,asm-save-flrv)]) @@ -755,7 +758,7 @@ asm-fl-cvt asm-store-single asm-fpt asm-fptrunc asm-fpsingle asm-div asm-exchange asm-pause asm-locked-incr asm-locked-decr asm-locked-cmpxchg asm-fpop-2 asm-fpmove asm-fpmovefrom asm-fpcastfrom asm-fpcastto asm-fpsqrt asm-c-simple-call - asm-save-flrv asm-restore-flrv asm-return asm-c-return asm-size + asm-save-flrv asm-restore-flrv asm-return asm-c-return asm-size asm-check-stack-align asm-enter asm-foreign-call asm-foreign-callable asm-inc-profile-counter asm-inc-cc-counter asm-read-time-stamp-counter asm-read-performance-monitoring-counter @@ -890,6 +893,8 @@ (define-op sahf byte-op #b10011110) (define-op extad byte-op #b10011001) ; extend eax to edx + (define-op int3 byte-op #b11001100) + (define-op rdtsc two-byte-op #b1111 #b00110001) ; read time-stamp counter (define-op rdpmc two-byte-op #b1111 #b00110011) ; read performance monitoring counter (define-op pause two-byte-op #b11110011 #b10010000) ; equivalent to rep nop @@ -1802,6 +1807,13 @@ (emit retl `(imm ,offset) '())) (emit ret '())))) + ;; debugging helper; use as `(%inline check-stack-align)` + (define asm-check-stack-align + (lambda (code*) + (emit testi (list 'imm 15) (cons 'reg %sp) + (emit beq `(label 1 #f) + (emit int3 code*))))) + (define asm-locked-incr (lambda (code* base index offset) (let ([dest (build-mem-opnd base index offset)]) @@ -2145,6 +2157,7 @@ [(>) (i? (r? bge ble) (r? blt bgt))] [(>=) (i? (r? bgt blt) (r? ble bge))] [(overflow multiply-overflow) (i? bvc bvs)] + [(positive) (i? ble bgt)] [(carry) (i? bcc bcs)] ; unordered: zf,pf,cf <- 111; gt: 000; lt: 001; eq: 100 ; reversed & inverted: !(fl< y x) = !(fl> x y) iff zf = 1 & cf = 1 @@ -2211,7 +2224,7 @@ [(i3nt ti3nt) offset] [else (fx- (fxlogand (fx+ offset (fx* 4 arg-count) 15) -16) - (fx* 4 arg-count))]))) + (fx* 4 arg-count))]))) (define (push-registers regs fp-reg-count arg-count) (let ([offset (push-registers-size regs fp-reg-count arg-count)]) (move-registers regs fp-reg-count #f offset @@ -2376,6 +2389,14 @@ ,e ,(save-and-restore result-regs result-fp-count `(set! ,%eax ,(%inline activate-thread))))))] [else e])) + (define (add-cleanup-compensate result-type e) + ;; The convention for the calle to pop the return-pointer argument makes a mess, + ;; especially for alignment, so counteract it right away + (if (callee-pops-result-pointer? result-type) + (%seq + ,e + (set! ,%sp ,(%inline - ,%sp ,(%constant ptr-bytes)))) + e)) (define returnem (lambda (conv* orig-frame-size locs result-type ccall r-loc) (let ([frame-size (constant-case machine-type-name @@ -2394,10 +2415,7 @@ (lambda () (if (or (fx= frame-size 0) (memq 'i3nt-stdcall conv*) (memq 'i3nt-com conv*)) `(nop) - (let ([frame-size (if (callee-pops-result-pointer? result-type) - (fx- frame-size (constant ptr-bytes)) - frame-size)]) - `(set! ,%sp ,(%inline + ,%sp (immediate ,frame-size)))))))))) + `(set! ,%sp ,(%inline + ,%sp (immediate ,frame-size))))))))) (lambda (info) (safe-assert (reg-callee-save? %tc)) ; no need to save-restore (let ([conv* (info-foreign-conv* info)] @@ -2413,18 +2431,20 @@ [live* (add-caller-save-registers (reg-list %eax %edx))] [call (add-deactivate adjust-active? fill-result-here? t0 result-type - (cond - [(memq 'i3nt-com conv*) - (when (null? arg-type*) - ($oops 'foreign-procedure - "__com convention requires instance argument")) - ; jump indirect - (%seq - (set! ,%eax ,(%mref ,%sp 0)) - (set! ,%eax ,(%mref ,%eax 0)) - (set! ,%eax ,(%inline + ,%eax ,t)) - (inline ,(make-info-kill*-live* live* '()) ,%c-call ,(%mref ,%eax 0)))] - [else `(inline ,(make-info-kill*-live* live* '()) ,%c-call ,t)]))]) + (add-cleanup-compensate result-type + (cond + [(memq 'i3nt-com conv*) + (when (null? arg-type*) + ($oops 'foreign-procedure + "__com convention requires instance argument")) + ;; jump indirect + (%seq + (set! ,%eax ,(%mref ,%sp 0)) + (set! ,%eax ,(%mref ,%eax 0)) + (set! ,%eax ,(%inline + ,%eax ,t)) + (inline ,(make-info-kill*-live* live* '()) ,%c-call ,(%mref ,%eax 0)))] + [else + `(inline ,(make-info-kill*-live* live* '()) ,%c-call ,t)])))]) (cond [fill-result-here? (let* ([ftd (nanopass-case (Ltype Type) result-type @@ -2661,12 +2681,13 @@ (list %eax) 0)])])) (define (unactivate result-regs result-num-fp-regs) - (let ([e (%seq - (set! ,%eax ,(%mref ,%sp ,(+ 8 (push-registers-size result-regs result-num-fp-regs 1)))) + (let* ([push-size (push-registers-size result-regs result-num-fp-regs 1)] + [e (%seq + (set! ,%eax ,(%mref ,%sp ,(+ 8 push-size))) ,(%inline push ,%eax) ,(%inline unactivate-thread) (set! ,%eax ,(%inline pop)))]) - (if (and (null? result-regs) (fx= 0 result-num-fp-regs)) + (if (and (null? result-regs) (fx= 0 result-num-fp-regs) (fx= 0 push-size)) e (%seq ,(push-registers result-regs result-num-fp-regs 1) diff --git a/src/ChezScheme/s/x86_64.ss b/src/ChezScheme/s/x86_64.ss index 17d517ef0c..1ea01fac1f 100644 --- a/src/ChezScheme/s/x86_64.ss +++ b/src/ChezScheme/s/x86_64.ss @@ -323,7 +323,7 @@ `(set! ,(make-live-info) ,t (asm ,info ,asm-sub ,t ,y)) `(set! ,(make-live-info) ,z ,t)))]) - (define-instruction value (-/ovfl -/eq) ; must set condition codes, so can't use lea or sub-negate + (define-instruction value (-/ovfl -/eq -/pos) ; must set condition codes, so can't use lea or sub-negate [(op (z mem) (x z) (y ur imm32)) `(set! ,(make-live-info) ,z (asm ,info ,asm-sub ,x ,y))] [(op (z mem) (x zero) (y z)) @@ -791,6 +791,9 @@ (define-instruction effect (pause) [(op) `(asm ,info ,asm-pause)]) + (define-instruction effect (debug) + [(op) `(asm ,info ,asm-debug)]) + (define-instruction value read-performance-monitoring-counter [(op (z ur) (x ur mem imm)) (safe-assert (eq? z %rax)) @@ -848,7 +851,7 @@ asm-direct-jump asm-return-address asm-jump asm-conditional-jump asm-lea1 asm-lea2 asm-indirect-call asm-condition-code asm-fl-cvt asm-store-single asm-load-single asm-fpt asm-fptrunc asm-div asm-popcount - asm-exchange asm-pause asm-locked-incr asm-locked-decr asm-locked-cmpxchg + asm-exchange asm-pause asm-debug asm-locked-incr asm-locked-decr asm-locked-cmpxchg asm-fpsqrt asm-fpop-2 asm-fpmove asm-fpcast asm-fpsingle asm-c-simple-call asm-save-flrv asm-restore-flrv asm-return asm-c-return asm-size @@ -983,6 +986,8 @@ (define-op rdpmc two-byte-op #b1111 #b00110011) ; read performance monitoring counter (define-op pause two-byte-op #b11110011 #b10010000) ; equivalent to rep nop + (define-op int3 byte-op #b11001100) + (define-op dec (#;b *) unary-op #b1111111 #b001) (define-op inc (#;b *) unary-op #b1111111 #b000) (define-op neg (b *) unary-op #b1111011 #b011) ; was commented out in x86_64macros @@ -2031,6 +2036,10 @@ (lambda (code*) (emit pause code*))) + (define asm-debug + (lambda (code*) + (emit int3 code*))) + (define asm-exchange (lambda (code* dest src0 src1) (Trivit (dest src1) @@ -2374,6 +2383,7 @@ [(>) (i? (r? bge ble) (r? blt bgt))] [(>=) (i? (r? bgt blt) (r? ble bge))] [(overflow multiply-overflow) (i? bvc bvs)] + [(positive) (i? ble bgt)] [(carry) (i? bcc bcs)] ; unordered: zf,pf,cf <- 111; gt: 000; lt: 001; eq: 100 ; reversed & inverted: !(fl< y x) = !(fl> x y) iff zf = 1 & cf = 1 diff --git a/src/ChezScheme/workarea b/src/ChezScheme/workarea index 6c7cadb02f..d1b0aa80b4 100755 --- a/src/ChezScheme/workarea +++ b/src/ChezScheme/workarea @@ -55,6 +55,7 @@ case "$Mhost" in a6s2) ;; arm32le) ;; arm64le) ;; + arm64osx) ;; i3fb) ;; i3le) ;; i3nb) ;; @@ -64,6 +65,9 @@ case "$Mhost" in i3qnx) ;; i3s2) ;; ppc32le) ;; + ppc32osx) ;; + ppc32osx) ;; + arm64osx) ;; ta6fb) Muni=a6fb ;; ta6le) Muni=a6le ;; ta6nb) Muni=a6nb ;; @@ -73,6 +77,7 @@ case "$Mhost" in ta6s2) Muni=a6s2 ;; tarm32le) Muni=arm32le ;; tarm64le) Muni=arm64le ;; + tarm64osx) Muni=arm64osx ;; ti3fb) Muni=i3fb ;; ti3le) Muni=i3le ;; ti3nb) Muni=i3nb ;; @@ -82,6 +87,8 @@ case "$Mhost" in ti3qnx) Muni=i3qnx ;; ti3s2) Muni=i3s2 ;; tppc32le) Muni=ppc32le ;; + tppc32osx) Muni=ppc32osx ;; + tarm64osx) Muni=arm64osx ;; *) echo "Unrecognized machine name $Mhost"; exit 1 ;; esac @@ -101,6 +108,7 @@ case "$Muniarch" in a6s2) March=a6 ;; arm32le) March=arm32 ;; arm64le) March=arm64 ;; + arm64osx) March=arm64 ;; i3fb) March=i3 ;; i3le) March=i3 ;; i3nb) March=i3 ;; @@ -110,6 +118,7 @@ case "$Muniarch" in i3qnx) March=i3 ;; i3s2) March=i3 ;; ppc32le) March=ppc32 ;; + ppc32osx) March=ppc32 ;; *) March="" ;; esac |