diff options
| author | David Bremner <bremner@debian.org> | 2021-07-20 11:01:29 -0300 |
|---|---|---|
| committer | David Bremner <bremner@debian.org> | 2021-07-20 11:01:29 -0300 |
| commit | a0211ecc9a07308428cd12dd423183835b7569a4 (patch) | |
| tree | 294db890d6c518e7cdd11b866e3d7d88d31f32d0 /src/ChezScheme | |
| parent | 17233c0bf6ddcf1a1a8d68edef2f2604d03cf4ea (diff) | |
| parent | c1636b9ec961def24b8e659f93c49edf4ca44dba (diff) | |
Merge tag 'upstream/8.2' into dfsg
downloaded from racket-lang.org via uscan
Diffstat (limited to 'src/ChezScheme')
303 files changed, 15873 insertions, 14190 deletions
diff --git a/src/ChezScheme/BUILDING b/src/ChezScheme/BUILDING index 074b2c092c..0189e82c81 100644 --- a/src/ChezScheme/BUILDING +++ b/src/ChezScheme/BUILDING @@ -1,5 +1,5 @@ -Building Chez Scheme Version 9.5.3.x (Racket variant) -Copyright 1984-2019 Cisco Systems, Inc. +Building Chez Scheme Version 9.5.5.x (Racket variant) +Copyright 1984-2020 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. @@ -180,25 +180,26 @@ The makefile supports several targets: * `sudo make install` - Installs the biult executables, boot files, example files, and - manual pages. + Installs the built executables, boot files, example files, and + manual pages. If the `--installprefix` used with "configure" is + writable by the current user, then `sudo` is not necessary. * `sudo make uninstall` Uninstalls the executables, boot files, example files, and manual - pages. + pages. As with `make install`, if the `--installprefix` used with + "configure" is writable by the current user, then `sudo` is not + necessary. * `make test` Runs the build plus runs a set of test programs in various different ways, e.g., with different compiler options. It can take - 30 minutes or more, depending on the speed of the machine. It - produces voluminous output, so it's best to redirect its stdout and - stderr to a file. + on the order of an hour, depending on the speed of the machine. - A complete run does *not* imply no errors occurred. To check for - errors, look at the file "<workarea>/mats/summary", which should - contain one line per test run, something like this: + At the end of a complete run, the summary recorded in + "<workarea>/mats/summary" is shown. It should contain one line per + test configuration, something like this: -------- o=0 -------- -------- o=3 -------- @@ -214,7 +215,7 @@ The makefile supports several targets: -------- o=3 ehc=t eval=interpret -------- If there is anything else in "<workarea>/mats/summary", something - unexpected occurred. + unexpected occurred. See "IMPLEMENTATION.md" for more information. * `make <machine type>.boot` or `make <machine type>.bootquick` @@ -237,13 +238,40 @@ The makefile supports several targets: represented in "boot", simply add the appropriate subdirectory as empty or use `make <machine type>.boot` first. + * `make docs` + + Runs the build plus generates HTML and PDF versions of the Chez + Scheme Users Guide and the release notes. Unlike the other build + targets, the documentation is not built in the workarea, but rather + in the "csug" and "release_notes" directories (where "configure" is + run). + + Building the documentation requires a few prerequisites not required + to build the rest of Chez Scheme. The following must be available + in your PATH: + + * A TeX distribution (including latex, pdflatex, dvips, and gs) + + * ppmtogif and pnmcrop (from Netpbm) + + An X11 installation is not required, but ppmtogif does require an + "rgb.txt" file, which it will automatically locate in the common + X11 installation locations. If ppmtogif fails because it cannot + find an "rgb.txt" file, you can use the `RGBDEF` environment + variable to specify the path to a file. If your system has an Emacs + installation, then you can find an "rgb.txt" file in the "etc" + directory of the emacs installation. If your system has a Vim + installation, then it might contain an "rgb.txt" in the directory + identified by the `VIMRUNTIME` environment variable. + * `make clean` Removes binaries from the workarea. * `make distclean` - Removes "nanopass", "Makefile", and all workareas. + Removes "nanopass", "Makefile", built documentation, and all + workareas. WINDOWS VIA COMMAND PROMPT diff --git a/src/ChezScheme/IMPLEMENTATION.md b/src/ChezScheme/IMPLEMENTATION.md index 623dd7ec2f..efa30f2b80 100644 --- a/src/ChezScheme/IMPLEMENTATION.md +++ b/src/ChezScheme/IMPLEMENTATION.md @@ -14,26 +14,50 @@ Some key files in "s": * "syntax.ss": the macro expander - * "cpnanopass.ss": the main compiler + * "cpnanopass.ss" and "cpprim.ss": the main compiler, where + "cpprim.ss" is the part that inlines primitives * "cp0.ss", "cptypes.ss", "cpletrec.ss", etc.: source-to-source passes that apply before the main compiler * "x86_64.ss", "arm64.ss", etc.: backends that are used by - "cpnanopass.ss" + "cpnanopass.ss" and "cpprim.ss" - * "ta6os.def", "tarm64le", etc.: one per OS-architecture combination, - provides platform-specific constants that feed into "cmacro.ss" and - selects the backend used by "cpnanopass.ss" + * "ppc32osx.def", "tppc32osx.def", etc., with common combinations + produced from the "unix.def" and "tunix.def" templates: provides + platform-specific constants that feed into "cmacro.ss" and selects + the backend used by "cpnanopass.ss" and "cpprim.ss" Chez Scheme is a bootstrapped compiler, meaning you need a Chez Scheme compiler to build a Chez Scheme compiler. The compiler and makefiles support cross-compilation, so you can work from an already supported host to cross-compile the boot files and produce the header files for a new platform. In particular, the `pb` (portable bytecode) machine -type can run on any supported hardward and operating system, so having +type can run on any supported hardware and operating system, so having `pb` boot files is one way to get started in a new environment. +# 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. + # Build System Chez Scheme assigns a `machine-type` name to each platform it runs on. @@ -53,17 +77,22 @@ directory "boot/*machine-type*". (If it doesn't find them, then configuration cannot continue.) The supported machine types are listed in "cmacros.ss" and reflected -by a "boot/*machine-type*" directory for boot and headers files, a -"s/*machine-type*.def" file to describe the platform, a -"s/Mf-*machine-type*" makefile to select relevant files in "s", a -"c/Mf-*machine-type*" makefile for configration in "c", and a -"mats/Mf-*machine-type*" makefile to configure testing. +by a "boot/*machine-type*" directory for boot and headers files and a +combination of "s/*kind*.def" files to describe the platform. There +may also be a "s/Mf-*machine-type*" makefile to select relevant files +in "s", a "c/Mf-*machine-type*" makefile for configration in "c", and +a "mats/Mf-*machine-type*" makefile to configure testing, but Unix +machine types are handled by Mf-unix and variables configured in the +"configure" and "workarea" scripts. The "workarea" script in the root of the Chez Scheme project is used to generate a subdirectory with the appropriate contents to build for 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. +The directory where you run "configure" or "workarea" is the "build +directory", while the directory named "*machine-type*" created by +"workarea" is the "workarea directory". Bootstrap from scratch by running the Racket program "rktboot/main.rkt", which should work even with a relatively old @@ -88,21 +117,23 @@ handled by having the Scheme compiler generate a couple of C headers: "scheme.h" and "equates.h", that the contain the information about the Scheme compiler the C kernel needs to do its job. -Most of the work of porting to a new platform is producing a new -"*machine-type*.def" file, which (except in simple ports to a new -operating system) will require a new "*ISA*.ss" compiler backend. -You'll also have to set up all the "Mf-*machine-type*" makefiles and -update "configure", "cmacro.ss", and "version.h"---plus maybe other -files, such as "workarea" if you create new dependencies among "Mf-" -or ".def" files (e.g., "workarea" needs to know that "a6nt.def" uses -"a6.def" and "nt.def"). Once you have all of the pieces working -together, you cross-compile boot files, then copy them over to the the -new machine to start compiling there. - -You can port to a new operating system by imitating the files of a -similar supported oerating system, but building a new backend for a -new processor requires much more understanding of the compiler and -runtime system. +You can port to a new operating system by imitating the files and +configuration of a similar supported operating system, but building a +new backend for a new processor requires much more understanding of +the compiler and runtime system. + +Most of the work of porting to a new architecture is producing a new +"*ISA*.ss" compiler backend, and there will be a "*arch*.def" file to +go with it. For all ports, including a new operating system on an +already-supported architecture, you'll need to update "configure", +"workarea", "cmacro.ss", and possibly "version.h". If the generic +"unix.def" and/or "tunix.def" templates do not work for the +OS--architecture combination, you'll need to create a new +"*machine-type*.def" file. + +Once you have all of the pieces working together, you cross-compile +boot files, then copy them over to the the new machine to start +compiling there. # Adding Functionality @@ -137,32 +168,136 @@ 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. +# Writing and Running Tests + +A group of tests is written in a ".ms" file in the "mats" directory. +Within a `mat` form after the name for the group of tests, each test +is written as a expression that produces `#t` for success. Use the +`error?` form to wrap an expression that is supposed to raise an +exception in safe mode, but note that the test doesn't describe the +exception specifically, since the expected error message likely +depends on the configuration (e.g. safe versus unsafe); more on that +below. + +### Running One Set of Tests (no expected-error checking) + +Runs tests in a ".ms" file by going to your build's +"*machine-type*/mats" directory, then `make` with a ".mo" target. For +example, use `make 7.mo` to build and run `7.ms`. Delete `7.mo` to run +`7.ms` again. Makefile variables like `o` control the way tests are +run; for example, use `make 7.mo o=3` to test in unsafe mode. See the +source file "mats/Mf-base" for information about the configuration +options. Running tests to make a ".mo" file prints a lot of output, so +you'll likely want to redirect stdout and stderr to a file. + +A test failure is recorded in a ".mo" file as a line that contains +`Bug`, `Error`, or `invalid memory`. That's why the target for making +a ".mo" file ends by grepping the file. Tests for exceptions produce +the output `Expected error`, but there's not currently a way to check +that the exception tests of an individual ".ms" file produce the +expected error message. + +### Running Tests in One Configuration (with expected-error checking) + +You can make all ".mo" files with just `make` within your build's +"*machine-type*/mats". You can provide configuration arguments, too, +such as `make o=3` to make all ".mo" files in unsafe mode. + +In this mode, output ".mo" files are written to a subdirectory that is +partially configuration-specific, such as "compile-0-f-f-f" for +`compile` (as opposed to `interpret`) in safe mode (`0` instead of +`3`), without `suppress-primitive-inlining` enabled (first `f`), +without cp0 enabled (second `f`), and without +`compile-interpret-simple` enabled (last `f`). Note that a set of +tests is not run again if an up-to-date ".mo" file is in the output +directory, so use `make clean` as needed. + +The combination of all ".mo" error messages (from both expected +exceptions and test failures) is compared against a list of expected +errors messages for a configuration using `diff`. The `diff` result is +written to "report-*config*", where *config* is the name of the +configuration. So, an empty "report-*config*" means success. + +The set of expected error messages for a given configuration is +generated by starting with either "mats/root-experr-compile-0-f-f-f" +or "mats/root-experr-compile-3-f-f-f" (depending on whether the +configuration is in unsafe or safe mode) and then applying some number +of patches from "mats/patch-*config*". That's why the *config* in +"report-*config*" doesn't identify everything about the configuration; +it only identifies the combinations that can have different error +output. + +If you add a new test that's expected to have error output (usually to +check that an exception is correctly raised), then +"mats/root-experr-*config*" and/or "mats/patch-*config*" files need to +change. Modifying those files by hand is not practical. Instead, the +strategy is to make sure that the output diff in "record-*config*" is +correct, and then use targets like `make root-experr` and `make +patches` to generate new "root-experr-..." and "patch-..." files: + + * Run `make` and then `make root-experr` to generate a new + "root-experr-compile-0-f-f-f", then copy the generated file in the + workarea to the source "mats" directory. Often, this step is all + that is needed to update expected errors, since expected errors + tend to happen only in safe mode, and they tend not to change among + other configuration options. + + * If you need to update "root-experr-compile-3-f-f-f", use `make + root-experr o=3` after running with `make o=3` and then copy the + file from the workarea to the "mats" source directory. + + * After running tests for a configuration with `make` plus + configuration options, you may be able to recreate the + corresponding patch file using `make xpatch-*config*` with the same + configuration options. However, some configurations involve layers + of patch files, so it's tricky to get this right by running test + configurations one at a time, and it's better to run tests for all + configurations. + +### Running Tests for All Configurations + +To run tests for all configurations, use `make allx` within your +build's "*machine-type*/mats" directory. Add `-j` followed by *N* to +run tests using *N* parallel jobs. Using `make allx` implicitly uses +`make clean` before it runs tests. You can also use `make test` +directly in your build directory, since that's a shortcut for `make +allx` in the "*machine-type*/mats" directory. + +To support parallel tests, `make allx` write its output in a +collection of "output-*i*-*o*" directories within +"*machine-type*/mats", so you can look for "report-*config*" files in +those subdirectories. As its last step, `make allx` combines a summary +of reports to a `summary` file directly in "*machine-type*/mats", and +then it shows that summary as output. As long as that output shows +only configurations (i.e., no errors), then all tests passed for all +configurations. + +After running `make allx`, if the summary shows only errors that +reflect out-of-date expectations from "root-experr-..." or "patch-..." +files, you can use the sequence + +```bash +make root-experr o=0 +make root-experr o=3 +make patches +``` -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. +to create new vesions of the files in the workarea directory. Copy +changed files to the "mats" source directory; if the only change to a +patch file is to the line-number hints, then it's probably not worth +keeping the update (as long as the line numbers are not too far off). +After copying to source, delete any "root-experr-..." or "patch-..." +files, and then links are recreated on demand in the workarea space to +"root-experr-..." or "patch-..." files when they are needed to +generate expexted-error diffs. + +You can run a smaller set of tests using `make partialx` or using +`make test-some` directly in your build directory. Despite its name, +`make allx` does not run all available tests. Use `make bullyx` or +`make test-more` to run a different, more stressfull set of tests. The +bully tests may cover more configurations than `allx`, so `make +patches` after `make bullyx` may pick up additional "patch-..." file +changes. # Scheme Objects @@ -187,10 +322,10 @@ For example, if "cmacro.ss" says then that means an address with only the lowest bit set among the low three bits refers to a pair. To get the address where the pair content -is stored, round *up* to the nearest word. So, on a 64-bit machine, -add 7 to get to the `car` and add 15 to get to the `cdr`. Since -allocation on a 64-byte machine is 16-byte aligned, the hexadecimal -form of every pair pointer will end in "9". +is stored, round *up* to the nearest multiple 8 bytes. So, on a 64-bit +machine, add 7 to get to the `car` and add 15 to get to the `cdr`. +Since allocation on a 64-byte machine is 16-byte aligned, the +hexadecimal form of every pair pointer will end in "9". The `type-typed-object` type, @@ -204,14 +339,14 @@ of a Scheme record, that first word will be a record-type descriptor as a record. The based record type, `#!base-rtd` has itself as its record type. Since the type bits are all ones, on a 64-bit machine, every object tagged with an additional type workd will end in "F" in -hexadecimal, and adding 1 to the pointer produces the <address +hexadecimal, and adding 1 to the pointer produces the address containing the record content (which starts with the record type, so add 9 instead to get to the first field in the record). As another example, a vector is represented as `type-typed-object` pointer where the first word is a fixnum. That is, a fixnum used a type word indicates a vector. The fixnum value is the vector's length -in wordobjects, but shifted up by 1 bit, and then the low bit is set +in words/objects, but shifted up by 1 bit, and then the low bit is set to 1 for an immutable vector. Most kinds of Scheme values are represented records, so the layout is @@ -266,7 +401,7 @@ To the degree that the runtime system needs global state, that state is in the thread context (so, it's thread-local), which we'll abbreviate as "TC". Some machine register is designated as the `%tc` register, and it's initialized on entry to Scheme code. For the -defintion of TC, see `(define-primitive-structure-disps tc ...)` in +definition of TC, see `(define-primitive-structure-disps tc ...)` in "cmacro.ss". The first several fields of TC are virtual registers that may be @@ -305,7 +440,7 @@ frame is the return address, so a frame looks like this: On entry to a Scheme function, a check ensures that the difference between SFP and the end of the current stack segment is big enough to -accomodate the (spilled) variables of the called function, plus enough +accommodate the (spilled) variables of the called function, plus enough slop to deal with some primitive operations. A non-tail call moves SFP past all the live variables of the current @@ -375,12 +510,12 @@ 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. +"cpprim.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 +of inline `set-car!` in "cpprim.ss" includes ```scheme (build-libcall #t src sexpr set-car! e-pair e-new) @@ -436,7 +571,7 @@ 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". +definition in "prims.ss". If you're looking for math primitives, see "mathprims.ss" instead of "prims.ss". @@ -457,9 +592,9 @@ Compilation * performs front-end optimizations on that representation (see "cp0.ss", "cptypes.ss", etc.), - * and then compiles to machine code (see "cpnanopass.ss"), which - involves many individual passes that convert through many different - intermediate forms (see "np-language.ss"). + * and then compiles to machine code (see "cpnanopass.ss" and + "cpprim.ss"), which involves many individual passes that convert + through many different intermediate forms (see "np-language.ss"). It's worth noting that Chez Scheme produces machine code directly, instead of relying on a system-provided assembler. Chez Scheme also @@ -723,7 +858,7 @@ backend can assume that a `uvar` wil be replaced later by a register. When reading the compiler's implementation, `make-tmp` in most passes creates a `uvar` (that may eventually be spilled to a stack-frame slot). A `make-tmp` in the instruction-selection pass, however, makes -an unspillable. In earlies passes of the compiler, new temporaries +an unspillable. In earliest passes of the compiler, new temporaries must be bound with a `let` form (i.e., a `let` in the intermediate repressentation) before they can be used; in later passes, a `set!` initializes a temporary. @@ -928,7 +1063,7 @@ instruction for the register--register and the register--immediate cases. A more explicit distinction could be made in the output of instruction selection, but delaying the choice is anologous to how assembly languages often use the same mnemonic for related -instructions. The `asm-move` and `asm-fpmove` must accomodate +instructions. The `asm-move` and `asm-fpmove` must accommodate register--memory, memory--register, and register--register cases, because `set!` forms after instruction selection can have those variants. @@ -985,8 +1120,8 @@ machine-specific linking dierctives can appear. In the case of address), `arm32-call` (call an asolute address while setting the link register), and a`arm32-jump` (jump to an asolute address). These are turned into relocation entries associated with compiled code by steps -in "compile.ss". Relocaiton entires are used when loding an GCing with -update routines implemented in "fasl.c". +in "compile.ss". Relocation entries are used when loading and GCing +with update routines implemented in "fasl.c". Typically, a linking directive is written just after some code that is generated as installing a dummy value, and theen the update routine in @@ -999,7 +1134,7 @@ handling in "compile.ss", and the update routine in "fasl.c". # Foreign Function ABI Support for foreign procedures and callables in Chez Scheme boils down -to foriegn calls and callable stubs for the backend. A backend's +to foreign calls and callable stubs for the backend. A backend's `asm-foreign-call` and `asm-foreign-callbable` function receives an `info-foreign` record, which describes the argument and result types in relatively primitive forms: diff --git a/src/ChezScheme/LOG b/src/ChezScheme/LOG index c6b587e543..5e70877942 100644 --- a/src/ChezScheme/LOG +++ b/src/ChezScheme/LOG @@ -2118,3 +2118,95 @@ x86.ss - add special case in cpnanopass.ss for (eq? (ftype-pointer-address x) 0) cpnanopass.ss +- added missing #ifndef WIN32 + gcwrapper.c +- added initialization of __to_g to make gcc 7.5.0 happy + gc.c +- updated Windows makefiles + c/Makefile.*nt +- use lowercase for Windows include files + segment.c, windows.c +- proper unicode handling when retrieving error messages from the OS + on Windows + windows.c +- repair collector handling of an ephemerons that refers to a + younger object during incremental promotion + gc.c, 4.ms +- added textual-output-port checks for record-writer write argument + print.ss, + record.ms, root-experr* +- now using 64-bit arithmetic for seconds in S_condition_wait to + prevent a potential 2038 bug, at least on platforms where time_t + is 64 bits. also now rounding rather than truncating nanoseconds + in the coversion to milliseconds on Windows. + thread.c +- fixed a bug in arm32 that caused an error when generating + instructions with immediate operands where the immediate was larger + than 8 bits. + arm32.ss +- fixed formatting in arm32.ss + arm32.ss +- disabled unsupported mats for arm32le + foreign.ms, misc.ms +- fixed callee-save floating point registers for arm32 + arm32.ss, ftype.ss, np-languages.ss, primdata.ss +- added a mat for the add-with-immediate bug + misc.ms, + mats/arm-immediate-1.ss (new), mats/arm-immediate-2.ss (new) +- added a note about arm32 targets requiring a kernel module for the + time stamp counter + prims.ss + +9.5.4 changes: +- updated version to 9.5.4 + BUILDING NOTICE makefiles/Mf-install.in makefiles/Makefile-csug.in + scheme.1.in c/Makefile.a6nt c/Makefile.i3nt c/Makefile.ta6nt + c/Makefile.ti3nt mats/Mf-a6nt mats/Mf-i3nt mats/Mf-ta6nt + mats/Mf-ti3nt workarea c/scheme.rc s/7.ss s/cmacros.ss + release_notes/release_notes.stex csug/copyright.stex csug/csug.stex + bintar/Makefile rpm/Makefile pkg/Makefile wininstall/Makefile + wininstall/a6nt.wxs wininstall/i3nt.wxs wininstall/ta6nt.wxs + wininstall/ti3nt.wxs + +9.5.5 changes: +- updated version to 9.5.5 + BUILDING NOTICE makefiles/Mf-install.in scheme.1.in c/Makefile.a6nt + c/Makefile.i3nt c/Makefile.ta6nt c/Makefile.ti3nt mats/Mf-a6nt + mats/Mf-i3nt mats/Mf-ta6nt mats/Mf-ti3nt workarea c/scheme.rc + s/cmacros.ss release_notes/release_notes.stex csug/copyright.stex + csug/csug.stex bintar/Makefile rpm/Makefile pkg/Makefile + wininstall/Makefile wininstall/a6nt.wxs wininstall/i3nt.wxs + wininstall/ta6nt.wxs wininstall/ti3nt.wxs +- newrelease no longer logs as updated files with no actual changes + newrelease +- avoid hard-coded paths for utilities in build scripts + csug/gifs/Makefile csug/math/Makefile examples/Makefile + makefiles/Makefile-csug.in makefiles/Makefile-release_notes.in + makefiles/Mf-install.in makefiles/installsh mats/6.ms mats/Mf-a6fb + mats/Mf-a6le mats/Mf-a6nb mats/Mf-a6ob mats/Mf-a6osx mats/Mf-arm32le + mats/Mf-arm64le mats/Mf-arm64osx mats/Mf-i3fb mats/Mf-i3le mats/Mf-i3nb + mats/Mf-i3ob mats/Mf-i3osx mats/Mf-i3qnx mats/Mf-ppc32le mats/Mf-ppc32osx + mats/unix.ms newrelease pkg/Makefile release_notes/gifs/Makefile + release_notes/math/Makefile s/Mf-base stex/Makefile stex/Mf-stex + stex/gifs/Makefile stex/math/Makefile workarea + zlib/contrib/minizip/Makefile +- fixed the documentation of load-shared-object to mention an up-to-date + dll for Windows + foreign.stex +- New spellings #true and #false for #t and #f are recognized + read.ss 6.ms +- refactor mats to allow different configurations to run in parallel. + The {partial,all,bully}x targets in Mats/Mf-base now support running + in parallel if make chooses to do so (e.g., if instructed via -j). + Update travis-ci build scripts to use new partialx target and run + jobs in parallel (based on the number of cores available). Also + add the ability to "skip" (i.e., error before building) travis targets + by using a line (or lines) beginning with "travis:only:" and listing + the desired target machine type(s) in the commit message. + .travis.yml .travis/{build,test,maybe-skip-build}.sh + mats/{5_4,6,7,8,bytevector,examples,foreign}.ms + mats/{ftype,hash,io,misc,primvars,profile,record}.ms + mats/Mf-base mats/Mf-*nt mats/mat.ss mats/patch-interpret* +- escape $(MAKE) to fix parallel mat issue observed with GNU Make 4.2.1: + "make[1]: warning: jobserver unavailable: using -j1." + mats/Mf-base diff --git a/src/ChezScheme/NOTICE b/src/ChezScheme/NOTICE index 9fa93e4587..79ffaede08 100644 --- a/src/ChezScheme/NOTICE +++ b/src/ChezScheme/NOTICE @@ -1,5 +1,5 @@ -Chez Scheme Version 9.5.3 -Copyright 1984-2019 Cisco Systems, Inc. +Chez Scheme Version 9.5.5 +Copyright 1984-2020 Cisco Systems, Inc. This product includes code developed by Cisco Systems, Inc. diff --git a/src/ChezScheme/README.md b/src/ChezScheme/README.md index 5821dd3495..fdcaf245f0 100644 --- a/src/ChezScheme/README.md +++ b/src/ChezScheme/README.md @@ -8,10 +8,12 @@ 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 + * FreeBSD: x86, x86_64, ARMv6, AArch64, PowerPC32 + * OpenBSD: x86, x86_64, ARMv6, AArch64, PowerPC32 + * NetBSD: x86, x86_64, ARMv6, AArch64, PowerPC32 * Solaris: x86, x86_64 + * Android: ARMv7, AArch64 + * iOS: AArch64 As a superset of the language described in the [Revised<sup>6</sup> Report on the Algorithmic Language Scheme](http://www.r6rs.org) diff --git a/src/ChezScheme/bintar/Makefile b/src/ChezScheme/bintar/Makefile index 046ab70c10..693fb6b9bc 100644 --- a/src/ChezScheme/bintar/Makefile +++ b/src/ChezScheme/bintar/Makefile @@ -13,7 +13,7 @@ # See the License for the specific language governing permissions and # limitations under the License. -version = 9.5.3 +version = 9.5.5 m := $(shell find ../bin/* -type d | xargs basename) R = csv$(version) @@ -61,7 +61,7 @@ $(R)/boot: $(R) ( cd $(R)/boot/$(m) ; ln -s ../../../../boot/$(m)/{scheme.h,petite.boot,scheme.boot,revision} . ) case $(m) in \ *nt) \ - ( cd $R/boot/$(m) ; ln -s ../../../../boot/$(m)/{csv953md.lib,csv953mt.lib,mainmd.obj,mainmt.obj,scheme.res} . ) \ + ( cd $R/boot/$(m) ; ln -s ../../../../boot/$(m)/{csv955md.lib,csv955mt.lib,mainmd.obj,mainmt.obj,scheme.res} . ) \ ;; \ *) \ ( cd $R/boot/$(m) ; ln -s ../../../../boot/$(m)/{main.o,kernel.o} . ) \ @@ -72,7 +72,7 @@ $(R)/bin: $(R) mkdir -p $(R)/bin/$(m) case $(m) in \ *nt) \ - ( cd $R/bin/$(m) ; ln -s ../../../../bin/$(m)/{scheme.exe,csv953.dll,csv953.lib,vcruntime140.lib} . ) \ + ( cd $R/bin/$(m) ; ln -s ../../../../bin/$(m)/{scheme.exe,csv955.dll,csv955.lib,vcruntime140.lib} . ) \ ;; \ *) \ ( cd $R/bin/$(m) ; ln -s ../../../../bin/$(m)/scheme . ) \ diff --git a/src/ChezScheme/boot/pb/equates.h b/src/ChezScheme/boot/pb/equates.h index 4a3c9d3cbd..e3c605ac3e 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.58 */ +/* equates.h for Chez Scheme Version 9.5.5.5 */ /* Do not edit this file. It is automatically generated and */ /* specifically tailored to the version of Chez Scheme named */ @@ -71,6 +71,7 @@ typedef uint64_t U64; #define STRVNCATE 0x1 #define address_bits 0x40 #define alloc_waste_maximum 0x800 +#define ancestry_parent_offset 0x2 #define annotation_all 0x3 #define annotation_debug 0x1 #define annotation_profile 0x2 @@ -345,10 +346,16 @@ typedef uint64_t U64; #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_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) (42 . arm32fb) (43 . tarm32fb) (44 . ppc32fb) (45 . tppc32fb) (46 . arm64fb) (47 . tarm64fb) (48 . arm32ob) (49 . tarm32ob) (50 . ppc32ob) (51 . tppc32ob) (52 . arm64ob) (53 . tarm64ob) (54 . arm32nb) (55 . tarm32nb) (56 . ppc32nb) (57 . tppc32nb) (58 . arm64nb) (59 . tarm64nb)) #define machine_type_any 0x0 +#define machine_type_arm32fb 0x2A #define machine_type_arm32le 0x20 +#define machine_type_arm32nb 0x36 +#define machine_type_arm32ob 0x30 +#define machine_type_arm64fb 0x2E #define machine_type_arm64le 0x24 +#define machine_type_arm64nb 0x3A +#define machine_type_arm64ob 0x34 #define machine_type_arm64osx 0x26 #define machine_type_i3fb 0x6 #define machine_type_i3le 0x2 @@ -358,10 +365,13 @@ typedef uint64_t U64; #define machine_type_i3osx 0xA #define machine_type_i3qnx 0x1E #define machine_type_i3s2 0x14 -#define machine_type_limit 0x2A +#define machine_type_limit 0x3C #define machine_type_name pb #define machine_type_pb 0x1 +#define machine_type_ppc32fb 0x2C #define machine_type_ppc32le 0x22 +#define machine_type_ppc32nb 0x38 +#define machine_type_ppc32ob 0x32 #define machine_type_ppc32osx 0x28 #define machine_type_ta6fb 0x17 #define machine_type_ta6le 0xD @@ -370,8 +380,14 @@ typedef uint64_t U64; #define machine_type_ta6ob 0x11 #define machine_type_ta6osx 0xF #define machine_type_ta6s2 0x13 +#define machine_type_tarm32fb 0x2B #define machine_type_tarm32le 0x21 +#define machine_type_tarm32nb 0x37 +#define machine_type_tarm32ob 0x31 +#define machine_type_tarm64fb 0x2F #define machine_type_tarm64le 0x25 +#define machine_type_tarm64nb 0x3B +#define machine_type_tarm64ob 0x35 #define machine_type_tarm64osx 0x27 #define machine_type_ti3fb 0x7 #define machine_type_ti3le 0x3 @@ -381,7 +397,10 @@ typedef uint64_t U64; #define machine_type_ti3osx 0xB #define machine_type_ti3qnx 0x1F #define machine_type_ti3s2 0x15 +#define machine_type_tppc32fb 0x2D #define machine_type_tppc32le 0x23 +#define machine_type_tppc32nb 0x39 +#define machine_type_tppc32ob 0x33 #define machine_type_tppc32osx 0x29 #define mask_bignum 0x1F #define mask_bignum_sign 0x20 @@ -439,9 +458,9 @@ typedef uint64_t U64; #define mask_vector 0x7 #define max_float_alignment 0x8 #define max_integer_alignment 0x8 -#define max_real_space 0x11 -#define max_space 0x12 -#define max_sweep_space 0xF +#define max_real_space 0x12 +#define max_space 0x13 +#define max_sweep_space 0x10 #define maximum_bignum_length (iptr)0x3FFFFFFFFFFFFFF #define maximum_bytevector_length (iptr)0xFFFFFFFFFFFFFFF #define maximum_flvector_length (iptr)0xFFFFFFFFFFFFFFF @@ -450,6 +469,7 @@ typedef uint64_t U64; #define maximum_parallel_collect_threads 0x10 #define maximum_string_length (iptr)0xFFFFFFFFFFFFFFF #define maximum_vector_length (iptr)0xFFFFFFFFFFFFFFF +#define minimum_ancestry_vector_length 0x2 #define minimum_segment_request 0x80 #define most_negative_fixnum (iptr)-0x1000000000000000 #define most_positive_fixnum (iptr)0xFFFFFFFFFFFFFFF @@ -732,6 +752,7 @@ typedef uint64_t U64; #define pb_ld_op_pb_uint8_pb_immediate 0xA5 #define pb_ld_op_pb_uint8_pb_register 0xA4 #define pb_le 0x6 +#define pb_link 0xDA #define pb_lock 0xD8 #define pb_lsl 0x12 #define pb_lslo 0x18 @@ -878,8 +899,9 @@ typedef uint64_t U64; #define ratnum_numerator_disp 0x9 #define ratnum_pad_disp 0x19 #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 real_space_alist ((new . 0) (impure . 1) (symbol . 2) (port . 3) (pure . 4) (continuation . 5) (code . 6) (pure-typed-object . 7) (impure-record . 8) (impure-typed-object . 9) (closure . 10) (immobile-impure . 11) (count-pure . 12) (count-impure . 13) (weakpair . 14) (ephemeron . 15) (reference-array . 16) (data . 17) (immobile-data . 18)) #define record_data_disp 0x9 +#define record_ptr_offset 0x1 #define record_type_ancestry_disp 0x9 #define record_type_counts_disp 0x49 #define record_type_disp 0x1 @@ -891,6 +913,7 @@ typedef uint64_t U64; #define record_type_size_disp 0x11 #define record_type_type_disp 0x1 #define record_type_uid_disp 0x41 +#define reference_disp 0x9 #define reloc_abs 0x0 #define reloc_code_offset_index 0x3 #define reloc_code_offset_mask 0x3FFFFFF @@ -918,6 +941,7 @@ typedef uint64_t U64; #define rp_header_livemask_disp 0x10 #define rp_header_mv_return_address_disp 0x8 #define rp_header_toplink_disp 0x0 +#define rtd_act_sealed 0x8 #define rtd_counts_data_disp 0x11 #define rtd_counts_timestamp_disp 0x9 #define rtd_counts_type_disp 0x1 @@ -926,7 +950,7 @@ typedef uint64_t U64; #define rtd_sealed 0x4 #define sbwp (ptr)0x4E #define scaled_shot_1_shot_flag -0x8 -#define scheme_version 0x905033A +#define scheme_version 0x9050505 #define seginfo_generation_disp 0x1 #define seginfo_list_bits_disp 0x8 #define seginfo_space_disp 0x0 @@ -973,34 +997,35 @@ typedef uint64_t U64; #define size_rp_header 0x20 #define size_rtd_counts 0x810 #define size_symbol 0x30 -#define size_tc 0x300 +#define size_tc 0x310 #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) -#define space_closure 0xC -#define space_cname_list ("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") -#define space_code 0x8 -#define space_continuation 0x7 -#define space_count_impure 0xF -#define space_count_pure 0xE -#define space_data 0x10 -#define space_empty 0x12 -#define space_ephemeron 0x5 -#define space_immobile_data 0x11 -#define space_immobile_impure 0xD +#define space_char_list (#\n #\i #\x #\q #\p #\k #\c #\r #\s #\t #\l #\I #\y #\z #\w #\e #\a #\d #\D #\e) +#define space_closure 0xA +#define space_cname_list ("new" "impure" "symbol" "port" "pure" "cont" "code" "p-tobj" "ip-rec" "ip-tobj" "closure" "im-impure" "cnt-pure" "cnt-impure" "weakpr" "emph" "ref-array" "data" "im-data" "empty") +#define space_code 0x6 +#define space_continuation 0x5 +#define space_count_impure 0xD +#define space_count_pure 0xC +#define space_data 0x11 +#define space_empty 0x13 +#define space_ephemeron 0xF +#define space_immobile_data 0x12 +#define space_immobile_impure 0xB #define space_impure 0x1 -#define space_impure_record 0xA -#define space_impure_typed_object 0xB +#define space_impure_record 0x8 +#define space_impure_typed_object 0x9 #define space_new 0x0 #define space_port 0x3 -#define space_pure 0x6 -#define space_pure_typed_object 0x9 +#define space_pure 0x4 +#define space_pure_typed_object 0x7 +#define space_reference_array 0x10 #define space_symbol 0x2 -#define space_weakpair 0x4 +#define space_weakpair 0xE #define stack_frame_limit 0x200 #define stack_slop 0x400 #define stack_word_alignment 0x1 @@ -1026,73 +1051,74 @@ typedef uint64_t U64; #define symbol_pvalue_disp 0xD #define symbol_splist_disp 0x25 #define symbol_value_disp 0x5 -#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 -#define tc_X_disp 0x198 -#define tc_Y_disp 0x1A0 +#define tc_DSTBV_disp 0x2B0 +#define tc_SRCBV_disp 0x2B8 +#define tc_U_disp 0x188 +#define tc_V_disp 0x190 +#define tc_W_disp 0x198 +#define tc_X_disp 0x1A0 +#define tc_Y_disp 0x1A8 #define tc_ac0_disp 0x38 #define tc_ac1_disp 0x40 -#define tc_active_disp 0x144 -#define tc_alloc_counter_disp 0x298 +#define tc_active_disp 0x14C +#define tc_alloc_counter_disp 0x2A0 #define tc_ap_disp 0x60 #define tc_arg_regs_disp 0x0 -#define tc_attachments_disp 0x170 -#define tc_block_counter_disp 0x1F8 -#define tc_cached_frame_disp 0x178 -#define tc_cchain_disp 0x130 -#define tc_code_ranges_to_flush_disp 0x138 -#define tc_compile_profile_disp 0x230 -#define tc_compress_format_disp 0x278 -#define tc_compress_level_disp 0x280 +#define tc_attachments_disp 0x178 +#define tc_block_counter_disp 0x200 +#define tc_cached_frame_disp 0x180 +#define tc_cchain_disp 0x138 +#define tc_code_ranges_to_flush_disp 0x140 +#define tc_compile_profile_disp 0x238 +#define tc_compress_format_disp 0x280 +#define tc_compress_level_disp 0x288 #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 0x268 -#define tc_default_record_hash_procedure_disp 0x270 -#define tc_disable_count_disp 0x1B8 +#define tc_current_error_disp 0x1F8 +#define tc_current_input_disp 0x1E8 +#define tc_current_mso_disp 0x210 +#define tc_current_output_disp 0x1F0 +#define tc_default_record_equal_procedure_disp 0x270 +#define tc_default_record_hash_procedure_disp 0x278 +#define tc_disable_count_disp 0x1C0 #define tc_eap_disp 0x68 #define tc_esp_disp 0x58 -#define tc_fpregs_disp 0x2B8 -#define tc_fxfirst_bit_set_bv_disp 0x220 -#define tc_fxlength_bv_disp 0x218 -#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 0x290 -#define tc_keyboard_interrupt_pending_disp 0x1D0 -#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_fpregs_disp 0x2C0 +#define tc_fxfirst_bit_set_bv_disp 0x228 +#define tc_fxlength_bv_disp 0x220 +#define tc_gc_data_disp 0x300 +#define tc_generate_inspector_information_disp 0x240 +#define tc_generate_procedure_source_information_disp 0x248 +#define tc_generate_profile_forms_disp 0x250 +#define tc_guardian_entries_disp 0x130 +#define tc_instr_counter_disp 0x298 +#define tc_keyboard_interrupt_pending_disp 0x1D8 +#define tc_lz4_out_buffer_disp 0x290 +#define tc_meta_level_disp 0x230 +#define tc_optimize_level_disp 0x258 +#define tc_parameters_disp 0x2A8 +#define tc_random_seed_disp 0x148 #define tc_real_eap_disp 0xA0 #define tc_ret_disp 0x70 -#define tc_scheme_stack_disp 0x148 -#define tc_scheme_stack_size_disp 0x160 -#define tc_sfd_disp 0x200 +#define tc_save1_disp 0xA8 +#define tc_scheme_stack_disp 0x150 +#define tc_scheme_stack_size_disp 0x168 +#define tc_sfd_disp 0x208 #define tc_sfp_disp 0x48 -#define tc_signal_interrupt_pending_disp 0x1C0 -#define tc_signal_interrupt_queue_disp 0x1C8 -#define tc_something_pending_disp 0x1A8 -#define tc_stack_cache_disp 0x150 -#define tc_stack_link_disp 0x158 -#define tc_subset_mode_disp 0x258 -#define tc_suppress_primitive_inlining_disp 0x260 -#define tc_target_machine_disp 0x210 +#define tc_signal_interrupt_pending_disp 0x1C8 +#define tc_signal_interrupt_queue_disp 0x1D0 +#define tc_something_pending_disp 0x1B0 +#define tc_stack_cache_disp 0x158 +#define tc_stack_link_disp 0x160 +#define tc_subset_mode_disp 0x260 +#define tc_suppress_primitive_inlining_disp 0x268 +#define tc_target_machine_disp 0x218 #define tc_td_disp 0x98 -#define tc_threadno_disp 0x1D8 -#define tc_timer_ticks_disp 0x1B0 +#define tc_threadno_disp 0x1E0 +#define tc_timer_ticks_disp 0x1B8 #define tc_trap_disp 0x78 #define tc_ts_disp 0x90 -#define tc_virtual_registers_disp 0xA8 -#define tc_winders_disp 0x168 +#define tc_virtual_registers_disp 0xB0 +#define tc_winders_disp 0x170 #define tc_xp_disp 0x80 #define tc_yp_disp 0x88 #define thread_tc_disp 0x9 @@ -1165,6 +1191,7 @@ typedef uint64_t U64; #define type_thread 0x4E #define type_tlc 0xBE #define type_typed_object 0x7 +#define type_untyped 0x8 #define type_vector 0x0 #define typed_object_type_disp 0x1 #define typedef_i16 "int16_t" @@ -1451,90 +1478,91 @@ typedef uint64_t U64; #define VFASLHEADER_SINGLETONREF_COUNT(x) (*((uptr *)TO_VOIDP((uptr)(x)+104))) /* machine types */ -#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"} +#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", "arm32fb", "tarm32fb", "ppc32fb", "tppc32fb", "arm64fb", "tarm64fb", "arm32ob", "tarm32ob", "ppc32ob", "tppc32ob", "arm64ob", "tarm64ob", "arm32nb", "tarm32nb", "ppc32nb", "tppc32nb", "arm64nb", "tarm64nb"} /* 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" +#define alloc_space_names "new", "impure", "symbol", "port", "pure", "cont", "code", "p-tobj", "ip-rec", "ip-tobj", "closure", "im-impure", "cnt-pure", "cnt-impure", "weakpr", "emph", "ref-array", "data", "im-data", "empty" /* allocation-space characters */ -#define alloc_space_chars 'n', 'i', 'x', 'q', 'w', 'e', 'p', 'k', 'c', 'r', 's', 't', 'l', 'I', 'y', 'z', 'd', 'D', 'e' +#define alloc_space_chars 'n', 'i', 'x', 'q', 'p', 'k', 'c', 'r', 's', 't', 'l', 'I', 'y', 'z', 'w', 'e', 'a', 'd', 'D', 'e' /* threads */ #define THREADTYPE(x) (*((iptr *)TO_VOIDP((uptr)(x)+1))) #define THREADTC(x) (*((uptr *)TO_VOIDP((uptr)(x)+9))) /* thread-context data */ -#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))) -#define X(x) (*((ptr *)TO_VOIDP((uptr)(x)+408))) -#define Y(x) (*((ptr *)TO_VOIDP((uptr)(x)+416))) +#define DSTBV(x) (*((ptr *)TO_VOIDP((uptr)(x)+688))) +#define SRCBV(x) (*((ptr *)TO_VOIDP((uptr)(x)+696))) +#define U(x) (*((ptr *)TO_VOIDP((uptr)(x)+392))) +#define V(x) (*((ptr *)TO_VOIDP((uptr)(x)+400))) +#define W(x) (*((ptr *)TO_VOIDP((uptr)(x)+408))) +#define X(x) (*((ptr *)TO_VOIDP((uptr)(x)+416))) +#define Y(x) (*((ptr *)TO_VOIDP((uptr)(x)+424))) #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)+664))) +#define ACTIVE(x) (*((I32 *)TO_VOIDP((uptr)(x)+332))) +#define ALLOCCOUNTER(x) (*((U64 *)TO_VOIDP((uptr)(x)+672))) #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))) -#define BLOCKCOUNTER(x) (*((ptr *)TO_VOIDP((uptr)(x)+504))) -#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)+560))) -#define COMPRESSFORMAT(x) (*((ptr *)TO_VOIDP((uptr)(x)+632))) -#define COMPRESSLEVEL(x) (*((ptr *)TO_VOIDP((uptr)(x)+640))) +#define ATTACHMENTS(x) (*((ptr *)TO_VOIDP((uptr)(x)+376))) +#define BLOCKCOUNTER(x) (*((ptr *)TO_VOIDP((uptr)(x)+512))) +#define CACHEDFRAME(x) (*((ptr *)TO_VOIDP((uptr)(x)+384))) +#define CCHAIN(x) (*((ptr *)TO_VOIDP((uptr)(x)+312))) +#define CODERANGESTOFLUSH(x) (*((ptr *)TO_VOIDP((uptr)(x)+320))) +#define COMPILEPROFILE(x) (*((ptr *)TO_VOIDP((uptr)(x)+568))) +#define COMPRESSFORMAT(x) (*((ptr *)TO_VOIDP((uptr)(x)+640))) +#define COMPRESSLEVEL(x) (*((ptr *)TO_VOIDP((uptr)(x)+648))) #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)+616))) -#define DEFAULTRECORDHASHPROCEDURE(x) (*((ptr *)TO_VOIDP((uptr)(x)+624))) -#define DISABLECOUNT(x) (*((ptr *)TO_VOIDP((uptr)(x)+440))) +#define CURRENTERROR(x) (*((ptr *)TO_VOIDP((uptr)(x)+504))) +#define CURRENTINPUT(x) (*((ptr *)TO_VOIDP((uptr)(x)+488))) +#define CURRENTMSO(x) (*((ptr *)TO_VOIDP((uptr)(x)+528))) +#define CURRENTOUTPUT(x) (*((ptr *)TO_VOIDP((uptr)(x)+496))) +#define DEFAULTRECORDEQUALPROCEDURE(x) (*((ptr *)TO_VOIDP((uptr)(x)+624))) +#define DEFAULTRECORDHASHPROCEDURE(x) (*((ptr *)TO_VOIDP((uptr)(x)+632))) +#define DISABLECOUNT(x) (*((ptr *)TO_VOIDP((uptr)(x)+448))) #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)+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)+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)+656))) -#define KEYBOARDINTERRUPTPENDING(x) (*((ptr *)TO_VOIDP((uptr)(x)+464))) -#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 FPREGS(x,i) (((double *)TO_VOIDP((uptr)(x)+704))[i]) +#define FXFIRSTBITSETBV(x) (*((ptr *)TO_VOIDP((uptr)(x)+552))) +#define FXLENGTHBV(x) (*((ptr *)TO_VOIDP((uptr)(x)+544))) +#define GCDATA(x) (*((xptr *)TO_VOIDP((uptr)(x)+768))) +#define GENERATEINSPECTORINFORMATION(x) (*((ptr *)TO_VOIDP((uptr)(x)+576))) +#define GENERATEPROCEDURESOURCEINFORMATION(x) (*((ptr *)TO_VOIDP((uptr)(x)+584))) +#define GENERATEPROFILEFORMS(x) (*((ptr *)TO_VOIDP((uptr)(x)+592))) +#define GUARDIANENTRIES(x) (*((ptr *)TO_VOIDP((uptr)(x)+304))) +#define INSTRCOUNTER(x) (*((U64 *)TO_VOIDP((uptr)(x)+664))) +#define KEYBOARDINTERRUPTPENDING(x) (*((ptr *)TO_VOIDP((uptr)(x)+472))) +#define LZ4OUTBUFFER(x) (*((xptr *)TO_VOIDP((uptr)(x)+656))) +#define METALEVEL(x) (*((ptr *)TO_VOIDP((uptr)(x)+560))) +#define OPTIMIZELEVEL(x) (*((ptr *)TO_VOIDP((uptr)(x)+600))) +#define PARAMETERS(x) (*((ptr *)TO_VOIDP((uptr)(x)+680))) +#define RANDOMSEED(x) (*((U32 *)TO_VOIDP((uptr)(x)+328))) #define REAL_EAP(x) (*((xptr *)TO_VOIDP((uptr)(x)+160))) #define RET(x) (*((xptr *)TO_VOIDP((uptr)(x)+112))) -#define SCHEMESTACK(x) (*((xptr *)TO_VOIDP((uptr)(x)+328))) -#define SCHEMESTACKSIZE(x) (*((iptr *)TO_VOIDP((uptr)(x)+352))) -#define SFD(x) (*((ptr *)TO_VOIDP((uptr)(x)+512))) +#define SAVE1(x) (*((xptr *)TO_VOIDP((uptr)(x)+168))) +#define SCHEMESTACK(x) (*((xptr *)TO_VOIDP((uptr)(x)+336))) +#define SCHEMESTACKSIZE(x) (*((iptr *)TO_VOIDP((uptr)(x)+360))) +#define SFD(x) (*((ptr *)TO_VOIDP((uptr)(x)+520))) #define SFP(x) (*((xptr *)TO_VOIDP((uptr)(x)+72))) -#define SIGNALINTERRUPTPENDING(x) (*((ptr *)TO_VOIDP((uptr)(x)+448))) -#define SIGNALINTERRUPTQUEUE(x) (*((ptr *)TO_VOIDP((uptr)(x)+456))) -#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)+600))) -#define SUPPRESSPRIMITIVEINLINING(x) (*((ptr *)TO_VOIDP((uptr)(x)+608))) -#define TARGETMACHINE(x) (*((ptr *)TO_VOIDP((uptr)(x)+528))) +#define SIGNALINTERRUPTPENDING(x) (*((ptr *)TO_VOIDP((uptr)(x)+456))) +#define SIGNALINTERRUPTQUEUE(x) (*((ptr *)TO_VOIDP((uptr)(x)+464))) +#define SOMETHINGPENDING(x) (*((ptr *)TO_VOIDP((uptr)(x)+432))) +#define STACKCACHE(x) (*((ptr *)TO_VOIDP((uptr)(x)+344))) +#define STACKLINK(x) (*((ptr *)TO_VOIDP((uptr)(x)+352))) +#define SUBSETMODE(x) (*((ptr *)TO_VOIDP((uptr)(x)+608))) +#define SUPPRESSPRIMITIVEINLINING(x) (*((ptr *)TO_VOIDP((uptr)(x)+616))) +#define TARGETMACHINE(x) (*((ptr *)TO_VOIDP((uptr)(x)+536))) #define TD(x) (*((xptr *)TO_VOIDP((uptr)(x)+152))) -#define THREADNO(x) (*((ptr *)TO_VOIDP((uptr)(x)+472))) -#define TIMERTICKS(x) (*((ptr *)TO_VOIDP((uptr)(x)+432))) +#define THREADNO(x) (*((ptr *)TO_VOIDP((uptr)(x)+480))) +#define TIMERTICKS(x) (*((ptr *)TO_VOIDP((uptr)(x)+440))) #define TRAP(x) (*((xptr *)TO_VOIDP((uptr)(x)+120))) #define TS(x) (*((xptr *)TO_VOIDP((uptr)(x)+144))) -#define VIRTUALREGISTERS(x,i) (((ptr *)TO_VOIDP((uptr)(x)+168))[i]) -#define WINDERS(x) (*((ptr *)TO_VOIDP((uptr)(x)+360))) +#define VIRTUALREGISTERS(x,i) (((ptr *)TO_VOIDP((uptr)(x)+176))[i]) +#define WINDERS(x) (*((ptr *)TO_VOIDP((uptr)(x)+368))) #define XP(x) (*((xptr *)TO_VOIDP((uptr)(x)+128))) #define YP(x) (*((xptr *)TO_VOIDP((uptr)(x)+136))) #define ARGREG(x,i) (((xptr *)TO_VOIDP((uptr)(x)+0))[i]) -#define VIRTREG(x,i) (((ptr *)TO_VOIDP((uptr)(x)+168))[i]) +#define VIRTREG(x,i) (((ptr *)TO_VOIDP((uptr)(x)+176))[i]) /* library entries we access from C code */ #define library_nonprocedure_code 156 diff --git a/src/ChezScheme/boot/pb/gc-ocd.inc b/src/ChezScheme/boot/pb/gc-ocd.inc index 8d8f066307..0d0b86b115 100644 --- a/src/ChezScheme/boot/pb/gc-ocd.inc +++ b/src/ChezScheme/boot/pb/gc-ocd.inc @@ -117,13 +117,39 @@ static IGEN copy(thread_gc *tgc, ptr p, seginfo *si, ptr *dest) } else if (TYPEP(tf, mask_bytevector, type_bytevector)) { - ISPC p_spc = space_data; { - uptr sz = size_bytevector((Sbytevector_length(p))); + ISPC p_at_spc = si->space; + if (p_at_spc == space_reference_array) { - uptr p_sz = sz; - find_gc_room(tgc, p_spc, tg, type_typed_object, p_sz, new_p); - memcpy_aligned(&BYTEVECTOR_TYPE(new_p), &BYTEVECTOR_TYPE(p), sz); + ISPC p_spc = space_reference_array; + { + uptr sz = size_bytevector((Sbytevector_length(p))); + { + uptr p_sz = sz; + find_gc_room(tgc, p_spc, tg, type_typed_object, p_sz, new_p); + BYTEVECTOR_TYPE(new_p) = (uptr)tf; + { + uptr len = Sbytevector_reference_length(p); + memcpy_aligned(&BVIT(new_p, 0), &BVIT(p, 0), ptr_bytes * len); + if ((len & 1) == 0) + { + INITBVREFIT(new_p, len) = FIX(0); + } + } + } + } + } + else + { + ISPC p_spc = space_data; + { + uptr sz = size_bytevector((Sbytevector_length(p))); + { + uptr p_sz = sz; + find_gc_room(tgc, p_spc, tg, type_typed_object, p_sz, new_p); + memcpy_aligned(&BYTEVECTOR_TYPE(new_p), &BYTEVECTOR_TYPE(p), sz); + } + } } } } @@ -315,21 +341,9 @@ static IGEN copy(thread_gc *tgc, ptr p, seginfo *si, ptr *dest) { { ISPC p_at_spc = si->space; - if (p_at_spc == space_ephemeron) - { - ISPC p_spc = space_ephemeron; - { - uptr p_sz = size_ephemeron; - find_gc_room(tgc, p_spc, tg, type_pair, p_sz, new_p); - INITCAR(new_p) = INITCAR(p); - INITCDR(new_p) = INITCDR(p); - INITEPHEMERONPREVREF(new_p) = 0; - INITEPHEMERONNEXT(new_p) = 0; - } - } - else if (p_at_spc == space_weakpair) + if (p_at_spc < space_weakpair) { - ISPC p_spc = space_weakpair; + ISPC p_spc = space_impure; { ptr cdr_p = Scdr(p); if ((cdr_p != p) && (((TYPEBITS(cdr_p)) == type_pair) && (((ptr_get_segment(cdr_p)) == (ptr_get_segment(p))) && (((FWDMARKER(cdr_p)) != forward_marker) && (!(si -> marked_mask)))))) @@ -355,9 +369,21 @@ static IGEN copy(thread_gc *tgc, ptr p, seginfo *si, ptr *dest) } } } - else + else if (p_at_spc == space_ephemeron) { - ISPC p_spc = space_impure; + ISPC p_spc = space_ephemeron; + { + uptr p_sz = size_ephemeron; + find_gc_room(tgc, p_spc, tg, type_pair, p_sz, new_p); + INITCAR(new_p) = INITCAR(p); + INITCDR(new_p) = INITCDR(p); + INITEPHEMERONPREVREF(new_p) = 0; + INITEPHEMERONNEXT(new_p) = 0; + } + } + else if (p_at_spc == space_weakpair) + { + ISPC p_spc = space_weakpair; { ptr cdr_p = Scdr(p); if ((cdr_p != p) && (((TYPEBITS(cdr_p)) == type_pair) && (((ptr_get_segment(cdr_p)) == (ptr_get_segment(p))) && (((FWDMARKER(cdr_p)) != forward_marker) && (!(si -> marked_mask)))))) @@ -383,6 +409,10 @@ static IGEN copy(thread_gc *tgc, ptr p, seginfo *si, ptr *dest) } } } + else + { + S_error_abort("misplaced pair"); + } } } else if (t == type_closure) @@ -599,6 +629,26 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) } else if (TYPEP(tf, mask_bytevector, type_bytevector)) { + { + ISPC p_at_spc = SPACE(p); + if (p_at_spc == space_reference_array) + { + { + uptr len = Sbytevector_reference_length(p); + { + uptr idx, p_len = len; + ptr *p_p = (ptr*)&BVIT(p, 0); + for (idx = 0; idx < p_len; idx++) + { + relocate_reference(&(p_p[idx]), from_g); + } + } + } + } + else + { + } + } } else if ((iptr)tf == type_tlc) { @@ -708,14 +758,14 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) { if (!(marked(t_si, t))) { - mark_typemod_data_object(tgc, t, n, t_si); + mark_untyped_data_object(tgc, t, n, t_si); } } else { { ptr oldt = t; - find_gc_room(tgc, space_data, from_g, typemod, n, t); + find_gc_room(tgc, space_data, from_g, type_untyped, n, t); memcpy_aligned(TO_VOIDP(t), TO_VOIDP(oldt), n); } } @@ -921,7 +971,12 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) { { ISPC p_at_spc = SPACE(p); - if (p_at_spc == space_ephemeron) + if (p_at_spc < space_weakpair) + { + relocate_impure(&INITCAR(p), from_g); + relocate_impure(&INITCDR(p), from_g); + } + else if (p_at_spc == space_ephemeron) { add_ephemeron_to_pending(tgc, p); } @@ -931,8 +986,8 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) } else { - relocate_impure(&INITCAR(p), from_g); - relocate_impure(&INITCDR(p), from_g); + relocate_reference(&INITCAR(p), from_g); + relocate_reference(&INITCDR(p), from_g); } } } @@ -1258,6 +1313,26 @@ static void sweep_object_in_old(thread_gc *tgc, ptr p) } else if (TYPEP(tf, mask_bytevector, type_bytevector)) { + { + ISPC p_at_spc = SPACE(p); + if (p_at_spc == space_reference_array) + { + { + uptr len = Sbytevector_reference_length(p); + { + uptr idx, p_len = len; + ptr *p_p = (ptr*)&BVIT(p, 0); + for (idx = 0; idx < p_len; idx++) + { + relocate_reference_indirect((p_p[idx])); + } + } + } + } + else + { + } + } } else if ((iptr)tf == type_tlc) { @@ -1514,7 +1589,12 @@ static void sweep_object_in_old(thread_gc *tgc, ptr p) { { ISPC p_at_spc = SPACE(p); - if (p_at_spc == space_ephemeron) + if (p_at_spc < space_weakpair) + { + relocate_indirect(INITCAR(p)); + relocate_indirect(INITCDR(p)); + } + else if (p_at_spc == space_ephemeron) { } else if (p_at_spc == space_weakpair) @@ -1523,8 +1603,7 @@ static void sweep_object_in_old(thread_gc *tgc, ptr p) } else { - relocate_indirect(INITCAR(p)); - relocate_indirect(INITCDR(p)); + S_error_abort("misplaced pair"); } } } @@ -1813,6 +1892,26 @@ static IGEN sweep_dirty_object(thread_gc *tgc, ptr p, IGEN youngest) } else if (TYPEP(tf, mask_bytevector, type_bytevector)) { + { + ISPC p_at_spc = SPACE(p); + if (p_at_spc == space_reference_array) + { + { + uptr len = Sbytevector_reference_length(p); + { + uptr idx, p_len = len; + ptr *p_p = (ptr*)&BVIT(p, 0); + for (idx = 0; idx < p_len; idx++) + { + relocate_reference_dirty(&(p_p[idx]), youngest); + } + } + } + } + else + { + } + } } else if ((iptr)tf == type_tlc) { @@ -1875,7 +1974,12 @@ static IGEN sweep_dirty_object(thread_gc *tgc, ptr p, IGEN youngest) { { ISPC p_at_spc = SPACE(p); - if (p_at_spc == space_ephemeron) + if (p_at_spc < space_weakpair) + { + relocate_dirty(&INITCAR(p), youngest); + relocate_dirty(&INITCDR(p), youngest); + } + else if (p_at_spc == space_ephemeron) { add_ephemeron_to_pending(tgc, p); } @@ -1885,8 +1989,8 @@ static IGEN sweep_dirty_object(thread_gc *tgc, ptr p, IGEN youngest) } else { - relocate_dirty(&INITCAR(p), youngest); - relocate_dirty(&INITCDR(p), youngest); + relocate_reference_dirty(&INITCAR(p), youngest); + relocate_reference_dirty(&INITCDR(p), youngest); } } } @@ -2565,14 +2669,14 @@ static void sweep_code_object(thread_gc *tgc, ptr p, IGEN from_g) { if (!(marked(t_si, t))) { - mark_typemod_data_object(tgc, t, n, t_si); + mark_untyped_data_object(tgc, t, n, t_si); } } else { { ptr oldt = t; - find_gc_room(tgc, space_data, from_g, typemod, n, t); + find_gc_room(tgc, space_data, from_g, type_untyped, n, t); memcpy_aligned(TO_VOIDP(t), TO_VOIDP(oldt), n); } } @@ -2657,10 +2761,24 @@ static uptr size_object(ptr p) } else if (TYPEP(tf, mask_bytevector, type_bytevector)) { - uptr sz = size_bytevector((Sbytevector_length(p))); { - uptr p_sz = sz; - return p_sz; + ISPC p_at_spc = SPACE(p); + if (p_at_spc == space_reference_array) + { + uptr sz = size_bytevector((Sbytevector_length(p))); + { + uptr p_sz = sz; + return p_sz; + } + } + else + { + uptr sz = size_bytevector((Sbytevector_length(p))); + { + uptr p_sz = sz; + return p_sz; + } + } } } else if ((iptr)tf == type_tlc) @@ -2733,7 +2851,12 @@ static uptr size_object(ptr p) { { ISPC p_at_spc = SPACE(p); - if (p_at_spc == space_ephemeron) + if (p_at_spc < space_weakpair) + { + uptr p_sz = size_pair; + return p_sz; + } + else if (p_at_spc == space_ephemeron) { uptr p_sz = size_ephemeron; return p_sz; @@ -2745,8 +2868,7 @@ static uptr size_object(ptr p) } else { - uptr p_sz = size_pair; - return p_sz; + S_error_abort("misplaced pair"); } } } @@ -3002,35 +3124,78 @@ static IGEN mark_object(thread_gc *tgc, ptr p, seginfo *si) } else if (TYPEP(tf, mask_bytevector, type_bytevector)) { - uptr sz = size_bytevector((Sbytevector_length(p))); { - uptr p_sz = sz; - si->marked_mask[segment_bitmap_byte(p)] |= segment_bitmap_bit(p); + ISPC p_at_spc = si->space; + if (p_at_spc == space_reference_array) { - 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++; + uptr sz = size_bytevector((Sbytevector_length(p))); + { + uptr p_sz = sz; + { + uptr addr = (uptr)UNTYPE(p, type_typed_object); + if (addr_get_segment(addr) == addr_get_segment(addr + p_sz - 1)) + { + si->marked_count += p_sz; + { + uptr offset = 0; + while (offset < p_sz) { + ptr mark_p = (ptr)((uptr)p + offset); + si->marked_mask[segment_bitmap_byte(mark_p)] |= segment_bitmap_bit(mark_p); + offset += byte_alignment; + } + } + } + else + { + uptr offset = 0; + while (offset < p_sz) { + ptr mark_p = (ptr)((uptr)p + offset); + seginfo *mark_si = SegInfo(ptr_get_segment(mark_p)); + if (!mark_si->marked_mask) { + init_mask(tgc, mark_si->marked_mask, mark_si->generation, 0); + } + mark_si->marked_mask[segment_bitmap_byte(mark_p)] |= segment_bitmap_bit(mark_p); + mark_si->marked_count += byte_alignment; + offset += byte_alignment; + } + } } - mark_si = SegInfo(end_seg); + push_sweep(p); + } + } + else + { + uptr sz = size_bytevector((Sbytevector_length(p))); + { + uptr p_sz = sz; + si->marked_mask[segment_bitmap_byte(p)] |= segment_bitmap_bit(p); { - if (!mark_si->marked_mask) { - init_mask(tgc, mark_si->marked_mask, mark_si->generation, 0); + 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); + } } - /* 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); } } } @@ -3212,7 +3377,14 @@ static IGEN mark_object(thread_gc *tgc, ptr p, seginfo *si) { { ISPC p_at_spc = si->space; - if (p_at_spc == space_ephemeron) + if (p_at_spc < space_weakpair) + { + uptr p_sz = size_pair; + si->marked_mask[segment_bitmap_byte(p)] |= segment_bitmap_bit(p); + si->marked_count += p_sz; + push_sweep(p); + } + else if (p_at_spc == space_ephemeron) { uptr p_sz = size_ephemeron; add_ephemeron_to_pending(tgc, p); @@ -3228,10 +3400,7 @@ static IGEN mark_object(thread_gc *tgc, ptr p, seginfo *si) } else { - uptr p_sz = size_pair; - si->marked_mask[segment_bitmap_byte(p)] |= segment_bitmap_bit(p); - si->marked_count += p_sz; - push_sweep(p); + S_error_abort("misplaced pair"); } } } @@ -3444,7 +3613,7 @@ static IBOOL object_directly_refers_to_self(ptr p) ptr *p_p = &INITVECTIT(p, 0); for (idx = 0; idx < p_len; idx++) { - if (p_p[idx] == p) return 1; + if (p == p_p[idx]) return 1; } } } @@ -3456,7 +3625,7 @@ static IBOOL object_directly_refers_to_self(ptr p) ptr *p_p = &INITSTENVECTIT(p, 0); for (idx = 0; idx < p_len; idx++) { - if (p_p[idx] == p) return 1; + if (p == p_p[idx]) return 1; } } } @@ -3471,6 +3640,26 @@ static IBOOL object_directly_refers_to_self(ptr p) } else if (TYPEP(tf, mask_bytevector, type_bytevector)) { + { + ISPC p_at_spc = SPACE(p); + if (p_at_spc == space_reference_array) + { + { + uptr len = Sbytevector_reference_length(p); + { + uptr idx, p_len = len; + ptr *p_p = (ptr*)&BVIT(p, 0); + for (idx = 0; idx < p_len; idx++) + { + if (p == S_maybe_reference_to_object(p_p[idx])) return 1; + } + } + } + } + else + { + } + } } else if ((iptr)tf == type_tlc) { @@ -3561,7 +3750,12 @@ static IBOOL object_directly_refers_to_self(ptr p) { { ISPC p_at_spc = SPACE(p); - if (p_at_spc == space_ephemeron) + if (p_at_spc < space_weakpair) + { + if (p == INITCAR(p)) return 1; + if (p == INITCDR(p)) return 1; + } + else if (p_at_spc == space_ephemeron) { } else if (p_at_spc == space_weakpair) @@ -3570,8 +3764,7 @@ static IBOOL object_directly_refers_to_self(ptr p) } else { - if (p == INITCAR(p)) return 1; - if (p == INITCDR(p)) return 1; + S_error_abort("misplaced pair"); } } } @@ -3590,7 +3783,7 @@ static IBOOL object_directly_refers_to_self(ptr p) ptr *p_p = &CLOSIT(p, 0); for (idx = 0; idx < p_len; idx++) { - if (p_p[idx] == p) return 1; + if (p == p_p[idx]) return 1; } } } @@ -3609,7 +3802,7 @@ static IBOOL object_directly_refers_to_self(ptr p) return 0; } -static void mark_typemod_data_object(thread_gc *tgc, ptr p, uptr p_sz, seginfo *si) +static void mark_untyped_data_object(thread_gc *tgc, ptr p, uptr p_sz, seginfo *si) { if (!si->marked_mask) { init_mask(tgc, si->marked_mask, si->generation, 0); diff --git a/src/ChezScheme/boot/pb/gc-oce.inc b/src/ChezScheme/boot/pb/gc-oce.inc index 651e849b60..bd5e95a4df 100644 --- a/src/ChezScheme/boot/pb/gc-oce.inc +++ b/src/ChezScheme/boot/pb/gc-oce.inc @@ -192,15 +192,43 @@ static IGEN copy(thread_gc *tgc, ptr p, seginfo *si, ptr *dest) } else if (TYPEP(tf, mask_bytevector, type_bytevector)) { - ISPC p_spc = space_data; { - uptr sz = size_bytevector((Sbytevector_length(p))); + ISPC p_at_spc = si->space; + if (p_at_spc == space_reference_array) { - uptr p_sz = sz; - find_gc_room(tgc, p_spc, tg, type_typed_object, p_sz, new_p); - memcpy_aligned(&BYTEVECTOR_TYPE(new_p), &BYTEVECTOR_TYPE(p), sz); - S_G.countof[tg][countof_bytevector] += 1; - S_G.bytesof[tg][countof_bytevector] += p_sz; + ISPC p_spc = space_reference_array; + { + uptr sz = size_bytevector((Sbytevector_length(p))); + { + uptr p_sz = sz; + find_gc_room(tgc, p_spc, tg, type_typed_object, p_sz, new_p); + BYTEVECTOR_TYPE(new_p) = (uptr)tf; + { + uptr len = Sbytevector_reference_length(p); + memcpy_aligned(&BVIT(new_p, 0), &BVIT(p, 0), ptr_bytes * len); + if ((len & 1) == 0) + { + INITBVREFIT(new_p, len) = FIX(0); + } + S_G.countof[tg][countof_bytevector] += 1; + S_G.bytesof[tg][countof_bytevector] += p_sz; + } + } + } + } + else + { + ISPC p_spc = space_data; + { + uptr sz = size_bytevector((Sbytevector_length(p))); + { + uptr p_sz = sz; + find_gc_room(tgc, p_spc, tg, type_typed_object, p_sz, new_p); + memcpy_aligned(&BYTEVECTOR_TYPE(new_p), &BYTEVECTOR_TYPE(p), sz); + S_G.countof[tg][countof_bytevector] += 1; + S_G.bytesof[tg][countof_bytevector] += p_sz; + } + } } } } @@ -413,22 +441,9 @@ static IGEN copy(thread_gc *tgc, ptr p, seginfo *si, ptr *dest) { { ISPC p_at_spc = si->space; - if (p_at_spc == space_ephemeron) + if (p_at_spc < space_weakpair) { - ISPC p_spc = space_ephemeron; - { - uptr p_sz = size_ephemeron; - find_gc_room(tgc, p_spc, tg, type_pair, p_sz, new_p); - INITCAR(new_p) = INITCAR(p); - INITCDR(new_p) = INITCDR(p); - INITEPHEMERONPREVREF(new_p) = 0; - INITEPHEMERONNEXT(new_p) = 0; - S_G.countof[tg][countof_ephemeron] += 1; - } - } - else if (p_at_spc == space_weakpair) - { - ISPC p_spc = space_weakpair; + ISPC p_spc = space_impure; { ptr cdr_p = Scdr(p); if ((cdr_p != p) && (((TYPEBITS(cdr_p)) == type_pair) && (((ptr_get_segment(cdr_p)) == (ptr_get_segment(p))) && (((FWDMARKER(cdr_p)) != forward_marker) && (!(si -> marked_mask)))))) @@ -444,7 +459,7 @@ static IGEN copy(thread_gc *tgc, ptr p, seginfo *si, ptr *dest) FWDMARKER(cdr_p) = forward_marker; FWDADDRESS(cdr_p) = new_cdr_p; ADD_BACKREFERENCE_FROM(new_cdr_p, new_p, tg); - S_G.countof[tg][countof_weakpair] += 2; + S_G.countof[tg][countof_pair] += 2; } } else @@ -453,13 +468,26 @@ static IGEN copy(thread_gc *tgc, ptr p, seginfo *si, ptr *dest) find_gc_room(tgc, p_spc, tg, type_pair, p_sz, new_p); INITCAR(new_p) = INITCAR(p); INITCDR(new_p) = INITCDR(p); - S_G.countof[tg][countof_weakpair] += 1; + S_G.countof[tg][countof_pair] += 1; } } } - else + else if (p_at_spc == space_ephemeron) { - ISPC p_spc = space_impure; + ISPC p_spc = space_ephemeron; + { + uptr p_sz = size_ephemeron; + find_gc_room(tgc, p_spc, tg, type_pair, p_sz, new_p); + INITCAR(new_p) = INITCAR(p); + INITCDR(new_p) = INITCDR(p); + INITEPHEMERONPREVREF(new_p) = 0; + INITEPHEMERONNEXT(new_p) = 0; + S_G.countof[tg][countof_ephemeron] += 1; + } + } + else if (p_at_spc == space_weakpair) + { + ISPC p_spc = space_weakpair; { ptr cdr_p = Scdr(p); if ((cdr_p != p) && (((TYPEBITS(cdr_p)) == type_pair) && (((ptr_get_segment(cdr_p)) == (ptr_get_segment(p))) && (((FWDMARKER(cdr_p)) != forward_marker) && (!(si -> marked_mask)))))) @@ -475,7 +503,7 @@ static IGEN copy(thread_gc *tgc, ptr p, seginfo *si, ptr *dest) FWDMARKER(cdr_p) = forward_marker; FWDADDRESS(cdr_p) = new_cdr_p; ADD_BACKREFERENCE_FROM(new_cdr_p, new_p, tg); - S_G.countof[tg][countof_pair] += 2; + S_G.countof[tg][countof_weakpair] += 2; } } else @@ -484,10 +512,14 @@ static IGEN copy(thread_gc *tgc, ptr p, seginfo *si, ptr *dest) find_gc_room(tgc, p_spc, tg, type_pair, p_sz, new_p); INITCAR(new_p) = INITCAR(p); INITCDR(new_p) = INITCDR(p); - S_G.countof[tg][countof_pair] += 1; + S_G.countof[tg][countof_weakpair] += 1; } } } + else + { + S_error_abort("misplaced pair"); + } } } else if (t == type_closure) @@ -717,6 +749,26 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) } else if (TYPEP(tf, mask_bytevector, type_bytevector)) { + { + ISPC p_at_spc = SPACE(p); + if (p_at_spc == space_reference_array) + { + { + uptr len = Sbytevector_reference_length(p); + { + uptr idx, p_len = len; + ptr *p_p = (ptr*)&BVIT(p, 0); + for (idx = 0; idx < p_len; idx++) + { + relocate_reference(&(p_p[idx]), from_g); + } + } + } + } + else + { + } + } } else if ((iptr)tf == type_tlc) { @@ -828,14 +880,14 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) { if (!(marked(t_si, t))) { - mark_typemod_data_object(tgc, t, n, t_si); + mark_untyped_data_object(tgc, t, n, t_si); } } else { { ptr oldt = t; - find_gc_room(tgc, space_data, from_g, typemod, n, t); + find_gc_room(tgc, space_data, from_g, type_untyped, n, t); memcpy_aligned(TO_VOIDP(t), TO_VOIDP(oldt), n); } } @@ -1041,7 +1093,12 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) { { ISPC p_at_spc = SPACE(p); - if (p_at_spc == space_ephemeron) + if (p_at_spc < space_weakpair) + { + relocate_impure(&INITCAR(p), from_g); + relocate_impure(&INITCDR(p), from_g); + } + else if (p_at_spc == space_ephemeron) { add_ephemeron_to_pending(tgc, p); } @@ -1051,8 +1108,8 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) } else { - relocate_impure(&INITCAR(p), from_g); - relocate_impure(&INITCDR(p), from_g); + relocate_reference(&INITCAR(p), from_g); + relocate_reference(&INITCDR(p), from_g); } } } @@ -1379,6 +1436,26 @@ static void sweep_object_in_old(thread_gc *tgc, ptr p) } else if (TYPEP(tf, mask_bytevector, type_bytevector)) { + { + ISPC p_at_spc = SPACE(p); + if (p_at_spc == space_reference_array) + { + { + uptr len = Sbytevector_reference_length(p); + { + uptr idx, p_len = len; + ptr *p_p = (ptr*)&BVIT(p, 0); + for (idx = 0; idx < p_len; idx++) + { + relocate_reference_indirect((p_p[idx])); + } + } + } + } + else + { + } + } } else if ((iptr)tf == type_tlc) { @@ -1635,7 +1712,12 @@ static void sweep_object_in_old(thread_gc *tgc, ptr p) { { ISPC p_at_spc = SPACE(p); - if (p_at_spc == space_ephemeron) + if (p_at_spc < space_weakpair) + { + relocate_indirect(INITCAR(p)); + relocate_indirect(INITCDR(p)); + } + else if (p_at_spc == space_ephemeron) { } else if (p_at_spc == space_weakpair) @@ -1644,8 +1726,7 @@ static void sweep_object_in_old(thread_gc *tgc, ptr p) } else { - relocate_indirect(INITCAR(p)); - relocate_indirect(INITCDR(p)); + S_error_abort("misplaced pair"); } } } @@ -1935,6 +2016,26 @@ static IGEN sweep_dirty_object(thread_gc *tgc, ptr p, IGEN youngest) } else if (TYPEP(tf, mask_bytevector, type_bytevector)) { + { + ISPC p_at_spc = SPACE(p); + if (p_at_spc == space_reference_array) + { + { + uptr len = Sbytevector_reference_length(p); + { + uptr idx, p_len = len; + ptr *p_p = (ptr*)&BVIT(p, 0); + for (idx = 0; idx < p_len; idx++) + { + relocate_reference_dirty(&(p_p[idx]), youngest); + } + } + } + } + else + { + } + } } else if ((iptr)tf == type_tlc) { @@ -1997,7 +2098,12 @@ static IGEN sweep_dirty_object(thread_gc *tgc, ptr p, IGEN youngest) { { ISPC p_at_spc = SPACE(p); - if (p_at_spc == space_ephemeron) + if (p_at_spc < space_weakpair) + { + relocate_dirty(&INITCAR(p), youngest); + relocate_dirty(&INITCDR(p), youngest); + } + else if (p_at_spc == space_ephemeron) { add_ephemeron_to_pending(tgc, p); } @@ -2007,8 +2113,8 @@ static IGEN sweep_dirty_object(thread_gc *tgc, ptr p, IGEN youngest) } else { - relocate_dirty(&INITCAR(p), youngest); - relocate_dirty(&INITCDR(p), youngest); + relocate_reference_dirty(&INITCAR(p), youngest); + relocate_reference_dirty(&INITCDR(p), youngest); } } } @@ -2707,14 +2813,14 @@ static void sweep_code_object(thread_gc *tgc, ptr p, IGEN from_g) { if (!(marked(t_si, t))) { - mark_typemod_data_object(tgc, t, n, t_si); + mark_untyped_data_object(tgc, t, n, t_si); } } else { { ptr oldt = t; - find_gc_room(tgc, space_data, from_g, typemod, n, t); + find_gc_room(tgc, space_data, from_g, type_untyped, n, t); memcpy_aligned(TO_VOIDP(t), TO_VOIDP(oldt), n); } } @@ -2800,10 +2906,24 @@ static uptr size_object(ptr p) } else if (TYPEP(tf, mask_bytevector, type_bytevector)) { - uptr sz = size_bytevector((Sbytevector_length(p))); { - uptr p_sz = sz; - return p_sz; + ISPC p_at_spc = SPACE(p); + if (p_at_spc == space_reference_array) + { + uptr sz = size_bytevector((Sbytevector_length(p))); + { + uptr p_sz = sz; + return p_sz; + } + } + else + { + uptr sz = size_bytevector((Sbytevector_length(p))); + { + uptr p_sz = sz; + return p_sz; + } + } } } else if ((iptr)tf == type_tlc) @@ -2876,7 +2996,12 @@ static uptr size_object(ptr p) { { ISPC p_at_spc = SPACE(p); - if (p_at_spc == space_ephemeron) + if (p_at_spc < space_weakpair) + { + uptr p_sz = size_pair; + return p_sz; + } + else if (p_at_spc == space_ephemeron) { uptr p_sz = size_ephemeron; return p_sz; @@ -2888,8 +3013,7 @@ static uptr size_object(ptr p) } else { - uptr p_sz = size_pair; - return p_sz; + S_error_abort("misplaced pair"); } } } @@ -3205,40 +3329,85 @@ static IGEN mark_object(thread_gc *tgc, ptr p, seginfo *si) } else if (TYPEP(tf, mask_bytevector, type_bytevector)) { - uptr sz = size_bytevector((Sbytevector_length(p))); { - uptr p_sz = sz; - si->marked_mask[segment_bitmap_byte(p)] |= segment_bitmap_bit(p); + ISPC p_at_spc = si->space; + if (p_at_spc == space_reference_array) { - 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++; + uptr sz = size_bytevector((Sbytevector_length(p))); + { + uptr p_sz = sz; + { + uptr addr = (uptr)UNTYPE(p, type_typed_object); + if (addr_get_segment(addr) == addr_get_segment(addr + p_sz - 1)) + { + si->marked_count += p_sz; + { + uptr offset = 0; + while (offset < p_sz) { + ptr mark_p = (ptr)((uptr)p + offset); + si->marked_mask[segment_bitmap_byte(mark_p)] |= segment_bitmap_bit(mark_p); + offset += byte_alignment; + } + } + } + else + { + uptr offset = 0; + while (offset < p_sz) { + ptr mark_p = (ptr)((uptr)p + offset); + seginfo *mark_si = SegInfo(ptr_get_segment(mark_p)); + if (!mark_si->marked_mask) { + init_mask(tgc, mark_si->marked_mask, mark_si->generation, 0); + } + mark_si->marked_mask[segment_bitmap_byte(mark_p)] |= segment_bitmap_bit(mark_p); + mark_si->marked_count += byte_alignment; + offset += byte_alignment; + } + } } - mark_si = SegInfo(end_seg); + push_sweep(p); + S_G.countof[TARGET_GENERATION(si)][countof_bytevector] += 1; + S_G.bytesof[TARGET_GENERATION(si)][countof_bytevector] += p_sz; + } + } + else + { + uptr sz = size_bytevector((Sbytevector_length(p))); + { + uptr p_sz = sz; + si->marked_mask[segment_bitmap_byte(p)] |= segment_bitmap_bit(p); { - if (!mark_si->marked_mask) { - init_mask(tgc, mark_si->marked_mask, mark_si->generation, 0); + 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); + } } - /* 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_bytevector] += 1; + S_G.bytesof[TARGET_GENERATION(si)][countof_bytevector] += p_sz; } } - S_G.countof[TARGET_GENERATION(si)][countof_bytevector] += 1; - S_G.bytesof[TARGET_GENERATION(si)][countof_bytevector] += p_sz; } } else if ((iptr)tf == type_tlc) @@ -3430,7 +3599,15 @@ static IGEN mark_object(thread_gc *tgc, ptr p, seginfo *si) { { ISPC p_at_spc = si->space; - if (p_at_spc == space_ephemeron) + if (p_at_spc < space_weakpair) + { + uptr p_sz = size_pair; + si->marked_mask[segment_bitmap_byte(p)] |= segment_bitmap_bit(p); + si->marked_count += p_sz; + push_sweep(p); + S_G.countof[TARGET_GENERATION(si)][countof_pair] += 1; + } + else if (p_at_spc == space_ephemeron) { uptr p_sz = size_ephemeron; add_ephemeron_to_pending(tgc, p); @@ -3448,11 +3625,7 @@ static IGEN mark_object(thread_gc *tgc, ptr p, seginfo *si) } else { - uptr p_sz = size_pair; - si->marked_mask[segment_bitmap_byte(p)] |= segment_bitmap_bit(p); - si->marked_count += p_sz; - push_sweep(p); - S_G.countof[TARGET_GENERATION(si)][countof_pair] += 1; + S_error_abort("misplaced pair"); } } } @@ -3683,7 +3856,7 @@ static IBOOL object_directly_refers_to_self(ptr p) ptr *p_p = &INITVECTIT(p, 0); for (idx = 0; idx < p_len; idx++) { - if (p_p[idx] == p) return 1; + if (p == p_p[idx]) return 1; } } } @@ -3695,7 +3868,7 @@ static IBOOL object_directly_refers_to_self(ptr p) ptr *p_p = &INITSTENVECTIT(p, 0); for (idx = 0; idx < p_len; idx++) { - if (p_p[idx] == p) return 1; + if (p == p_p[idx]) return 1; } } } @@ -3710,6 +3883,26 @@ static IBOOL object_directly_refers_to_self(ptr p) } else if (TYPEP(tf, mask_bytevector, type_bytevector)) { + { + ISPC p_at_spc = SPACE(p); + if (p_at_spc == space_reference_array) + { + { + uptr len = Sbytevector_reference_length(p); + { + uptr idx, p_len = len; + ptr *p_p = (ptr*)&BVIT(p, 0); + for (idx = 0; idx < p_len; idx++) + { + if (p == S_maybe_reference_to_object(p_p[idx])) return 1; + } + } + } + } + else + { + } + } } else if ((iptr)tf == type_tlc) { @@ -3800,7 +3993,12 @@ static IBOOL object_directly_refers_to_self(ptr p) { { ISPC p_at_spc = SPACE(p); - if (p_at_spc == space_ephemeron) + if (p_at_spc < space_weakpair) + { + if (p == INITCAR(p)) return 1; + if (p == INITCDR(p)) return 1; + } + else if (p_at_spc == space_ephemeron) { } else if (p_at_spc == space_weakpair) @@ -3809,8 +4007,7 @@ static IBOOL object_directly_refers_to_self(ptr p) } else { - if (p == INITCAR(p)) return 1; - if (p == INITCDR(p)) return 1; + S_error_abort("misplaced pair"); } } } @@ -3829,7 +4026,7 @@ static IBOOL object_directly_refers_to_self(ptr p) ptr *p_p = &CLOSIT(p, 0); for (idx = 0; idx < p_len; idx++) { - if (p_p[idx] == p) return 1; + if (p == p_p[idx]) return 1; } } } @@ -3848,7 +4045,7 @@ static IBOOL object_directly_refers_to_self(ptr p) return 0; } -static void mark_typemod_data_object(thread_gc *tgc, ptr p, uptr p_sz, seginfo *si) +static void mark_untyped_data_object(thread_gc *tgc, ptr p, uptr p_sz, seginfo *si) { if (!si->marked_mask) { init_mask(tgc, si->marked_mask, si->generation, 0); @@ -3894,7 +4091,7 @@ static void measure(thread_gc *tgc, ptr p) { { /* measure */ ptr r_p = RECORDINSTTYPE(p); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } { @@ -3919,7 +4116,7 @@ static void measure(thread_gc *tgc, ptr p) { { /* measure */ ptr r_p = *(pp); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } pp += 1; @@ -3934,7 +4131,7 @@ static void measure(thread_gc *tgc, ptr p) { { /* measure */ ptr r_p = *(pp); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } } @@ -3958,7 +4155,7 @@ static void measure(thread_gc *tgc, ptr p) { { /* measure */ ptr r_p = *(pp); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } } @@ -3995,7 +4192,7 @@ static void measure(thread_gc *tgc, ptr p) { { /* measure */ ptr r_p = p_p[idx]; - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } } @@ -4015,7 +4212,7 @@ static void measure(thread_gc *tgc, ptr p) { { /* measure */ ptr r_p = p_p[idx]; - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } } @@ -4048,10 +4245,39 @@ static void measure(thread_gc *tgc, ptr p) } else if (TYPEP(tf, mask_bytevector, type_bytevector)) { - uptr sz = size_bytevector((Sbytevector_length(p))); { - uptr p_sz = sz; - measure_total += p_sz; + ISPC p_at_spc = SPACE(p); + if (p_at_spc == space_reference_array) + { + uptr sz = size_bytevector((Sbytevector_length(p))); + { + uptr p_sz = sz; + measure_total += p_sz; + { + uptr len = Sbytevector_reference_length(p); + { + uptr idx, p_len = len; + ptr *p_p = (ptr*)&BVIT(p, 0); + for (idx = 0; idx < p_len; idx++) + { + { /* measure */ + ptr r_p = S_maybe_reference_to_object(p_p[idx]); + if (!FIXMEDIATE(r_p)) + push_measure(tgc, r_p); + } + } + } + } + } + } + else + { + uptr sz = size_bytevector((Sbytevector_length(p))); + { + uptr p_sz = sz; + measure_total += p_sz; + } + } } } else if ((iptr)tf == type_tlc) @@ -4060,17 +4286,17 @@ static void measure(thread_gc *tgc, ptr p) measure_total += p_sz; { /* measure */ ptr r_p = INITTLCHT(p); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } { /* measure */ ptr r_p = INITTLCKEYVAL(p); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } { /* measure */ ptr r_p = INITTLCNEXT(p); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } } @@ -4080,7 +4306,7 @@ static void measure(thread_gc *tgc, ptr p) measure_total += p_sz; { /* measure */ ptr r_p = INITBOXREF(p); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } } @@ -4090,12 +4316,12 @@ static void measure(thread_gc *tgc, ptr p) measure_total += p_sz; { /* measure */ ptr r_p = RATNUM(p); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } { /* measure */ ptr r_p = RATDEN(p); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } } @@ -4105,12 +4331,12 @@ static void measure(thread_gc *tgc, ptr p) measure_total += p_sz; { /* measure */ ptr r_p = EXACTNUM_REAL_PART(p); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } { /* measure */ ptr r_p = EXACTNUM_IMAG_PART(p); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } } @@ -4133,17 +4359,17 @@ static void measure(thread_gc *tgc, ptr p) measure_total += p_sz; { /* measure */ ptr r_p = PORTHANDLER(p); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } { /* measure */ ptr r_p = PORTINFO(p); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } { /* measure */ ptr r_p = PORTNAME(p); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } } @@ -4155,22 +4381,22 @@ static void measure(thread_gc *tgc, ptr p) measure_total += p_sz; { /* measure */ ptr r_p = CODENAME(p); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } { /* measure */ ptr r_p = CODEARITYMASK(p); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } { /* measure */ ptr r_p = CODEINFO(p); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } { /* measure */ ptr r_p = CODEPINFOS(p); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } { @@ -4211,7 +4437,7 @@ static void measure(thread_gc *tgc, ptr p) ptr obj = S_get_code_obj(RELOC_TYPE(entry), oldco, a, item_off); { /* measure */ ptr r_p = obj; - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } } @@ -4236,22 +4462,22 @@ static void measure(thread_gc *tgc, ptr p) STACKCACHE(tc) = Snil; { /* measure */ ptr r_p = CCHAIN(tc); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } { /* measure */ ptr r_p = STACKLINK(tc); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } { /* measure */ ptr r_p = WINDERS(tc); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } { /* measure */ ptr r_p = ATTACHMENTS(tc); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } { @@ -4262,7 +4488,7 @@ static void measure(thread_gc *tgc, ptr p) ptr c_p = (ptr)(((uptr)xcp) - co); { /* measure */ ptr r_p = c_p; - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } { @@ -4290,7 +4516,7 @@ static void measure(thread_gc *tgc, ptr p) ptr c_p = (ptr)(((uptr)xcp) - co); { /* measure */ ptr r_p = c_p; - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } { @@ -4306,7 +4532,7 @@ static void measure(thread_gc *tgc, ptr p) { { /* measure */ ptr r_p = *(pp); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } } @@ -4324,7 +4550,7 @@ static void measure(thread_gc *tgc, ptr p) { { /* measure */ ptr r_p = *((ENTRYNONCOMPACTLIVEMASKADDR(oldret))); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } num = ENTRYLIVEMASK(oldret); @@ -4349,7 +4575,7 @@ static void measure(thread_gc *tgc, ptr p) { { /* measure */ ptr r_p = *(pp); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } } @@ -4367,82 +4593,82 @@ static void measure(thread_gc *tgc, ptr p) } { /* measure */ ptr r_p = THREADNO(tc); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } { /* measure */ ptr r_p = CURRENTINPUT(tc); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } { /* measure */ ptr r_p = CURRENTOUTPUT(tc); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } { /* measure */ ptr r_p = CURRENTERROR(tc); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } { /* measure */ ptr r_p = SFD(tc); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } { /* measure */ ptr r_p = CURRENTMSO(tc); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } { /* measure */ ptr r_p = TARGETMACHINE(tc); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } { /* measure */ ptr r_p = FXLENGTHBV(tc); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } { /* measure */ ptr r_p = FXFIRSTBITSETBV(tc); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } { /* measure */ ptr r_p = COMPILEPROFILE(tc); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } { /* measure */ ptr r_p = SUBSETMODE(tc); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } { /* measure */ ptr r_p = DEFAULTRECORDEQUALPROCEDURE(tc); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } { /* measure */ ptr r_p = DEFAULTRECORDHASHPROCEDURE(tc); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } { /* measure */ ptr r_p = COMPRESSFORMAT(tc); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } { /* measure */ ptr r_p = COMPRESSLEVEL(tc); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } { /* measure */ ptr r_p = PARAMETERS(tc); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } { @@ -4451,7 +4677,7 @@ static void measure(thread_gc *tgc, ptr p) { { /* measure */ ptr r_p = VIRTREG(tc, i); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } i += 1; @@ -4486,7 +4712,22 @@ static void measure(thread_gc *tgc, ptr p) { { ISPC p_at_spc = SPACE(p); - if (p_at_spc == space_ephemeron) + if (p_at_spc < space_weakpair) + { + uptr p_sz = size_pair; + measure_total += p_sz; + { /* measure */ + ptr r_p = INITCAR(p); + if (!FIXMEDIATE(r_p)) + push_measure(tgc, r_p); + } + { /* measure */ + ptr r_p = INITCDR(p); + if (!FIXMEDIATE(r_p)) + push_measure(tgc, r_p); + } + } + else if (p_at_spc == space_ephemeron) { uptr p_sz = size_ephemeron; measure_total += p_sz; @@ -4498,24 +4739,13 @@ static void measure(thread_gc *tgc, ptr p) measure_total += p_sz; { /* measure */ ptr r_p = INITCDR(p); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } } else { - uptr p_sz = size_pair; - measure_total += p_sz; - { /* measure */ - ptr r_p = INITCAR(p); - if (!IMMEDIATE(r_p)) - push_measure(tgc, r_p); - } - { /* measure */ - ptr r_p = INITCDR(p); - if (!IMMEDIATE(r_p)) - push_measure(tgc, r_p); - } + S_error_abort("misplaced pair"); } } } @@ -4524,7 +4754,7 @@ static void measure(thread_gc *tgc, ptr p) ptr code = CLOSCODE(p); { /* measure */ ptr r_p = code; - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } if ((CODETYPE(code)) & (code_flag_continuation << code_flags_offset)) @@ -4533,12 +4763,12 @@ static void measure(thread_gc *tgc, ptr p) measure_total += p_sz; { /* measure */ ptr r_p = CONTWINDERS(p); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } { /* measure */ ptr r_p = CONTATTACHMENTS(p); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } if ((CONTLENGTH(p)) == scaled_shot_1_shot_flag) @@ -4548,7 +4778,7 @@ static void measure(thread_gc *tgc, ptr p) { { /* measure */ ptr r_p = CONTLINK(p); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } { @@ -4559,7 +4789,7 @@ static void measure(thread_gc *tgc, ptr p) ptr c_p = (ptr)(((uptr)xcp) - co); { /* measure */ ptr r_p = c_p; - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } { @@ -4589,7 +4819,7 @@ static void measure(thread_gc *tgc, ptr p) ptr c_p = (ptr)(((uptr)xcp) - co); { /* measure */ ptr r_p = c_p; - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } { @@ -4605,7 +4835,7 @@ static void measure(thread_gc *tgc, ptr p) { { /* measure */ ptr r_p = *(pp); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } } @@ -4623,7 +4853,7 @@ static void measure(thread_gc *tgc, ptr p) { { /* measure */ ptr r_p = *((ENTRYNONCOMPACTLIVEMASKADDR(oldret))); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } num = ENTRYLIVEMASK(oldret); @@ -4648,7 +4878,7 @@ static void measure(thread_gc *tgc, ptr p) { { /* measure */ ptr r_p = *(pp); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } } @@ -4686,7 +4916,7 @@ static void measure(thread_gc *tgc, ptr p) { { /* measure */ ptr r_p = p_p[idx]; - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } } @@ -4700,27 +4930,27 @@ static void measure(thread_gc *tgc, ptr p) measure_total += p_sz; { /* measure */ ptr r_p = INITSYMVAL(p); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } { /* measure */ ptr r_p = INITSYMPLIST(p); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } { /* measure */ ptr r_p = INITSYMNAME(p); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } { /* measure */ ptr r_p = INITSYMSPLIST(p); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } { /* measure */ ptr r_p = INITSYMHASH(p); - if (!IMMEDIATE(r_p)) + if (!FIXMEDIATE(r_p)) push_measure(tgc, r_p); } } diff --git a/src/ChezScheme/boot/pb/gc-par.inc b/src/ChezScheme/boot/pb/gc-par.inc index 9d60ec3741..1405c7417b 100644 --- a/src/ChezScheme/boot/pb/gc-par.inc +++ b/src/ChezScheme/boot/pb/gc-par.inc @@ -117,13 +117,39 @@ static IGEN copy(thread_gc *tgc, ptr p, seginfo *si, ptr *dest) } else if (TYPEP(tf, mask_bytevector, type_bytevector)) { - ISPC p_spc = space_data; { - uptr sz = size_bytevector((Sbytevector_length(p))); + ISPC p_at_spc = si->space; + if (p_at_spc == space_reference_array) { - uptr p_sz = sz; - find_gc_room(tgc, p_spc, tg, type_typed_object, p_sz, new_p); - memcpy_aligned(&BYTEVECTOR_TYPE(new_p), &BYTEVECTOR_TYPE(p), sz); + ISPC p_spc = space_reference_array; + { + uptr sz = size_bytevector((Sbytevector_length(p))); + { + uptr p_sz = sz; + find_gc_room(tgc, p_spc, tg, type_typed_object, p_sz, new_p); + BYTEVECTOR_TYPE(new_p) = (uptr)tf; + { + uptr len = Sbytevector_reference_length(p); + memcpy_aligned(&BVIT(new_p, 0), &BVIT(p, 0), ptr_bytes * len); + if ((len & 1) == 0) + { + INITBVREFIT(new_p, len) = FIX(0); + } + } + } + } + } + else + { + ISPC p_spc = space_data; + { + uptr sz = size_bytevector((Sbytevector_length(p))); + { + uptr p_sz = sz; + find_gc_room(tgc, p_spc, tg, type_typed_object, p_sz, new_p); + memcpy_aligned(&BYTEVECTOR_TYPE(new_p), &BYTEVECTOR_TYPE(p), sz); + } + } } } } @@ -301,21 +327,9 @@ static IGEN copy(thread_gc *tgc, ptr p, seginfo *si, ptr *dest) { { ISPC p_at_spc = si->space; - if (p_at_spc == space_ephemeron) - { - ISPC p_spc = space_ephemeron; - { - uptr p_sz = size_ephemeron; - find_gc_room(tgc, p_spc, tg, type_pair, p_sz, new_p); - INITCAR(new_p) = INITCAR(p); - INITCDR(new_p) = INITCDR(p); - INITEPHEMERONPREVREF(new_p) = 0; - INITEPHEMERONNEXT(new_p) = 0; - } - } - else if (p_at_spc == space_weakpair) + if (p_at_spc < space_weakpair) { - ISPC p_spc = space_weakpair; + ISPC p_spc = space_impure; { ptr cdr_p = Scdr(p); if ((cdr_p != p) && (((TYPEBITS(cdr_p)) == type_pair) && (((ptr_get_segment(cdr_p)) == (ptr_get_segment(p))) && (((FWDMARKER(cdr_p)) != forward_marker) && (!(si -> marked_mask)))))) @@ -341,9 +355,21 @@ static IGEN copy(thread_gc *tgc, ptr p, seginfo *si, ptr *dest) } } } - else + else if (p_at_spc == space_ephemeron) { - ISPC p_spc = space_impure; + ISPC p_spc = space_ephemeron; + { + uptr p_sz = size_ephemeron; + find_gc_room(tgc, p_spc, tg, type_pair, p_sz, new_p); + INITCAR(new_p) = INITCAR(p); + INITCDR(new_p) = INITCDR(p); + INITEPHEMERONPREVREF(new_p) = 0; + INITEPHEMERONNEXT(new_p) = 0; + } + } + else if (p_at_spc == space_weakpair) + { + ISPC p_spc = space_weakpair; { ptr cdr_p = Scdr(p); if ((cdr_p != p) && (((TYPEBITS(cdr_p)) == type_pair) && (((ptr_get_segment(cdr_p)) == (ptr_get_segment(p))) && (((FWDMARKER(cdr_p)) != forward_marker) && (!(si -> marked_mask)))))) @@ -369,6 +395,10 @@ static IGEN copy(thread_gc *tgc, ptr p, seginfo *si, ptr *dest) } } } + else + { + S_error_abort("misplaced pair"); + } } } else if (t == type_closure) @@ -593,6 +623,26 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) } else if (TYPEP(tf, mask_bytevector, type_bytevector)) { + { + ISPC p_at_spc = SPACE(p); + if (p_at_spc == space_reference_array) + { + { + uptr len = Sbytevector_reference_length(p); + { + uptr idx, p_len = len; + ptr *p_p = (ptr*)&BVIT(p, 0); + for (idx = 0; idx < p_len; idx++) + { + relocate_reference(&(p_p[idx]), from_g); + } + } + } + } + else + { + } + } } else if ((iptr)tf == type_tlc) { @@ -702,14 +752,14 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) { if (!(marked(t_si, t))) { - mark_typemod_data_object(tgc, t, n, t_si); + mark_untyped_data_object(tgc, t, n, t_si); } } else { { ptr oldt = t; - find_gc_room(tgc, space_data, from_g, typemod, n, t); + find_gc_room(tgc, space_data, from_g, type_untyped, n, t); memcpy_aligned(TO_VOIDP(t), TO_VOIDP(oldt), n); } } @@ -915,7 +965,12 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) { { ISPC p_at_spc = SPACE(p); - if (p_at_spc == space_ephemeron) + if (p_at_spc < space_weakpair) + { + relocate_impure(&INITCAR(p), from_g); + relocate_impure(&INITCDR(p), from_g); + } + else if (p_at_spc == space_ephemeron) { add_ephemeron_to_pending(tgc, p); } @@ -925,8 +980,8 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g) } else { - relocate_impure(&INITCAR(p), from_g); - relocate_impure(&INITCDR(p), from_g); + relocate_reference(&INITCAR(p), from_g); + relocate_reference(&INITCDR(p), from_g); } } } @@ -1262,6 +1317,26 @@ static void sweep_object_in_old(thread_gc *tgc, ptr p) } else if (TYPEP(tf, mask_bytevector, type_bytevector)) { + { + ISPC p_at_spc = SPACE(p); + if (p_at_spc == space_reference_array) + { + { + uptr len = Sbytevector_reference_length(p); + { + uptr idx, p_len = len; + ptr *p_p = (ptr*)&BVIT(p, 0); + for (idx = 0; idx < p_len; idx++) + { + relocate_reference_indirect((p_p[idx])); + } + } + } + } + else + { + } + } } else if ((iptr)tf == type_tlc) { @@ -1518,7 +1593,12 @@ static void sweep_object_in_old(thread_gc *tgc, ptr p) { { ISPC p_at_spc = SPACE(p); - if (p_at_spc == space_ephemeron) + if (p_at_spc < space_weakpair) + { + relocate_indirect(INITCAR(p)); + relocate_indirect(INITCDR(p)); + } + else if (p_at_spc == space_ephemeron) { } else if (p_at_spc == space_weakpair) @@ -1527,8 +1607,7 @@ static void sweep_object_in_old(thread_gc *tgc, ptr p) } else { - relocate_indirect(INITCAR(p)); - relocate_indirect(INITCDR(p)); + S_error_abort("misplaced pair"); } } } @@ -1817,6 +1896,26 @@ static IGEN sweep_dirty_object(thread_gc *tgc, ptr p, IGEN youngest) } else if (TYPEP(tf, mask_bytevector, type_bytevector)) { + { + ISPC p_at_spc = SPACE(p); + if (p_at_spc == space_reference_array) + { + { + uptr len = Sbytevector_reference_length(p); + { + uptr idx, p_len = len; + ptr *p_p = (ptr*)&BVIT(p, 0); + for (idx = 0; idx < p_len; idx++) + { + relocate_reference_dirty(&(p_p[idx]), youngest); + } + } + } + } + else + { + } + } } else if ((iptr)tf == type_tlc) { @@ -1879,7 +1978,12 @@ static IGEN sweep_dirty_object(thread_gc *tgc, ptr p, IGEN youngest) { { ISPC p_at_spc = SPACE(p); - if (p_at_spc == space_ephemeron) + if (p_at_spc < space_weakpair) + { + relocate_dirty(&INITCAR(p), youngest); + relocate_dirty(&INITCDR(p), youngest); + } + else if (p_at_spc == space_ephemeron) { add_ephemeron_to_pending(tgc, p); } @@ -1889,8 +1993,8 @@ static IGEN sweep_dirty_object(thread_gc *tgc, ptr p, IGEN youngest) } else { - relocate_dirty(&INITCAR(p), youngest); - relocate_dirty(&INITCDR(p), youngest); + relocate_reference_dirty(&INITCAR(p), youngest); + relocate_reference_dirty(&INITCDR(p), youngest); } } } @@ -2611,14 +2715,14 @@ static void sweep_code_object(thread_gc *tgc, ptr p, IGEN from_g) { if (!(marked(t_si, t))) { - mark_typemod_data_object(tgc, t, n, t_si); + mark_untyped_data_object(tgc, t, n, t_si); } } else { { ptr oldt = t; - find_gc_room(tgc, space_data, from_g, typemod, n, t); + find_gc_room(tgc, space_data, from_g, type_untyped, n, t); memcpy_aligned(TO_VOIDP(t), TO_VOIDP(oldt), n); } } @@ -2703,10 +2807,24 @@ static uptr size_object(ptr p) } else if (TYPEP(tf, mask_bytevector, type_bytevector)) { - uptr sz = size_bytevector((Sbytevector_length(p))); { - uptr p_sz = sz; - return p_sz; + ISPC p_at_spc = SPACE(p); + if (p_at_spc == space_reference_array) + { + uptr sz = size_bytevector((Sbytevector_length(p))); + { + uptr p_sz = sz; + return p_sz; + } + } + else + { + uptr sz = size_bytevector((Sbytevector_length(p))); + { + uptr p_sz = sz; + return p_sz; + } + } } } else if ((iptr)tf == type_tlc) @@ -2779,7 +2897,12 @@ static uptr size_object(ptr p) { { ISPC p_at_spc = SPACE(p); - if (p_at_spc == space_ephemeron) + if (p_at_spc < space_weakpair) + { + uptr p_sz = size_pair; + return p_sz; + } + else if (p_at_spc == space_ephemeron) { uptr p_sz = size_ephemeron; return p_sz; @@ -2791,8 +2914,7 @@ static uptr size_object(ptr p) } else { - uptr p_sz = size_pair; - return p_sz; + S_error_abort("misplaced pair"); } } } @@ -3048,35 +3170,78 @@ static IGEN mark_object(thread_gc *tgc, ptr p, seginfo *si) } else if (TYPEP(tf, mask_bytevector, type_bytevector)) { - uptr sz = size_bytevector((Sbytevector_length(p))); { - uptr p_sz = sz; - si->marked_mask[segment_bitmap_byte(p)] |= segment_bitmap_bit(p); + ISPC p_at_spc = si->space; + if (p_at_spc == space_reference_array) { - 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++; + uptr sz = size_bytevector((Sbytevector_length(p))); + { + uptr p_sz = sz; + { + uptr addr = (uptr)UNTYPE(p, type_typed_object); + if (addr_get_segment(addr) == addr_get_segment(addr + p_sz - 1)) + { + si->marked_count += p_sz; + { + uptr offset = 0; + while (offset < p_sz) { + ptr mark_p = (ptr)((uptr)p + offset); + si->marked_mask[segment_bitmap_byte(mark_p)] |= segment_bitmap_bit(mark_p); + offset += byte_alignment; + } + } + } + else + { + uptr offset = 0; + while (offset < p_sz) { + ptr mark_p = (ptr)((uptr)p + offset); + seginfo *mark_si = SegInfo(ptr_get_segment(mark_p)); + if (!mark_si->marked_mask) { + init_mask(tgc, mark_si->marked_mask, mark_si->generation, 0); + } + mark_si->marked_mask[segment_bitmap_byte(mark_p)] |= segment_bitmap_bit(mark_p); + mark_si->marked_count += byte_alignment; + offset += byte_alignment; + } + } } - mark_si = SegInfo(end_seg); + push_sweep(p); + } + } + else + { + uptr sz = size_bytevector((Sbytevector_length(p))); + { + uptr p_sz = sz; + si->marked_mask[segment_bitmap_byte(p)] |= segment_bitmap_bit(p); { - if (!mark_si->marked_mask) { - init_mask(tgc, mark_si->marked_mask, mark_si->generation, 0); + 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); + } } - /* 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); } } } @@ -3254,7 +3419,14 @@ static IGEN mark_object(thread_gc *tgc, ptr p, seginfo *si) { { ISPC p_at_spc = si->space; - if (p_at_spc == space_ephemeron) + if (p_at_spc < space_weakpair) + { + uptr p_sz = size_pair; + si->marked_mask[segment_bitmap_byte(p)] |= segment_bitmap_bit(p); + si->marked_count += p_sz; + push_sweep(p); + } + else if (p_at_spc == space_ephemeron) { uptr p_sz = size_ephemeron; add_ephemeron_to_pending(tgc, p); @@ -3270,10 +3442,7 @@ static IGEN mark_object(thread_gc *tgc, ptr p, seginfo *si) } else { - uptr p_sz = size_pair; - si->marked_mask[segment_bitmap_byte(p)] |= segment_bitmap_bit(p); - si->marked_count += p_sz; - push_sweep(p); + S_error_abort("misplaced pair"); } } } @@ -3485,7 +3654,7 @@ static IBOOL object_directly_refers_to_self(ptr p) ptr *p_p = &INITVECTIT(p, 0); for (idx = 0; idx < p_len; idx++) { - if (p_p[idx] == p) return 1; + if (p == p_p[idx]) return 1; } } } @@ -3497,7 +3666,7 @@ static IBOOL object_directly_refers_to_self(ptr p) ptr *p_p = &INITSTENVECTIT(p, 0); for (idx = 0; idx < p_len; idx++) { - if (p_p[idx] == p) return 1; + if (p == p_p[idx]) return 1; } } } @@ -3512,6 +3681,26 @@ static IBOOL object_directly_refers_to_self(ptr p) } else if (TYPEP(tf, mask_bytevector, type_bytevector)) { + { + ISPC p_at_spc = SPACE(p); + if (p_at_spc == space_reference_array) + { + { + uptr len = Sbytevector_reference_length(p); + { + uptr idx, p_len = len; + ptr *p_p = (ptr*)&BVIT(p, 0); + for (idx = 0; idx < p_len; idx++) + { + if (p == S_maybe_reference_to_object(p_p[idx])) return 1; + } + } + } + } + else + { + } + } } else if ((iptr)tf == type_tlc) { @@ -3602,7 +3791,12 @@ static IBOOL object_directly_refers_to_self(ptr p) { { ISPC p_at_spc = SPACE(p); - if (p_at_spc == space_ephemeron) + if (p_at_spc < space_weakpair) + { + if (p == INITCAR(p)) return 1; + if (p == INITCDR(p)) return 1; + } + else if (p_at_spc == space_ephemeron) { } else if (p_at_spc == space_weakpair) @@ -3611,8 +3805,7 @@ static IBOOL object_directly_refers_to_self(ptr p) } else { - if (p == INITCAR(p)) return 1; - if (p == INITCDR(p)) return 1; + S_error_abort("misplaced pair"); } } } @@ -3631,7 +3824,7 @@ static IBOOL object_directly_refers_to_self(ptr p) ptr *p_p = &CLOSIT(p, 0); for (idx = 0; idx < p_len; idx++) { - if (p_p[idx] == p) return 1; + if (p == p_p[idx]) return 1; } } } @@ -3650,7 +3843,7 @@ static IBOOL object_directly_refers_to_self(ptr p) return 0; } -static void mark_typemod_data_object(thread_gc *tgc, ptr p, uptr p_sz, seginfo *si) +static void mark_untyped_data_object(thread_gc *tgc, ptr p, uptr p_sz, seginfo *si) { if (!si->marked_mask) { init_mask(tgc, si->marked_mask, si->generation, 0); diff --git a/src/ChezScheme/boot/pb/heapcheck.inc b/src/ChezScheme/boot/pb/heapcheck.inc index c0f08825c6..ea2ea8a2de 100644 --- a/src/ChezScheme/boot/pb/heapcheck.inc +++ b/src/ChezScheme/boot/pb/heapcheck.inc @@ -6,7 +6,7 @@ static void check_object(ptr p, uptr seg, ISPC s_in, IBOOL aftergc) ptr tf = TYPEFIELD(p); if (TYPEP(tf, mask_record, type_record)) { - check_pointer(&(RECORDINSTTYPE(p)), 1, p, seg, s_in, aftergc); + check_pointer(&(RECORDINSTTYPE(p)), 1, 0, p, seg, s_in, aftergc); { ptr rtd = RECORDINSTTYPE(p); { @@ -24,7 +24,7 @@ static void check_object(ptr p, uptr seg, ISPC s_in, IBOOL aftergc) ptr* ppend = ((ptr*)(TO_VOIDP((((uptr)(TO_PTR(pp))) + len)))) - 1; while (pp < ppend) { - check_pointer(&(*(pp)), 1, p, seg, s_in, aftergc); + check_pointer(&(*(pp)), 1, 0, p, seg, s_in, aftergc); pp += 1; } } @@ -35,7 +35,7 @@ static void check_object(ptr p, uptr seg, ISPC s_in, IBOOL aftergc) { if (mask & 1) { - check_pointer(&(*(pp)), 1, p, seg, s_in, aftergc); + check_pointer(&(*(pp)), 1, 0, p, seg, s_in, aftergc); } mask >>= 1; pp += 1; @@ -45,7 +45,7 @@ static void check_object(ptr p, uptr seg, ISPC s_in, IBOOL aftergc) } else { - check_pointer(&(num), 0, p, seg, s_in, aftergc); + check_pointer(&(num), 0, 0, p, seg, s_in, aftergc); check_bignum(num); { iptr index = (BIGLEN(num)) - 1; @@ -57,7 +57,7 @@ static void check_object(ptr p, uptr seg, ISPC s_in, IBOOL aftergc) { if (mask & 1) { - check_pointer(&(*(pp)), 1, p, seg, s_in, aftergc); + check_pointer(&(*(pp)), 1, 0, p, seg, s_in, aftergc); } mask >>= 1; pp += 1; @@ -86,7 +86,7 @@ static void check_object(ptr p, uptr seg, ISPC s_in, IBOOL aftergc) ptr *p_p = &INITVECTIT(p, 0); for (idx = 0; idx < p_len; idx++) { - check_pointer(&(p_p[idx]), 1, p, seg, s_in, aftergc); + check_pointer(&(p_p[idx]), 1, 0, p, seg, s_in, aftergc); } } } @@ -98,7 +98,7 @@ static void check_object(ptr p, uptr seg, ISPC s_in, IBOOL aftergc) ptr *p_p = &INITSTENVECTIT(p, 0); for (idx = 0; idx < p_len; idx++) { - check_pointer(&(p_p[idx]), 1, p, seg, s_in, aftergc); + check_pointer(&(p_p[idx]), 1, 0, p, seg, s_in, aftergc); } } } @@ -113,26 +113,46 @@ static void check_object(ptr p, uptr seg, ISPC s_in, IBOOL aftergc) } else if (TYPEP(tf, mask_bytevector, type_bytevector)) { + { + ISPC p_at_spc = SPACE(p); + if (p_at_spc == space_reference_array) + { + { + uptr len = Sbytevector_reference_length(p); + { + uptr idx, p_len = len; + ptr *p_p = (ptr*)&BVIT(p, 0); + for (idx = 0; idx < p_len; idx++) + { + check_pointer(&(p_p[idx]), 1, 1, p, seg, s_in, aftergc); + } + } + } + } + else + { + } + } } else if ((iptr)tf == type_tlc) { - check_pointer(&(INITTLCHT(p)), 1, p, seg, s_in, aftergc); - check_pointer(&(INITTLCKEYVAL(p)), 1, p, seg, s_in, aftergc); - check_pointer(&(INITTLCNEXT(p)), 1, p, seg, s_in, aftergc); + check_pointer(&(INITTLCHT(p)), 1, 0, p, seg, s_in, aftergc); + check_pointer(&(INITTLCKEYVAL(p)), 1, 0, p, seg, s_in, aftergc); + check_pointer(&(INITTLCNEXT(p)), 1, 0, p, seg, s_in, aftergc); } else if (TYPEP(tf, mask_box, type_box)) { - check_pointer(&(INITBOXREF(p)), 1, p, seg, s_in, aftergc); + check_pointer(&(INITBOXREF(p)), 1, 0, p, seg, s_in, aftergc); } else if ((iptr)tf == type_ratnum) { - check_pointer(&(RATNUM(p)), 1, p, seg, s_in, aftergc); - check_pointer(&(RATDEN(p)), 1, p, seg, s_in, aftergc); + check_pointer(&(RATNUM(p)), 1, 0, p, seg, s_in, aftergc); + check_pointer(&(RATDEN(p)), 1, 0, p, seg, s_in, aftergc); } else if ((iptr)tf == type_exactnum) { - check_pointer(&(EXACTNUM_REAL_PART(p)), 1, p, seg, s_in, aftergc); - check_pointer(&(EXACTNUM_IMAG_PART(p)), 1, p, seg, s_in, aftergc); + check_pointer(&(EXACTNUM_REAL_PART(p)), 1, 0, p, seg, s_in, aftergc); + check_pointer(&(EXACTNUM_IMAG_PART(p)), 1, 0, p, seg, s_in, aftergc); } else if ((iptr)tf == type_inexactnum) { @@ -142,24 +162,24 @@ static void check_object(ptr p, uptr seg, ISPC s_in, IBOOL aftergc) } else if (TYPEP(tf, mask_port, type_port)) { - check_pointer(&(PORTHANDLER(p)), 1, p, seg, s_in, aftergc); + check_pointer(&(PORTHANDLER(p)), 1, 0, p, seg, s_in, aftergc); if (((uptr)tf) & PORT_FLAG_OUTPUT) { - check_pointer(&(PORTOBUF(p)), 1, p, seg, s_in, aftergc); + check_pointer(&(PORTOBUF(p)), 1, 0, p, seg, s_in, aftergc); } if (((uptr)tf) & PORT_FLAG_INPUT) { - check_pointer(&(PORTIBUF(p)), 1, p, seg, s_in, aftergc); + check_pointer(&(PORTIBUF(p)), 1, 0, p, seg, s_in, aftergc); } - check_pointer(&(PORTINFO(p)), 1, p, seg, s_in, aftergc); - check_pointer(&(PORTNAME(p)), 1, p, seg, s_in, aftergc); + check_pointer(&(PORTINFO(p)), 1, 0, p, seg, s_in, aftergc); + check_pointer(&(PORTNAME(p)), 1, 0, p, seg, s_in, aftergc); } else if (TYPEP(tf, mask_code, type_code)) { - check_pointer(&(CODENAME(p)), 1, p, seg, s_in, aftergc); - check_pointer(&(CODEARITYMASK(p)), 1, p, seg, s_in, aftergc); - check_pointer(&(CODEINFO(p)), 1, p, seg, s_in, aftergc); - check_pointer(&(CODEPINFOS(p)), 1, p, seg, s_in, aftergc); + check_pointer(&(CODENAME(p)), 1, 0, p, seg, s_in, aftergc); + check_pointer(&(CODEARITYMASK(p)), 1, 0, p, seg, s_in, aftergc); + check_pointer(&(CODEINFO(p)), 1, 0, p, seg, s_in, aftergc); + check_pointer(&(CODEPINFOS(p)), 1, 0, p, seg, s_in, aftergc); { ptr t = CODERELOC(p); { @@ -196,7 +216,7 @@ static void check_object(ptr p, uptr seg, ISPC s_in, IBOOL aftergc) a = a + code_off; { ptr obj = S_get_code_obj(RELOC_TYPE(entry), oldco, a, item_off); - check_pointer(&(obj), 0, p, seg, s_in, aftergc); + check_pointer(&(obj), 0, 0, p, seg, s_in, aftergc); } } } @@ -213,17 +233,17 @@ static void check_object(ptr p, uptr seg, ISPC s_in, IBOOL aftergc) if (tc != ((ptr)0)) { STACKCACHE(tc) = Snil; - check_pointer(&(CCHAIN(tc)), 1, p, seg, s_in, aftergc); - check_pointer(&(STACKLINK(tc)), 1, p, seg, s_in, aftergc); - check_pointer(&(WINDERS(tc)), 1, p, seg, s_in, aftergc); - check_pointer(&(ATTACHMENTS(tc)), 1, p, seg, s_in, aftergc); + check_pointer(&(CCHAIN(tc)), 1, 0, p, seg, s_in, aftergc); + check_pointer(&(STACKLINK(tc)), 1, 0, p, seg, s_in, aftergc); + check_pointer(&(WINDERS(tc)), 1, 0, p, seg, s_in, aftergc); + check_pointer(&(ATTACHMENTS(tc)), 1, 0, p, seg, s_in, aftergc); { ptr xcp = FRAME(tc, 0); { iptr co = (ENTRYOFFSET(xcp)) + (((uptr)xcp) - ((uptr)(TO_PTR((ENTRYOFFSETADDR(xcp)))))); { ptr c_p = (ptr)(((uptr)xcp) - co); - check_pointer(&(c_p), 0, p, seg, s_in, aftergc); + check_pointer(&(c_p), 0, 0, p, seg, s_in, aftergc); { uptr base = (uptr)(SCHEMESTACK(tc)); { @@ -247,7 +267,7 @@ static void check_object(ptr p, uptr seg, ISPC s_in, IBOOL aftergc) iptr co = (ENTRYOFFSET(xcp)) + (((uptr)xcp) - ((uptr)(TO_PTR((ENTRYOFFSETADDR(xcp)))))); { ptr c_p = (ptr)(((uptr)xcp) - co); - check_pointer(&(c_p), 0, p, seg, s_in, aftergc); + check_pointer(&(c_p), 0, 0, p, seg, s_in, aftergc); { ptr num = ENTRYLIVEMASK(oldret); if (Sfixnump(num)) @@ -259,7 +279,7 @@ static void check_object(ptr p, uptr seg, ISPC s_in, IBOOL aftergc) pp += 1; if (mask & 1) { - check_pointer(&(*(pp)), 1, p, seg, s_in, aftergc); + check_pointer(&(*(pp)), 1, 0, p, seg, s_in, aftergc); } mask >>= 1; } @@ -267,7 +287,7 @@ static void check_object(ptr p, uptr seg, ISPC s_in, IBOOL aftergc) } else { - check_pointer(&(num), 0, p, seg, s_in, aftergc); + check_pointer(&(num), 0, 0, p, seg, s_in, aftergc); check_bignum(num); { iptr index = BIGLEN(num); @@ -283,7 +303,7 @@ static void check_object(ptr p, uptr seg, ISPC s_in, IBOOL aftergc) pp += 1; if (mask & 1) { - check_pointer(&(*(pp)), 1, p, seg, s_in, aftergc); + check_pointer(&(*(pp)), 1, 0, p, seg, s_in, aftergc); } mask >>= 1; } @@ -297,27 +317,27 @@ static void check_object(ptr p, uptr seg, ISPC s_in, IBOOL aftergc) } } } - check_pointer(&(THREADNO(tc)), 1, p, seg, s_in, aftergc); - check_pointer(&(CURRENTINPUT(tc)), 1, p, seg, s_in, aftergc); - check_pointer(&(CURRENTOUTPUT(tc)), 1, p, seg, s_in, aftergc); - check_pointer(&(CURRENTERROR(tc)), 1, p, seg, s_in, aftergc); - check_pointer(&(SFD(tc)), 1, p, seg, s_in, aftergc); - check_pointer(&(CURRENTMSO(tc)), 1, p, seg, s_in, 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(&(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); - check_pointer(&(DEFAULTRECORDHASHPROCEDURE(tc)), 1, p, seg, s_in, aftergc); - check_pointer(&(COMPRESSFORMAT(tc)), 1, p, seg, s_in, aftergc); - check_pointer(&(COMPRESSLEVEL(tc)), 1, p, seg, s_in, aftergc); - check_pointer(&(PARAMETERS(tc)), 1, p, seg, s_in, aftergc); + check_pointer(&(THREADNO(tc)), 1, 0, p, seg, s_in, aftergc); + check_pointer(&(CURRENTINPUT(tc)), 1, 0, p, seg, s_in, aftergc); + check_pointer(&(CURRENTOUTPUT(tc)), 1, 0, p, seg, s_in, aftergc); + check_pointer(&(CURRENTERROR(tc)), 1, 0, p, seg, s_in, aftergc); + check_pointer(&(SFD(tc)), 1, 0, p, seg, s_in, aftergc); + check_pointer(&(CURRENTMSO(tc)), 1, 0, p, seg, s_in, aftergc); + check_pointer(&(TARGETMACHINE(tc)), 1, 0, p, seg, s_in, aftergc); + check_pointer(&(FXLENGTHBV(tc)), 1, 0, p, seg, s_in, aftergc); + check_pointer(&(FXFIRSTBITSETBV(tc)), 1, 0, p, seg, s_in, aftergc); + check_pointer(&(COMPILEPROFILE(tc)), 1, 0, p, seg, s_in, aftergc); + check_pointer(&(SUBSETMODE(tc)), 1, 0, p, seg, s_in, aftergc); + check_pointer(&(DEFAULTRECORDEQUALPROCEDURE(tc)), 1, 0, p, seg, s_in, aftergc); + check_pointer(&(DEFAULTRECORDHASHPROCEDURE(tc)), 1, 0, p, seg, s_in, aftergc); + check_pointer(&(COMPRESSFORMAT(tc)), 1, 0, p, seg, s_in, aftergc); + check_pointer(&(COMPRESSLEVEL(tc)), 1, 0, p, seg, s_in, aftergc); + check_pointer(&(PARAMETERS(tc)), 1, 0, p, seg, s_in, aftergc); { INT i = 0; while (i < virtual_register_count) { - check_pointer(&(VIRTREG(tc, i)), 1, p, seg, s_in, aftergc); + check_pointer(&(VIRTREG(tc, i)), 1, 0, p, seg, s_in, aftergc); i += 1; } } @@ -345,44 +365,48 @@ static void check_object(ptr p, uptr seg, ISPC s_in, IBOOL aftergc) { { ISPC p_at_spc = SPACE(p); - if (p_at_spc == space_ephemeron) + if (p_at_spc < space_weakpair) { - check_pointer(&(INITCAR(p)), 1, p, seg, s_in, aftergc); - check_pointer(&(INITCDR(p)), 1, p, seg, s_in, aftergc); + check_pointer(&(INITCAR(p)), 1, 0, p, seg, s_in, aftergc); + check_pointer(&(INITCDR(p)), 1, 0, p, seg, s_in, aftergc); + } + else if (p_at_spc == space_ephemeron) + { + check_pointer(&(INITCAR(p)), 1, 0, p, seg, s_in, aftergc); + check_pointer(&(INITCDR(p)), 1, 0, p, seg, s_in, aftergc); } else if (p_at_spc == space_weakpair) { - check_pointer(&(INITCAR(p)), 1, p, seg, s_in, aftergc); - check_pointer(&(INITCDR(p)), 1, p, seg, s_in, aftergc); + check_pointer(&(INITCAR(p)), 1, 0, p, seg, s_in, aftergc); + check_pointer(&(INITCDR(p)), 1, 0, p, seg, s_in, aftergc); } else { - check_pointer(&(INITCAR(p)), 1, p, seg, s_in, aftergc); - check_pointer(&(INITCDR(p)), 1, p, seg, s_in, aftergc); + S_error_abort("misplaced pair"); } } } else if (t == type_closure) { ptr code = CLOSCODE(p); - check_pointer(&(code), 0, p, seg, s_in, aftergc); + check_pointer(&(code), 0, 0, p, seg, s_in, aftergc); if ((CODETYPE(code)) & (code_flag_continuation << code_flags_offset)) { - check_pointer(&(CONTWINDERS(p)), 1, p, seg, s_in, aftergc); - check_pointer(&(CONTATTACHMENTS(p)), 1, p, seg, s_in, aftergc); + check_pointer(&(CONTWINDERS(p)), 1, 0, p, seg, s_in, aftergc); + check_pointer(&(CONTATTACHMENTS(p)), 1, 0, p, seg, s_in, aftergc); if ((CONTLENGTH(p)) == scaled_shot_1_shot_flag) { } else { - check_pointer(&(CONTLINK(p)), 1, p, seg, s_in, aftergc); + check_pointer(&(CONTLINK(p)), 1, 0, p, seg, s_in, aftergc); { ptr xcp = CONTRET(p); { iptr co = (ENTRYOFFSET(xcp)) + (((uptr)xcp) - ((uptr)(TO_PTR((ENTRYOFFSETADDR(xcp)))))); { ptr c_p = (ptr)(((uptr)xcp) - co); - check_pointer(&(c_p), 0, p, seg, s_in, aftergc); + check_pointer(&(c_p), 0, 0, p, seg, s_in, aftergc); { uptr stack = (uptr)(CONTSTACK(p)); { @@ -408,7 +432,7 @@ static void check_object(ptr p, uptr seg, ISPC s_in, IBOOL aftergc) iptr co = (ENTRYOFFSET(xcp)) + (((uptr)xcp) - ((uptr)(TO_PTR((ENTRYOFFSETADDR(xcp)))))); { ptr c_p = (ptr)(((uptr)xcp) - co); - check_pointer(&(c_p), 0, p, seg, s_in, aftergc); + check_pointer(&(c_p), 0, 0, p, seg, s_in, aftergc); { ptr num = ENTRYLIVEMASK(oldret); if (Sfixnump(num)) @@ -420,7 +444,7 @@ static void check_object(ptr p, uptr seg, ISPC s_in, IBOOL aftergc) pp += 1; if (mask & 1) { - check_pointer(&(*(pp)), 1, p, seg, s_in, aftergc); + check_pointer(&(*(pp)), 1, 0, p, seg, s_in, aftergc); } mask >>= 1; } @@ -428,7 +452,7 @@ static void check_object(ptr p, uptr seg, ISPC s_in, IBOOL aftergc) } else { - check_pointer(&(num), 0, p, seg, s_in, aftergc); + check_pointer(&(num), 0, 0, p, seg, s_in, aftergc); check_bignum(num); { iptr index = BIGLEN(num); @@ -444,7 +468,7 @@ static void check_object(ptr p, uptr seg, ISPC s_in, IBOOL aftergc) pp += 1; if (mask & 1) { - check_pointer(&(*(pp)), 1, p, seg, s_in, aftergc); + check_pointer(&(*(pp)), 1, 0, p, seg, s_in, aftergc); } mask >>= 1; } @@ -475,17 +499,17 @@ static void check_object(ptr p, uptr seg, ISPC s_in, IBOOL aftergc) ptr *p_p = &CLOSIT(p, 0); for (idx = 0; idx < p_len; idx++) { - check_pointer(&(p_p[idx]), 1, p, seg, s_in, aftergc); + check_pointer(&(p_p[idx]), 1, 0, p, seg, s_in, aftergc); } } } } else if (t == type_symbol) { - check_pointer(&(INITSYMPLIST(p)), 1, p, seg, s_in, aftergc); - check_pointer(&(INITSYMNAME(p)), 1, p, seg, s_in, aftergc); - check_pointer(&(INITSYMSPLIST(p)), 1, p, seg, s_in, aftergc); - check_pointer(&(INITSYMHASH(p)), 1, p, seg, s_in, aftergc); + check_pointer(&(INITSYMPLIST(p)), 1, 0, p, seg, s_in, aftergc); + check_pointer(&(INITSYMNAME(p)), 1, 0, p, seg, s_in, aftergc); + check_pointer(&(INITSYMSPLIST(p)), 1, 0, p, seg, s_in, aftergc); + check_pointer(&(INITSYMHASH(p)), 1, 0, p, seg, s_in, aftergc); } else if (t == type_flonum) { @@ -557,10 +581,24 @@ static uptr size_object(ptr p) } else if (TYPEP(tf, mask_bytevector, type_bytevector)) { - uptr sz = size_bytevector((Sbytevector_length(p))); { - uptr p_sz = sz; - return p_sz; + ISPC p_at_spc = SPACE(p); + if (p_at_spc == space_reference_array) + { + uptr sz = size_bytevector((Sbytevector_length(p))); + { + uptr p_sz = sz; + return p_sz; + } + } + else + { + uptr sz = size_bytevector((Sbytevector_length(p))); + { + uptr p_sz = sz; + return p_sz; + } + } } } else if ((iptr)tf == type_tlc) @@ -633,7 +671,12 @@ static uptr size_object(ptr p) { { ISPC p_at_spc = SPACE(p); - if (p_at_spc == space_ephemeron) + if (p_at_spc < space_weakpair) + { + uptr p_sz = size_pair; + return p_sz; + } + else if (p_at_spc == space_ephemeron) { uptr p_sz = size_ephemeron; return p_sz; @@ -645,8 +688,7 @@ static uptr size_object(ptr p) } else { - uptr p_sz = size_pair; - return p_sz; + S_error_abort("misplaced pair"); } } } diff --git a/src/ChezScheme/boot/pb/petite.boot b/src/ChezScheme/boot/pb/petite.boot Binary files differindex b8918b27c5..2ace3e2dd5 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 1ef3a157aa..f1d3693a57 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 50107505ce..e9afc4d619 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.58 (pb) */ +/* scheme.h for Chez Scheme Version 9.5.5.5 (pb) */ /* Do not edit this file. It is automatically generated and */ /* specifically tailored to the version of Chez Scheme named */ @@ -45,7 +45,7 @@ #endif /* Chez Scheme Version and machine type */ -#define VERSION "9.5.3.58" +#define VERSION "9.5.5.5" #define MACHINE_TYPE "pb" /* All Scheme objects are of type ptr. Type iptr and */ @@ -231,6 +231,7 @@ EXPORT int Sscheme_start PROTO((int, const char *[])); EXPORT int Sscheme_script PROTO((const char *, int, const char *[])); EXPORT int Sscheme_program PROTO((const char *, int, const char *[])); EXPORT void Sscheme_deinit PROTO((void)); +EXPORT void Sscheme_register_signal_registerer PROTO((void (*f)(int))); /* Features. */ diff --git a/src/ChezScheme/c/Makefile.a6nt b/src/ChezScheme/c/Makefile.a6nt index 17f242e0e8..93793acbf7 100644 --- a/src/ChezScheme/c/Makefile.a6nt +++ b/src/ChezScheme/c/Makefile.a6nt @@ -17,11 +17,11 @@ m = a6nt # following have to use \ for directory separator SchemeInclude = ..\boot\$m -KernelDll = ..\bin\$m\csv953.dll -KernelLib = ..\bin\$m\csv953.lib -MTKernelLib = ..\boot\$m\csv953mt.lib -MDKernelLib = ..\boot\$m\csv953md.lib -KernelExp = ..\bin\$m\csv953.exp +KernelDll = ..\bin\$m\csv955.dll +KernelLib = ..\bin\$m\csv955.lib +MTKernelLib = ..\boot\$m\csv955mt.lib +MDKernelLib = ..\boot\$m\csv955md.lib +KernelExp = ..\bin\$m\csv955.exp Exec = ..\bin\$m\scheme.exe MTMain = ..\boot\$m\mainmt.obj MDMain = ..\boot\$m\mainmd.obj diff --git a/src/ChezScheme/c/Makefile.i3nt b/src/ChezScheme/c/Makefile.i3nt index 8f91283c1b..db8172bf98 100644 --- a/src/ChezScheme/c/Makefile.i3nt +++ b/src/ChezScheme/c/Makefile.i3nt @@ -17,11 +17,11 @@ m = i3nt # following have to use \ for directory separator SchemeInclude = ..\boot\$m -KernelDll = ..\bin\$m\csv953.dll -KernelLib = ..\bin\$m\csv953.lib -MTKernelLib = ..\boot\$m\csv953mt.lib -MDKernelLib = ..\boot\$m\csv953md.lib -KernelExp = ..\bin\$m\csv953.exp +KernelDll = ..\bin\$m\csv955.dll +KernelLib = ..\bin\$m\csv955.lib +MTKernelLib = ..\boot\$m\csv955mt.lib +MDKernelLib = ..\boot\$m\csv955md.lib +KernelExp = ..\bin\$m\csv955.exp Exec = ..\bin\$m\scheme.exe MTMain = ..\boot\$m\mainmt.obj MDMain = ..\boot\$m\mainmd.obj diff --git a/src/ChezScheme/c/Makefile.ta6nt b/src/ChezScheme/c/Makefile.ta6nt index 55285a9e48..4ed3ec892c 100644 --- a/src/ChezScheme/c/Makefile.ta6nt +++ b/src/ChezScheme/c/Makefile.ta6nt @@ -17,11 +17,11 @@ m = ta6nt # following have to use \ for directory separator SchemeInclude = ..\boot\$m -KernelDll = ..\bin\$m\csv953.dll -KernelLib = ..\bin\$m\csv953.lib -MTKernelLib = ..\boot\$m\csv953mt.lib -MDKernelLib = ..\boot\$m\csv953md.lib -KernelExp = ..\bin\$m\csv953.exp +KernelDll = ..\bin\$m\csv955.dll +KernelLib = ..\bin\$m\csv955.lib +MTKernelLib = ..\boot\$m\csv955mt.lib +MDKernelLib = ..\boot\$m\csv955md.lib +KernelExp = ..\bin\$m\csv955.exp Exec = ..\bin\$m\scheme.exe MTMain = ..\boot\$m\mainmt.obj MDMain = ..\boot\$m\mainmd.obj diff --git a/src/ChezScheme/c/Makefile.ti3nt b/src/ChezScheme/c/Makefile.ti3nt index c1450aba97..ec20d39f94 100644 --- a/src/ChezScheme/c/Makefile.ti3nt +++ b/src/ChezScheme/c/Makefile.ti3nt @@ -18,11 +18,11 @@ m = ti3nt # following have to use \ for directory separator SchemeInclude = ..\boot\$m -KernelDll = ..\bin\$m\csv953.dll -KernelLib = ..\bin\$m\csv953.lib -MTKernelLib = ..\boot\$m\csv953mt.lib -MDKernelLib = ..\boot\$m\csv953md.lib -KernelExp = ..\bin\$m\csv953.exp +KernelDll = ..\bin\$m\csv955.dll +KernelLib = ..\bin\$m\csv955.lib +MTKernelLib = ..\boot\$m\csv955mt.lib +MDKernelLib = ..\boot\$m\csv955md.lib +KernelExp = ..\bin\$m\csv955.exp Exec = ..\bin\$m\scheme.exe MTMain = ..\boot\$m\mainmt.obj MDMain = ..\boot\$m\mainmd.obj diff --git a/src/ChezScheme/c/Mf-a6fb b/src/ChezScheme/c/Mf-a6fb deleted file mode 100644 index 51c51f8017..0000000000 --- a/src/ChezScheme/c/Mf-a6fb +++ /dev/null @@ -1,45 +0,0 @@ -# Mf-a6fb -# 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 ?= a6fb -Cpu ?= X86_64 - -mdinclude = -I/usr/local/include -I/usr/X11R6/include -o = o -mdsrc ?= i3le.c -mdobj ?= i3le.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 -X -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 --64) - -../lz4/lib/liblz4.a: ${LZ4Sources} - (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS}" ${MAKE} liblz4.a) diff --git a/src/ChezScheme/c/Mf-a6le b/src/ChezScheme/c/Mf-a6le deleted file mode 100644 index e9705e9111..0000000000 --- a/src/ChezScheme/c/Mf-a6le +++ /dev/null @@ -1,44 +0,0 @@ -# Mf-a6le -# 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 ?= a6le -Cpu ?= X86_64 - -o = o -mdsrc ?= i3le.c -mdobj ?= i3le.o - -.SUFFIXES: -.SUFFIXES: .c .o - -.c.o: - $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c - -include Mf-base - -${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} - ${LD} -melf_x86_64 -r -X -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 --64) - -../lz4/lib/liblz4.a: ${LZ4Sources} - (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS}" ${MAKE} liblz4.a) diff --git a/src/ChezScheme/c/Mf-a6nb b/src/ChezScheme/c/Mf-a6nb deleted file mode 100644 index 81a9983f71..0000000000 --- a/src/ChezScheme/c/Mf-a6nb +++ /dev/null @@ -1,46 +0,0 @@ -# Mf-a6nb -# 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 ?= 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 -o = o -mdsrc ?= i3le.c -mdobj ?= i3le.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 -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} - -${KernelLib}: ${kernelobj} - ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} - -${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} - $C -o ${Scheme} ${Main} ${Kernel} ${KernelLinkLibs} ${LDFLAGS} ${LIBS} - paxctl +m ${Scheme} - -../zlib/configure.log: - (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS}" ./configure --64) - -../lz4/lib/liblz4.a: ${LZ4Sources} - (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS}" ${MAKE} liblz4.a) diff --git a/src/ChezScheme/c/Mf-a6nt b/src/ChezScheme/c/Mf-a6nt index 19e3e98967..40c0265b99 100644 --- a/src/ChezScheme/c/Mf-a6nt +++ b/src/ChezScheme/c/Mf-a6nt @@ -13,7 +13,6 @@ # See the License for the specific language governing permissions and # limitations under the License. -m ?= a6nt Cpu ?= X86_64 clib= diff --git a/src/ChezScheme/c/Mf-a6ob b/src/ChezScheme/c/Mf-a6ob deleted file mode 100644 index 19e843aa29..0000000000 --- a/src/ChezScheme/c/Mf-a6ob +++ /dev/null @@ -1,45 +0,0 @@ -# Mf-a6ob -# 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 ?= a6ob -Cpu ?= X86_64 - -mdinclude = -I/usr/local/include -I/usr/X11R6/include -o = o -mdsrc ?= i3le.c -mdobj ?= i3le.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 -X -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 --64) - -../lz4/lib/liblz4.a: ${LZ4Sources} - (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS}" ${MAKE} liblz4.a) diff --git a/src/ChezScheme/c/Mf-a6osx b/src/ChezScheme/c/Mf-a6osx deleted file mode 100644 index 247d52d2d3..0000000000 --- a/src/ChezScheme/c/Mf-a6osx +++ /dev/null @@ -1,45 +0,0 @@ -# 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 ?= a6osx -Cpu ?= X86_64 - -mdinclude = -I/opt/X11/include/ -o = o -mdsrc ?= i3le.c -mdobj ?= i3le.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 --64) - -../lz4/lib/liblz4.a: ${LZ4Sources} - (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS}" ${MAKE} liblz4.a) diff --git a/src/ChezScheme/c/Mf-a6s2 b/src/ChezScheme/c/Mf-a6s2 deleted file mode 100644 index b497e190c9..0000000000 --- a/src/ChezScheme/c/Mf-a6s2 +++ /dev/null @@ -1,44 +0,0 @@ -# Mf-a6s2 -# 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 ?= a6s2 -Cpu ?= X86_64 - -o = o -mdsrc ?= i3le.c -mdobj ?= i3le.o - -.SUFFIXES: -.SUFFIXES: .c .o - -.c.o: - $C -c -DSOLARIS -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c - -include Mf-base - -${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} - ${LD} -melf_x86_64 -r -X -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 --64) - -../lz4/lib/liblz4.a: ${LZ4Sources} - (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS}" ${MAKE} liblz4.a) diff --git a/src/ChezScheme/c/Mf-arm32le b/src/ChezScheme/c/Mf-arm32le deleted file mode 100644 index 9d095d2367..0000000000 --- a/src/ChezScheme/c/Mf-arm32le +++ /dev/null @@ -1,44 +0,0 @@ -# Mf-arm32le -# 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 ?= arm32le -Cpu ?= ARMV6 - -o = o -mdsrc ?= arm32le.c -mdobj ?= arm32le.o - -.SUFFIXES: -.SUFFIXES: .c .o - -.c.o: - $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c - -include Mf-base - -${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} - ${LD} -r -X -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-arm64le b/src/ChezScheme/c/Mf-arm64le deleted file mode 100644 index 2bb34e21c5..0000000000 --- a/src/ChezScheme/c/Mf-arm64le +++ /dev/null @@ -1,44 +0,0 @@ -# Mf-arm64le -# 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 ?= tarm64le -Cpu ?= AARCH64 - -o = o -mdsrc ?= arm32le.c -mdobj ?= arm32le.o - -.SUFFIXES: -.SUFFIXES: .c .o - -.c.o: - $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c - -include Mf-base - -${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} - ${LD} -r -X -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-arm64osx b/src/ChezScheme/c/Mf-arm64osx deleted file mode 100644 index d73163a0b3..0000000000 --- a/src/ChezScheme/c/Mf-arm64osx +++ /dev/null @@ -1,45 +0,0 @@ -# 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 2dddc636a7..188c7ff571 100644 --- a/src/ChezScheme/c/Mf-base +++ b/src/ChezScheme/c/Mf-base @@ -15,6 +15,9 @@ include Mf-config +mdsrc ?= ${mdarchsrc}.c +mdobj ?= ${mdarchsrc}.o + Include=../boot/$m PetiteBoot=../boot/$m/petite.boot SchemeBoot=../boot/$m/scheme.boot @@ -22,7 +25,7 @@ Main=../boot/$m/main.$o Scheme=../bin/$m/scheme # CFLAGS is propagated separately: -SetConfigEnv = CC="${CC}" CPPFLAGS="${CPPFLAGS}" AR="${AR}" ARFLAGS="${ARFLAGS}" +SetConfigEnv = CC="${CC}" CPPFLAGS="${CPPFLAGS}" AR="${AR}" ARFLAGS="${ARFLAGS}" RANLIB="${RANLIB}" # One of these sets is referenced in Mf-config to select between # linking with kernel.o or libkernel.a diff --git a/src/ChezScheme/c/Mf-i3fb b/src/ChezScheme/c/Mf-i3fb deleted file mode 100644 index eb21e1118c..0000000000 --- a/src/ChezScheme/c/Mf-i3fb +++ /dev/null @@ -1,45 +0,0 @@ -# Mf-i3fb -# 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 ?= i3fb -Cpu ?= I386 - -mdinclude = -I/usr/local/include -I/usr/X11R6/include -o = o -mdsrc ?= i3le.c -mdobj ?= i3le.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 -X -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-i3le b/src/ChezScheme/c/Mf-i3le deleted file mode 100644 index 801f9bf447..0000000000 --- a/src/ChezScheme/c/Mf-i3le +++ /dev/null @@ -1,44 +0,0 @@ -# Mf-i3le -# 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 ?= i3le -Cpu ?= I386 - -o = o -mdsrc ?= i3le.c -mdobj ?= i3le.o - -.SUFFIXES: -.SUFFIXES: .c .o - -.c.o: - $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c - -include Mf-base - -${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} - ${LD} -melf_i386 -r -X -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-i3nb b/src/ChezScheme/c/Mf-i3nb deleted file mode 100644 index 84d10bdf66..0000000000 --- a/src/ChezScheme/c/Mf-i3nb +++ /dev/null @@ -1,46 +0,0 @@ -# Mf-i3nb -# 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 ?= i3nb -Cpu ?= I386 - -mdinclude = -I/usr/X11R7/include -I/usr/pkg/include -I/usr/pkg/include/ncurses -I/usr/X11R6/include -o = o -mdsrc ?= i3le.c -mdobj ?= i3le.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} -m elf_i386 -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} - -${KernelLib}: ${kernelobj} - ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} - -${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} - $C -o ${Scheme} ${Main} ${Kernel} ${KernelLinkLibs} ${LDFLAGS} ${LIBS} - paxctl +m ${Scheme} - -../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-i3nt b/src/ChezScheme/c/Mf-i3nt index b7bd5bc32d..1166c3eb00 100644 --- a/src/ChezScheme/c/Mf-i3nt +++ b/src/ChezScheme/c/Mf-i3nt @@ -13,7 +13,6 @@ # See the License for the specific language governing permissions and # limitations under the License. -m ?= i3nt Cpu ?= I386 clib= diff --git a/src/ChezScheme/c/Mf-i3ob b/src/ChezScheme/c/Mf-i3ob deleted file mode 100644 index 6bb27a47e0..0000000000 --- a/src/ChezScheme/c/Mf-i3ob +++ /dev/null @@ -1,45 +0,0 @@ -# Mf-i3ob -# 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 ?= i3ob -Cpu ?= I386 - -mdinclude = -I/usr/local/include -I/usr/X11R6/include -o = o -mdsrc ?= i3le.c -mdobj ?= i3le.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 -X -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-i3osx b/src/ChezScheme/c/Mf-i3osx deleted file mode 100644 index 710e9ec515..0000000000 --- a/src/ChezScheme/c/Mf-i3osx +++ /dev/null @@ -1,45 +0,0 @@ -# Mf-i3osx -# 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 ?= i3osx -Cpu ?= I386 - -mdinclude = -I/opt/X11/include/ -o = o -mdsrc ?= i3le.c -mdobj ?= i3le.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-i3qnx b/src/ChezScheme/c/Mf-i3qnx deleted file mode 100644 index 3395c6ce50..0000000000 --- a/src/ChezScheme/c/Mf-i3qnx +++ /dev/null @@ -1,45 +0,0 @@ -# Mf-i3qnx -# 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 ?= i3qnx -Cpu ?= I386 - -o = o -mdsrc ?= i3le.c -mdobj ?= i3le.o -LocalInclude = /usr/local/include - -.SUFFIXES: -.SUFFIXES: .c .o - -.c.o: - $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} -I${LocalInclude} $*.c - -include Mf-base - -${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} - ${LD} -mi386nto -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} - -${KernelLib}: ${kernelobj} - ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} - -${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} - $C -Wl,--export-dynamic -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-i3s2 b/src/ChezScheme/c/Mf-i3s2 deleted file mode 100644 index 24930a36f2..0000000000 --- a/src/ChezScheme/c/Mf-i3s2 +++ /dev/null @@ -1,44 +0,0 @@ -# Mf-i3s2 -# 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 ?= i3s2 -Cpu ?= I386 - -o = o -mdsrc ?= i3le.c -mdobj ?= i3le.o - -.SUFFIXES: -.SUFFIXES: .c .o - -.c.o: - $C -c -DSOLARIS -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c - -include Mf-base - -${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} - ${LD} -melf_i386 -r -X -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-pb b/src/ChezScheme/c/Mf-pb deleted file mode 100644 index 4f26c6ca66..0000000000 --- a/src/ChezScheme/c/Mf-pb +++ /dev/null @@ -1,9 +0,0 @@ -# Mf-pb - -# Override definitions in `Mf-pbhost` -m = pb -Cpu = PORTABLE_BYTECODE -mdsrc = pb.c -mdobj = pb.o - -include Mf-pbhost diff --git a/src/ChezScheme/c/Mf-ppc32le b/src/ChezScheme/c/Mf-ppc32le deleted file mode 100644 index 6cd75d8a16..0000000000 --- a/src/ChezScheme/c/Mf-ppc32le +++ /dev/null @@ -1,44 +0,0 @@ -# Mf-ppc32le -# 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 ?= ppc32le -Cpu ?= PPC32 - -o = o -mdsrc ?= ppc32.c -mdobj ?= ppc32.o - -.SUFFIXES: -.SUFFIXES: .c .o - -.c.o: - $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c - -include Mf-base - -${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} - ${LD} -r -X -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-ppc32osx b/src/ChezScheme/c/Mf-ppc32osx deleted file mode 100644 index e6efbb1a54..0000000000 --- a/src/ChezScheme/c/Mf-ppc32osx +++ /dev/null @@ -1,32 +0,0 @@ -# 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 deleted file mode 100644 index dc61083b98..0000000000 --- a/src/ChezScheme/c/Mf-ta6fb +++ /dev/null @@ -1,5 +0,0 @@ -# Mf-ta6fb - -m ?= ta6fb - -include Mf-a6fb diff --git a/src/ChezScheme/c/Mf-ta6le b/src/ChezScheme/c/Mf-ta6le deleted file mode 100644 index 8cae7d4fa7..0000000000 --- a/src/ChezScheme/c/Mf-ta6le +++ /dev/null @@ -1,5 +0,0 @@ -# Mf-ta6le - -m ?= ta6le - -include Mf-a6le diff --git a/src/ChezScheme/c/Mf-ta6nb b/src/ChezScheme/c/Mf-ta6nb deleted file mode 100644 index bf7af020df..0000000000 --- a/src/ChezScheme/c/Mf-ta6nb +++ /dev/null @@ -1,6 +0,0 @@ - -# Mf-ta6nb - -m ?= ta6nb - -include Mf-a6nb diff --git a/src/ChezScheme/c/Mf-ta6nt b/src/ChezScheme/c/Mf-ta6nt index ea40fa996e..53b585efb3 100644 --- a/src/ChezScheme/c/Mf-ta6nt +++ b/src/ChezScheme/c/Mf-ta6nt @@ -1,5 +1,4 @@ # Mf-ta6nt -m ?= ta6nt include Mf-a6nt diff --git a/src/ChezScheme/c/Mf-ta6ob b/src/ChezScheme/c/Mf-ta6ob deleted file mode 100644 index 8c9c96cc85..0000000000 --- a/src/ChezScheme/c/Mf-ta6ob +++ /dev/null @@ -1,5 +0,0 @@ -# Mf-ta6ob - -m ?= ta6ob - -include Mf-a6ob diff --git a/src/ChezScheme/c/Mf-ta6osx b/src/ChezScheme/c/Mf-ta6osx deleted file mode 100644 index 4907914cb3..0000000000 --- a/src/ChezScheme/c/Mf-ta6osx +++ /dev/null @@ -1,5 +0,0 @@ -# Mf-ta6osx - -m ?= ta6osx - -include Mf-a6osx diff --git a/src/ChezScheme/c/Mf-ta6s2 b/src/ChezScheme/c/Mf-ta6s2 deleted file mode 100644 index 0f53ae4d2c..0000000000 --- a/src/ChezScheme/c/Mf-ta6s2 +++ /dev/null @@ -1,5 +0,0 @@ -# Mf-ta6s2 - -m ?= ta6s2 - -include Mf-a6s2 diff --git a/src/ChezScheme/c/Mf-tarm32le b/src/ChezScheme/c/Mf-tarm32le deleted file mode 100644 index 114107274e..0000000000 --- a/src/ChezScheme/c/Mf-tarm32le +++ /dev/null @@ -1,5 +0,0 @@ -# Mf-tarm32le - -m ?= tarm32le - -include Mf-arm32le diff --git a/src/ChezScheme/c/Mf-tarm64le b/src/ChezScheme/c/Mf-tarm64le deleted file mode 100644 index f3b71782f6..0000000000 --- a/src/ChezScheme/c/Mf-tarm64le +++ /dev/null @@ -1,5 +0,0 @@ -# Mf-tarm64le - -m ?= tarm64le - -include Mf-arm64le diff --git a/src/ChezScheme/c/Mf-tarm64osx b/src/ChezScheme/c/Mf-tarm64osx deleted file mode 100644 index e4d05eb21f..0000000000 --- a/src/ChezScheme/c/Mf-tarm64osx +++ /dev/null @@ -1,5 +0,0 @@ -# Mf-tarm64osx - -m ?= tarm64osx - -include Mf-arm64osx diff --git a/src/ChezScheme/c/Mf-ti3fb b/src/ChezScheme/c/Mf-ti3fb deleted file mode 100644 index e2d380dad6..0000000000 --- a/src/ChezScheme/c/Mf-ti3fb +++ /dev/null @@ -1,5 +0,0 @@ -# Mf-ti3fb - -m ?= ti3fb - -include Mf-i3fb diff --git a/src/ChezScheme/c/Mf-ti3le b/src/ChezScheme/c/Mf-ti3le deleted file mode 100644 index 606a736b77..0000000000 --- a/src/ChezScheme/c/Mf-ti3le +++ /dev/null @@ -1,5 +0,0 @@ -# Mf-ti3le - -m ?= ti3le - -include Mf-i3le diff --git a/src/ChezScheme/c/Mf-ti3nb b/src/ChezScheme/c/Mf-ti3nb deleted file mode 100644 index e32895d500..0000000000 --- a/src/ChezScheme/c/Mf-ti3nb +++ /dev/null @@ -1,5 +0,0 @@ -# Mf-ti3nb - -m ?= ti3nb - -include Mf-i3nb diff --git a/src/ChezScheme/c/Mf-ti3nt b/src/ChezScheme/c/Mf-ti3nt index 7016fbf080..3be81d0b19 100644 --- a/src/ChezScheme/c/Mf-ti3nt +++ b/src/ChezScheme/c/Mf-ti3nt @@ -1,5 +1,4 @@ # Mf-ti3nt -m ?= ti3nt include Mf-i3nt diff --git a/src/ChezScheme/c/Mf-ti3ob b/src/ChezScheme/c/Mf-ti3ob deleted file mode 100644 index bc3c1afd82..0000000000 --- a/src/ChezScheme/c/Mf-ti3ob +++ /dev/null @@ -1,5 +0,0 @@ -# Mf-ti3ob - -m ?= ti3ob - -include Mf-i3ob diff --git a/src/ChezScheme/c/Mf-ti3osx b/src/ChezScheme/c/Mf-ti3osx deleted file mode 100644 index 9cd7e049ac..0000000000 --- a/src/ChezScheme/c/Mf-ti3osx +++ /dev/null @@ -1,5 +0,0 @@ -# Mf-ti3osx - -m ?= ti3osx - -include Mf-i3osx diff --git a/src/ChezScheme/c/Mf-ti3s2 b/src/ChezScheme/c/Mf-ti3s2 deleted file mode 100644 index b73c553688..0000000000 --- a/src/ChezScheme/c/Mf-ti3s2 +++ /dev/null @@ -1,5 +0,0 @@ -# Mf-ti3s2 - -m ?= ti3s2 - -include Mf-i3s2 diff --git a/src/ChezScheme/c/Mf-tppc32le b/src/ChezScheme/c/Mf-tppc32le deleted file mode 100644 index b3c7f071b4..0000000000 --- a/src/ChezScheme/c/Mf-tppc32le +++ /dev/null @@ -1,5 +0,0 @@ -# Mf-tppc32le - -m ?= tppc32le - -include Mf-ppc32le diff --git a/src/ChezScheme/c/Mf-tppc32osx b/src/ChezScheme/c/Mf-tppc32osx deleted file mode 100644 index 2a1a6584ed..0000000000 --- a/src/ChezScheme/c/Mf-tppc32osx +++ /dev/null @@ -1,5 +0,0 @@ -# Mf-tppc32osx - -m ?= tppc32osx - -include Mf-ppc32osx diff --git a/src/ChezScheme/c/Mf-unix b/src/ChezScheme/c/Mf-unix new file mode 100644 index 0000000000..025c295a7d --- /dev/null +++ b/src/ChezScheme/c/Mf-unix @@ -0,0 +1,25 @@ +o = o + +include Mf-base + +.SUFFIXES: +.SUFFIXES: .c .o + +.c.o: + $C -c ${mdcppflags} -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} ${mdinclude} $*.c + +${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} + ${LD} -r -X ${mdldflags} -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} + +${KernelLib}: ${kernelobj} + ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} + +${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} + $C ${mdlinkflags} -o ${Scheme} ${Main} ${Kernel} ${KernelLinkLibs} ${LDFLAGS} ${LIBS} + ${exePostStep} + +../zlib/configure.log: + (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS}" LDFLAGS="${LDFLAGS}" ./configure ${zlibConfigureFlags}) + +../lz4/lib/liblz4.a: ${LZ4Sources} + (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS}" LDFLAGS="${LDFLAGS}" ${MAKE} liblz4.a) diff --git a/src/ChezScheme/c/alloc.c b/src/ChezScheme/c/alloc.c index cbeac73d54..52a29903e9 100644 --- a/src/ChezScheme/c/alloc.c +++ b/src/ChezScheme/c/alloc.c @@ -33,9 +33,10 @@ void S_alloc_init() { for (g = 0; g <= static_generation; g++) { S_G.bytes_of_generation[g] = 0; for (s = 0; s <= max_real_space; s++) { - S_G.main_thread_gc.base_loc[g][s] = FIX(0); - S_G.main_thread_gc.next_loc[g][s] = FIX(0); + S_G.main_thread_gc.base_loc[g][s] = FIX(0); + S_G.main_thread_gc.next_loc[g][s] = FIX(0); S_G.main_thread_gc.bytes_left[g][s] = 0; + S_G.main_thread_gc.sweep_next[g][s] = NULL; S_G.bytes_of_space[g][s] = 0; } } @@ -108,7 +109,7 @@ void S_reset_scheme_stack(tc, n) ptr tc; iptr n; { if (*x == snil) { if (n < default_stack_size) n = default_stack_size; /* stacks are untyped objects */ - find_room(tc, space_new, 0, typemod, n, SCHEMESTACK(tc)); + find_room(tc, space_new, 0, type_untyped, n, SCHEMESTACK(tc)); break; } if ((m = CACHEDSTACKSIZE(*x)) >= n) { @@ -224,6 +225,9 @@ static void close_off_segment(thread_gc *tgc, ptr old, ptr base_loc, ptr sweep_l /* in case this is during a GC, add to sweep list */ si = SegInfo(addr_get_segment(base_loc)); si->sweep_start = sweep_loc; +#if defined(WRITE_XOR_EXECUTE_CODE) + si->sweep_bytes = bytes; +#endif si->sweep_next = tgc->sweep_next[g][s]; tgc->sweep_next[g][s] = si; } @@ -240,7 +244,7 @@ ptr S_find_more_gc_room(thread_gc *tgc, ISPC s, IGEN g, iptr n, ptr old) { tgc->during_alloc += 1; - nsegs = (uptr)(n + ptr_bytes + bytes_per_segment - 1) >> segment_offset_bits; + nsegs = (uptr)(n + allocation_segment_tail_padding + bytes_per_segment - 1) >> segment_offset_bits; /* block requests to minimize fragmentation and improve cache locality */ if (s == space_code && nsegs < 16) nsegs = 16; @@ -252,9 +256,18 @@ ptr S_find_more_gc_room(thread_gc *tgc, ISPC s, IGEN g, iptr n, ptr old) { tgc->base_loc[g][s] = new; tgc->sweep_loc[g][s] = new; - tgc->bytes_left[g][s] = (new_bytes - n) - ptr_bytes; + tgc->bytes_left[g][s] = (new_bytes - n) - allocation_segment_tail_padding; tgc->next_loc[g][s] = (ptr)((uptr)new + n); +#if defined(WRITE_XOR_EXECUTE_CODE) + if (s == space_code) { + /* Ensure allocated code segments are writable. The caller should + already have bracketed the writes with calls to start and stop + so there is no need for a stop here. */ + S_thread_start_code_write(tgc->tc, 0, 1, NULL, 0); + } +#endif + if (tgc->during_alloc == 1) maybe_queue_fire_collector(tgc); tgc->during_alloc -= 1; @@ -275,6 +288,7 @@ void S_close_off_thread_local_segment(ptr tc, ISPC s, IGEN g) { tgc->bytes_left[g][s] = 0; tgc->next_loc[g][s] = (ptr)0; tgc->sweep_loc[g][s] = (ptr)0; + tgc->sweep_next[g][s] = NULL; } /* S_reset_allocation_pointer is always called with allocation mutex @@ -360,7 +374,7 @@ void S_dirty_set(ptr *loc, ptr x) { seginfo *si = SegInfo(addr_get_segment(TO_PTR(loc))); if (si->use_marks) { /* GC must be in progress */ - if (!IMMEDIATE(x)) { + if (!FIXMEDIATE(x)) { seginfo *t_si = SegInfo(ptr_get_segment(x)); if (t_si->generation < si->generation) S_record_new_dirty_card(THREAD_GC(get_thread_context()), loc, t_si->generation); @@ -463,7 +477,8 @@ void S_get_more_room() { ptr xp; uptr ap, type, size; xp = XP(tc); - if ((type = TYPEBITS(xp)) == 0) type = typemod; + type = TYPEBITS(xp); + if ((type_untyped != 0) && (type == 0)) type = type_untyped; ap = (uptr)UNTYPE(xp, type); size = (uptr)((iptr)AP(tc) - (iptr)ap); @@ -713,10 +728,10 @@ ptr S_flvector(n) iptr n; { } ptr S_bytevector(n) iptr n; { - return S_bytevector2(get_thread_context(), n, 0); + return S_bytevector2(get_thread_context(), n, space_new); } -ptr S_bytevector2(tc, n, immobile) ptr tc; iptr n; IBOOL immobile; { +ptr S_bytevector2(tc, n, spc) ptr tc; iptr n; ISPC spc; { ptr p; iptr d; if (n == 0) return S_G.null_bytevector; @@ -725,8 +740,8 @@ ptr S_bytevector2(tc, n, immobile) ptr tc; iptr n; IBOOL immobile; { S_error("", "invalid bytevector size request"); d = size_bytevector(n); - if (immobile) - find_room(tc, space_immobile_data, 0, type_typed_object, d, p); + if (spc != space_new) + find_room(tc, spc, 0, type_typed_object, d, p); else newspace_find_room(tc, type_typed_object, d, p); BYTEVECTOR_TYPE(p) = (n << bytevector_length_offset) | type_bytevector; @@ -1028,6 +1043,9 @@ ptr S_bignum(tc, n, sign) ptr tc; iptr n; IBOOL sign; { if ((uptr)n > (uptr)maximum_bignum_length) S_error("", "invalid bignum size request"); + /* for anything that allocates bignums, make sure scheduling fuel is consumed */ + USE_TRAP_FUEL(tc, n); + d = size_bignum(n); newspace_find_room(tc, type_typed_object, d, p); BIGTYPE(p) = (uptr)n << bignum_length_offset | sign << bignum_sign_offset | type_bignum; @@ -1053,7 +1071,7 @@ ptr S_relocation_table(n) iptr n; { ptr p; iptr d; d = size_reloc_table(n); - newspace_find_room(tc, typemod, d, p); + newspace_find_room(tc, type_untyped, d, p); RELOCSIZE(p) = n; return p; } diff --git a/src/ChezScheme/c/arm32le.c b/src/ChezScheme/c/arm32le.c index 085ef0be5b..48023452ef 100644 --- a/src/ChezScheme/c/arm32le.c +++ b/src/ChezScheme/c/arm32le.c @@ -19,6 +19,10 @@ #include <sys/types.h> #include <sys/mman.h> +#ifdef TARGET_OS_IPHONE +# include <libkern/OSCacheControl.h> +#endif + /* we don't count on having the right value for correctness, * but the right value will give maximum efficiency */ #define DEFAULT_L1_MAX_CACHE_LINE_SIZE 32 @@ -35,7 +39,18 @@ void S_doflush(uptr start, uptr end) { printf(" doflush(%x, %x)\n", start, end); fflush(stdout); #endif +#ifdef TARGET_OS_IPHONE + sys_icache_invalidate((void *)start, (char *)end-(char *)start); +#else __clear_cache((char *)start, (char *)end); +# if defined(__clang__) && defined(__aarch64__) && !defined(__APPLE__) + /* Seem to need an extra combination of barriers here to make up for + something in Clang's __clear_cache() */ + asm volatile ("dsb ish\n\t" + "isb" + : : : "memory"); +# endif +#endif } void S_machine_init() { diff --git a/src/ChezScheme/c/atomic.h b/src/ChezScheme/c/atomic.h index 854de274b5..5fb98e0dde 100644 --- a/src/ChezScheme/c/atomic.h +++ b/src/ChezScheme/c/atomic.h @@ -1,11 +1,11 @@ #if !defined(PTHREADS) # define STORE_FENCE() do { } while (0) -#elif defined(__arm64__) +#elif defined(__arm64__) || defined(__aarch64__) # define STORE_FENCE() __asm__ __volatile__ ("dmb ishst" : : : "memory") # define ACQUIRE_FENCE() __asm__ __volatile__ ("dmb ish" : : : "memory") # define RELEASE_FENCE() ACQUIRE_FENCE() #elif defined(__arm__) -# if arm_isa_version == 7 +# if (arm_isa_version >= 7) || (__ARM_ARCH >= 7) # define STORE_FENCE() __asm__ __volatile__ ("dmb ishst" : : : "memory") # define ACQUIRE_FENCE() __asm__ __volatile__ ("dmb ish" : : : "memory") # define RELEASE_FENCE() ACQUIRE_FENCE() @@ -35,7 +35,7 @@ #if !defined(PTHREADS) # define CAS_ANY_FENCE(a, old, new) ((*(a) == (old)) ? (*(a) = (new), 1) : 0) -#elif defined(__arm64__) +#elif defined(__arm64__) || defined(__aarch64__) FORCEINLINE int CAS_LOAD_ACQUIRE(volatile void *addr, void *old_val, void *new_val) { long ret; __asm__ __volatile__ ("mov %0, #0\n\t" @@ -72,15 +72,18 @@ FORCEINLINE int CAS_STORE_RELEASE(volatile void *addr, void *old_val, void *new_ return ret; } #elif defined(__arm__) -FORCEINLINE int S_cas_any_fence(volatile void *addr, void *old_val, void *new_val) { +FORCEINLINE int S_cas_any_fence(int load_acquire, volatile void *addr, void *old_val, void *new_val) { int ret; - __asm__ __volatile__ ("mcr p15, 0, %0, c7, c10, 5\n\t" - "mov %0, #0\n\t" + if (load_acquire) + ACQUIRE_FENCE(); + else + RELEASE_FENCE(); + __asm__ __volatile__ ("mov %0, #0\n\t" "0:\n\t" - "ldrex r12, [%1, #0]\n\t" + "ldrex r12, [%1]\n\t" "cmp r12, %2\n\t" "bne 1f\n\t" - "strex r7, %3, [%1, #0]\n\t" + "strex r7, %3, [%1]\n\t" "cmp r7, #0\n\t" "bne 1f\n\t" "it eq\n\t" @@ -91,7 +94,8 @@ FORCEINLINE int S_cas_any_fence(volatile void *addr, void *old_val, void *new_va : "cc", "memory", "r12", "r7"); return ret; } -# define CAS_ANY_FENCE(a, old, new) S_cas_any_fence(a, old, new) +# define CAS_LOAD_ACQUIRE(a, old, new) S_cas_any_fence(1, a, old, new) +# define CAS_STORE_RELEASE(a, old, new) S_cas_any_fence(0, a, old, new) #elif (__GNUC__ >= 5) || defined(__clang__) # define CAS_ANY_FENCE(a, old, new) __sync_bool_compare_and_swap(a, old, new) #elif defined(_MSC_VER) diff --git a/src/ChezScheme/c/expeditor.c b/src/ChezScheme/c/expeditor.c index 6dd849ba34..faef7ebb94 100644 --- a/src/ChezScheme/c/expeditor.c +++ b/src/ChezScheme/c/expeditor.c @@ -548,7 +548,6 @@ static void s_ee_write_char(wchar_t c) { #endif #include <termios.h> #include <signal.h> -#include <time.h> #include <fcntl.h> #include <sys/ioctl.h> #include <wchar.h> @@ -741,7 +740,7 @@ static ptr s_ee_get_screen_size(void) { static IBOOL tried_resize = 0; /* attempt to work around 10.6 tty driver / xterm bug */ if (ee_rows == 0 && ee_cols == 0 && !tried_resize) { - system("exec /usr/X11/bin/resize >& /dev/null"); + SYSTEM("exec /usr/X11/bin/resize >& /dev/null"); tried_resize = 1; return s_ee_get_screen_size(); } diff --git a/src/ChezScheme/c/externs.h b/src/ChezScheme/c/externs.h index 059ed85c4c..c0bc380d0b 100644 --- a/src/ChezScheme/c/externs.h +++ b/src/ChezScheme/c/externs.h @@ -23,6 +23,7 @@ #include <stdlib.h> #include <string.h> #include <errno.h> +#include <time.h> #ifndef WIN32 #include <unistd.h> @@ -88,7 +89,7 @@ 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((ptr tc, iptr n, IBOOL immobile)); +extern ptr S_bytevector2 PROTO((ptr tc, iptr n, ISPC spc)); extern ptr S_null_immutable_vector PROTO((void)); extern ptr S_null_immutable_fxvector PROTO((void)); extern ptr S_null_immutable_bytevector PROTO((void)); @@ -313,6 +314,7 @@ extern ptr S_gcd PROTO((ptr x, ptr y)); extern ptr S_ash PROTO((ptr x, ptr n)); extern ptr S_big_positive_bit_field PROTO((ptr x, ptr fxstart, ptr fxend)); extern ptr S_integer_length PROTO((ptr x)); +extern ptr S_big_trailing_zero_bits PROTO((ptr x)); extern ptr S_big_first_bit_set PROTO((ptr x)); extern double S_random_double PROTO((U32 m1, U32 m2, U32 m3, U32 m4, double scale)); @@ -393,8 +395,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); +extern void S_thread_start_code_write PROTO((ptr tc, IGEN maxg, IBOOL current, void *hint, uptr hint_len)); +extern void S_thread_end_code_write PROTO((ptr tc, IGEN maxg, IBOOL current, void *hint, uptr hint_len)); /* stats.c */ extern void S_stats_init PROTO((void)); @@ -438,7 +440,7 @@ extern INT S_getpagesize(void); extern ptr S_LastErrorString(void); extern void *S_ntdlopen(const char *path); extern void *S_ntdlsym(void *h, const char *s); -extern char *S_ntdlerror(void); +extern ptr S_ntdlerror(void); extern int S_windows_flock(int fd, int operation); extern int S_windows_chdir(const char *pathname); extern int S_windows_chmod(const char *pathname, int mode); diff --git a/src/ChezScheme/c/fasl.c b/src/ChezScheme/c/fasl.c index 25bc6a3802..9ef0a3e930 100644 --- a/src/ChezScheme/c/fasl.c +++ b/src/ChezScheme/c/fasl.c @@ -508,7 +508,7 @@ static ptr fasl_entry(ptr tc, IFASLCODE situation, unbufFaslFile uf, ptr externa Scompact_heap(); } - S_thread_start_code_write(); + S_thread_start_code_write(tc, S_vfasl_boot_mode ? static_generation : 0, 1, NULL, 0); switch (ty) { case fasl_type_gzip: @@ -557,7 +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(); + S_thread_end_code_write(tc, S_vfasl_boot_mode ? static_generation : 0, 1, NULL, 0); return x; } else { uf_skipbytes(uf, size); @@ -569,7 +569,7 @@ 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(); + S_thread_start_code_write(tc, S_vfasl_boot_mode ? static_generation : 0, 1, NULL, 0); if (ty == fasl_type_vfasl) { x = S_vfasl(bv, NULL, offset, len); @@ -585,8 +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(); - + S_thread_end_code_write(tc, S_vfasl_boot_mode ? static_generation : 0, 1, NULL, 0); + return x; } @@ -1569,7 +1569,10 @@ static void pb_set_abs(void *address, uptr item) { 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)); + /* pb_link is the same as pb_mov16_pb_zero_bits_pb_shift0, but with + a promise of the subsequent instructions to load a full word */ + + ((U32 *)address)[0] = (pb_link | 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)); diff --git a/src/ChezScheme/c/flushcache.c b/src/ChezScheme/c/flushcache.c index 6ddcfbef2b..7a520a4ffd 100644 --- a/src/ChezScheme/c/flushcache.c +++ b/src/ChezScheme/c/flushcache.c @@ -30,7 +30,7 @@ static uptr max_gap; static ptr make_mod_range PROTO((ptr tc, uptr start, uptr end)); static ptr make_mod_range(ptr tc, uptr start, uptr end) { - ptr bv = S_bytevector2(tc, sizeof(mod_range), 0); + ptr bv = S_bytevector2(tc, sizeof(mod_range), space_new); mod_range_start(bv) = start; mod_range_end(bv) = end; return bv; diff --git a/src/ChezScheme/c/foreign.c b/src/ChezScheme/c/foreign.c index 318b2c7be6..de8be702f3 100644 --- a/src/ChezScheme/c/foreign.c +++ b/src/ChezScheme/c/foreign.c @@ -36,13 +36,14 @@ #if defined(HPUX) #include <dl.h> #define dlopen(path,flags) (void *)shl_load(path, BIND_IMMEDIATE, 0L) -#define dlerror() strerror(errno) +#define s_dlerror() Sstring_utf8(strerror(errno), -1) #elif defined(WIN32) #define dlopen(path,flags) S_ntdlopen(path) #define dlsym(h,s) S_ntdlsym(h,s) -#define dlerror() S_ntdlerror() +#define s_dlerror() S_ntdlerror() #else #include <dlfcn.h> +#define s_dlerror() Sstring_utf8(dlerror(), -1) #ifndef RTLD_NOW #define RTLD_NOW 2 #endif /* RTLD_NOW */ @@ -230,8 +231,7 @@ static void load_shared_object(path) const char *path; { handle = dlopen(path, RTLD_NOW); if (handle == (void *)NULL) - S_error2("", "(while loading ~a) ~a", Sstring_utf8(path, -1), - Sstring_utf8(dlerror(), -1)); + S_error2("", "(while loading ~a) ~a", Sstring_utf8(path, -1), s_dlerror()); S_foreign_dynamic = Scons(addr_to_ptr(handle), S_foreign_dynamic); tc_mutex_release(); diff --git a/src/ChezScheme/c/gc.c b/src/ChezScheme/c/gc.c index 7739a8e4ce..49b98b4b9c 100644 --- a/src/ChezScheme/c/gc.c +++ b/src/ChezScheme/c/gc.c @@ -126,7 +126,7 @@ Parallel mode runs `sweep_generation` concurrently in multiple sweeper threads. It relies on a number of invariants: - * There are no attempts to take tc_mutex suring sweeping. To the + * There are no attempts to take tc_mutex during sweeping. To the degree that locking is needed (e.g., to allocate new segments), the allocation mutex is used. No other locks can be taken while that one is held. @@ -167,7 +167,7 @@ * Normally, a sweeper that encounters a remote reference can continue sweeping and eventually register the remote re-sweep. - An object is swept by only one sweeper at a time; if mmultiple + An object is swept by only one sweeper at a time; if multiple remote references to different sweepers are discovered in an object, it is sent to only one of the remote sweepers, and that sweeper will eventually send on the object to the other sweeper. @@ -223,7 +223,7 @@ static void record_dirty_segment PROTO((IGEN from_g, IGEN to_g, seginfo *si)); static void setup_sweep_dirty PROTO((thread_gc *tgc)); static uptr sweep_dirty_segments PROTO((thread_gc *tgc, seginfo **dirty_segments)); static void resweep_dirty_weak_pairs PROTO((thread_gc *tgc)); -static void mark_typemod_data_object PROTO((thread_gc *tgc, ptr p, uptr len, seginfo *si)); +static void mark_untyped_data_object PROTO((thread_gc *tgc, ptr p, uptr len, seginfo *si)); static void add_pending_guardian PROTO((ptr gdn, ptr tconc)); static void add_trigger_guardians_to_recheck PROTO((ptr ls)); static void add_ephemeron_to_pending PROTO((thread_gc *tgc, ptr p)); @@ -563,7 +563,7 @@ static int flonum_is_forwarded_p(ptr p, seginfo *si) { #define relocate_pure_help(ppp, pp) do { \ seginfo *SI; \ - if (!IMMEDIATE(pp) && (SI = MaybeSegInfo(ptr_get_segment(pp))) != NULL) { \ + if (!FIXMEDIATE(pp) && (SI = MaybeSegInfo(ptr_get_segment(pp))) != NULL) { \ if (SI->old_space) \ relocate_pure_help_help(ppp, pp, SI); \ ELSE_MEASURE_NONOLDSPACE(pp) \ @@ -609,7 +609,7 @@ static int flonum_is_forwarded_p(ptr p, seginfo *si) { static void do_relocate_pure_in_owner(thread_gc *tgc, ptr *ppp) { seginfo *si; ptr pp = *ppp; - if (!IMMEDIATE(pp) + if (!FIXMEDIATE(pp) && (si = MaybeSegInfo(ptr_get_segment(pp))) != NULL && si->old_space) { BLOCK_SET_THREAD(si->creator); @@ -639,7 +639,7 @@ static void do_relocate_pure_in_owner(thread_gc *tgc, ptr *ppp) { #define relocate_impure_help(ppp, pp, from_g) do { \ seginfo *SI; \ - if (!IMMEDIATE(pp) && (SI = MaybeSegInfo(ptr_get_segment(pp))) != NULL) { \ + if (!FIXMEDIATE(pp) && (SI = MaybeSegInfo(ptr_get_segment(pp))) != NULL) { \ if (SI->old_space) \ relocate_impure_help_help(ppp, pp, from_g, SI); \ ELSE_MEASURE_NONOLDSPACE(pp) \ @@ -673,7 +673,7 @@ static void do_relocate_pure_in_owner(thread_gc *tgc, ptr *ppp) { #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 (!FIXMEDIATE(_pp) && (_si = MaybeSegInfo(ptr_get_segment(_pp))) != NULL) { \ if (!_si->old_space) { \ _pg = _si->generation; \ } else { \ @@ -697,6 +697,24 @@ static void do_relocate_pure_in_owner(thread_gc *tgc, ptr *ppp) { } \ } while (0) +#define relocate_reference(ppp, from_g) do { \ + ptr* rPPP = ppp; ptr rPP = *rPPP; \ + if (!FOREIGN_REFERENCEP(rPP)) { \ + *rPPP = S_reference_to_object(rPP); \ + relocate_impure(rPPP, from_g); \ + *rPPP = S_object_to_reference(*rPPP); \ + } \ + } while (0) + +#define relocate_reference_dirty(ppp, YOUNGEST) do { \ + ptr* rPPP = ppp; \ + if (!FOREIGN_REFERENCEP(*rPPP)) { \ + *rPPP = S_reference_to_object(*rPPP); \ + relocate_dirty(rPPP, YOUNGEST); \ + *rPPP = S_object_to_reference(*rPPP); \ + } \ + } while (0) + #ifdef ENABLE_OBJECT_COUNTS # define is_counting_root(si, p) (si->counting_mask && (si->counting_mask[segment_bitmap_byte(p)] & segment_bitmap_bit(p))) #endif @@ -706,6 +724,14 @@ static void do_relocate_pure_in_owner(thread_gc *tgc, ptr *ppp) { relocate_pure(&_P); \ } while (0) +# define relocate_reference_indirect(p) do { \ + ptr _P = p; \ + if (!FOREIGN_REFERENCEP(_P)) { \ + _P = S_reference_to_object(_P); \ + relocate_pure(&_P); \ + } \ + } while (0) + FORCEINLINE void check_triggers(thread_gc *tgc, seginfo *si) { /* Registering ephemerons and guardians to recheck at the granularity of a segment means that the worst-case complexity of @@ -779,7 +805,7 @@ static ptr copy_stack(thread_gc *tgc, ptr old, iptr *length, iptr clength) { #ifndef NO_NEWSPACE_MARKS if (si->use_marks) { if (!marked(si, old)) { - mark_typemod_data_object(tgc, old, n, si); + mark_untyped_data_object(tgc, old, n, si); #ifdef ENABLE_OBJECT_COUNTS S_G.countof[newg][countof_stack] += 1; @@ -805,7 +831,7 @@ static ptr copy_stack(thread_gc *tgc, ptr old, iptr *length, iptr clength) { if (n == 0) { return (ptr)0; } else { - find_gc_room(tgc, space_data, newg, typemod, n, new); + find_gc_room(tgc, space_data, newg, type_untyped, n, new); n = ptr_align(clength); /* warning: stack may have been left non-double-aligned by split_and_resize */ memcpy_aligned(TO_VOIDP(new), TO_VOIDP(old), n); @@ -815,7 +841,7 @@ static ptr copy_stack(thread_gc *tgc, ptr old, iptr *length, iptr clength) { } } -#define NONSTATICINHEAP(si, x) (!IMMEDIATE(x) && (si = MaybeSegInfo(ptr_get_segment(x))) != NULL && si->generation != static_generation) +#define NONSTATICINHEAP(si, x) (!FIXMEDIATE(x) && (si = MaybeSegInfo(ptr_get_segment(x))) != NULL && si->generation != static_generation) #define ALWAYSTRUE(si, x) (si = SegInfo(ptr_get_segment(x)), 1) #define partition_guardians(LS, FILTER) do { \ ptr ls; seginfo *si; \ @@ -870,7 +896,7 @@ ptr GCENTRY(ptr tc, ptr count_roots_ls) { GET_REAL_TIME(astart); - S_thread_start_code_write(); + S_thread_start_code_write(tc, MAX_TG, 0, NULL, 0); /* flush instruction cache: effectively clear_code_mod but safer */ for (ls = S_threads; ls != Snil; ls = Scdr(ls)) { @@ -1070,7 +1096,7 @@ ptr GCENTRY(ptr tc, ptr count_roots_ls) { for (ls = count_roots_ls, i = 0; ls != Snil; ls = Scdr(ls), i++) { ptr p = Scar(ls); - if (IMMEDIATE(p)) { + if (FIXMEDIATE(p)) { count_roots[i].p = p; count_roots[i].weak = 0; } else { @@ -1106,7 +1132,7 @@ ptr GCENTRY(ptr tc, ptr count_roots_ls) { for (i = 0; i < count_roots_len; i++) { uptr total; ptr p = count_roots[i].p; - if (IMMEDIATE(p)) { + if (FIXMEDIATE(p)) { /* nothing to do */ } else { seginfo *si = SegInfo(ptr_get_segment(p)); @@ -1152,7 +1178,7 @@ ptr GCENTRY(ptr tc, ptr count_roots_ls) { /* clear `counting_mask`s */ for (i = 0; i < count_roots_len; i++) { ptr p = count_roots[i].p; - if (!IMMEDIATE(p)) { + if (!FIXMEDIATE(p)) { seginfo *si = SegInfo(ptr_get_segment(p)); si->counting_mask = NULL; } @@ -1368,7 +1394,7 @@ ptr GCENTRY(ptr tc, ptr count_roots_ls) { pend_hold_ls = ls; } else { seginfo *si; - if (!IMMEDIATE(rep) && (si = MaybeSegInfo(ptr_get_segment(rep))) != NULL && si->old_space) { + if (!FIXMEDIATE(rep) && (si = MaybeSegInfo(ptr_get_segment(rep))) != NULL && si->old_space) { /* mark things reachable from `rep`, but not `rep` itself, unless `rep` is immediately reachable from itself */ PUSH_BACKREFERENCE(ls) @@ -1440,7 +1466,7 @@ ptr GCENTRY(ptr tc, ptr count_roots_ls) { /* In backreference mode, we rely on sweep of the guardian entry not registering any backreferences. Otherwise, bogus pair pointers would get created. */ - find_gc_room(tgc, space_pure, g, typemod, size_guardian_entry, p); + find_gc_room(tgc, space_pure, g, type_untyped, size_guardian_entry, p); INITGUARDIANOBJ(p) = GUARDIANOBJ(ls); INITGUARDIANREP(p) = rep; INITGUARDIANTCONC(p) = tconc; @@ -1679,7 +1705,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(); + S_thread_end_code_write(tc, MAX_TG, 0, NULL, 0); #ifndef NO_DIRTY_NEWSPACE_POINTERS /* mark dirty those newspace cards to which we've added wrong-way pointers */ @@ -1885,7 +1911,7 @@ static void resweep_weak_pairs(seginfo *oldweakspacesegments) { static void forward_or_bwp(pp, p) ptr *pp; ptr p; { seginfo *si; /* adapted from relocate */ - if (!IMMEDIATE(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL && si->old_space && !new_marked(si, p)) { + if (!FIXMEDIATE(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL && si->old_space && !new_marked(si, p)) { if (FORWARDEDP(p, si)) { *pp = GET_FWDADDRESS(p); } else { @@ -1907,14 +1933,14 @@ 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 */ + /* only pairs in these 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)); + FLUSH_REMOTE(tgc, TYPE(TO_PTR(pp), type_pair)); /* can always treat as a pair to sweep words */ pp = ppn + 1; }); SET_BACKREFERENCE(Sfalse); @@ -1996,6 +2022,12 @@ static iptr sweep_generation_pass(thread_gc *tgc) { sweep(tgc, p, from_g); pp = TO_VOIDP((uptr)TO_PTR(pp) + size_object(p)); }); + + sweep_space(space_reference_array, from_g, { + p = TYPE(TO_PTR(pp), type_typed_object); + pp = TO_VOIDP((uptr)TO_PTR(pp) + sweep_typed_object(tgc, p, from_g)); + }); + } /* May add to the sweep stack: */ @@ -2028,7 +2060,7 @@ void enlarge_stack(thread_gc *tgc, ptr *stack, ptr *stack_start, ptr *stack_limi 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); + find_gc_room(tgc, space_data, 0, type_untyped, ptr_align(new_sz), new_stack); if (sz != 0) memcpy(TO_VOIDP(new_stack), TO_VOIDP(*stack_start), sz); tgc->bitmask_overhead[0] += ptr_align(new_sz); @@ -2448,6 +2480,33 @@ static uptr sweep_dirty_segments(thread_gc *tgc, seginfo **dirty_segments) { youngest = check_dirty_ephemeron(tgc, p, youngest); pp += size_ephemeron / sizeof(ptr); } + } else if (s == space_reference_array) { + /* the same as space_impure and others above, but for object references */ + if (dirty_si->marked_mask) { + while (pp < ppend) { + /* handle two pointers at a time */ + if (marked(dirty_si, TO_PTR(pp))) { + FLUSH_REMOTE_BLOCK + relocate_reference_dirty(pp, youngest); + ppn = pp + 1; + relocate_reference_dirty(ppn, youngest); + FLUSH_REMOTE(tgc, TYPE(TO_PTR(pp), type_pair)); /* can treat as a pair for resweep */ + pp = ppn + 1; + } else { + pp += 2; + } + } + } else { + while (pp < ppend && *pp != forward_marker) { + /* handle two pointers at a time */ + FLUSH_REMOTE_BLOCK + relocate_reference_dirty(pp, youngest); + ppn = pp + 1; + relocate_reference_dirty(ppn, youngest); + FLUSH_REMOTE(tgc, TYPE(TO_PTR(pp), type_pair)); + pp = ppn + 1; + } + } } else { S_error_abort("sweep_dirty(gc): unexpected space"); } @@ -2526,7 +2585,7 @@ static void resweep_dirty_weak_pairs(thread_gc *tgc) { seginfo *si; /* handle car field */ - if (!IMMEDIATE(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL) { + if (!FIXMEDIATE(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL) { if (si->old_space) { if (new_marked(si, p)) { youngest = TARGET_GENERATION(si); @@ -2637,7 +2696,7 @@ static void check_ephemeron(thread_gc *tgc, ptr pe) { from_g = GENERATION(pe); p = Scar(pe); - if (!IMMEDIATE(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL && si->old_space) { + if (!FIXMEDIATE(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL && si->old_space) { if (SEGMENT_IS_LOCAL(si, p)) { if (new_marked(si, p)) { #ifndef NO_DIRTY_NEWSPACE_POINTERS @@ -2696,7 +2755,7 @@ static IGEN check_dirty_ephemeron(thread_gc *tgc, ptr pe, IGEN youngest) { PUSH_BACKREFERENCE(pe); p = Scar(pe); - if (!IMMEDIATE(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL) { + if (!FIXMEDIATE(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL) { if (si->old_space) { if (SEGMENT_IS_LOCAL(si, p)) { if (new_marked(si, p)) { @@ -2950,7 +3009,9 @@ static void setup_sweepers(thread_gc *tgc) { static s_thread_rv_t start_sweeper(void *_sweeper) { gc_sweeper *sweeper = _sweeper; - S_thread_start_code_write(); /* never ended */ +#if !defined(WRITE_XOR_EXECUTE_CODE) + S_thread_start_code_write((ptr)0, static_generation, 0, NULL, 0); /* never ended */ +#endif (void)s_thread_mutex_lock(&sweep_mutex); while (1) { @@ -3303,7 +3364,7 @@ static void add_ephemeron_to_pending_measure(thread_gc *tgc, ptr pe) { seginfo *si; ptr p = Scar(pe); - if (!IMMEDIATE(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL && si->old_space) + if (!FIXMEDIATE(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL && si->old_space) add_ephemeron_to_pending(tgc, pe); else { if (EPHEMERONPREVREF(pe)) @@ -3324,7 +3385,7 @@ static void check_ephemeron_measure(thread_gc *tgc, ptr pe) { EPHEMERONNEXT(pe) = 0; p = Scar(pe); - if (!IMMEDIATE(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL + if (!FIXMEDIATE(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL && (si->generation <= max_measure_generation) && (si->generation >= min_measure_generation) && (!(si->old_space) || !FORWARDEDP(p, si)) @@ -3339,7 +3400,7 @@ static void check_ephemeron_measure(thread_gc *tgc, ptr pe) { } p = Scdr(pe); - if (!IMMEDIATE(p)) + if (!FIXMEDIATE(p)) push_measure(tgc, p); } @@ -3396,7 +3457,7 @@ ptr S_count_size_increments(ptr ls, IGEN generation) { for (l = ls; l != Snil; l = Scdr(l)) { ptr p = Scar(l); - if (!IMMEDIATE(p)) { + if (!FIXMEDIATE(p)) { seginfo *si = SegInfo(ptr_get_segment(p)); if (!si->measured_mask) @@ -3414,7 +3475,7 @@ ptr S_count_size_increments(ptr ls, IGEN generation) { measure_total = 0; - if (!IMMEDIATE(p)) { + if (!FIXMEDIATE(p)) { seginfo *si = SegInfo(ptr_get_segment(p)); measure_mask_unset(si->counting_mask, si, p); gc_measure_one(tgc, p); @@ -3430,7 +3491,7 @@ ptr S_count_size_increments(ptr ls, IGEN generation) { for (l = ls; l != Snil; l = Scdr(l)) { ptr p = Scar(l); - if (!IMMEDIATE(p)) { + if (!FIXMEDIATE(p)) { seginfo *si = SegInfo(ptr_get_segment(p)); si->counting_mask = NULL; } diff --git a/src/ChezScheme/c/gcwrapper.c b/src/ChezScheme/c/gcwrapper.c index 857cf5d7c5..bf82e587bf 100644 --- a/src/ChezScheme/c/gcwrapper.c +++ b/src/ChezScheme/c/gcwrapper.c @@ -185,7 +185,7 @@ void S_set_minmarkgen(IGEN g) { void S_immobilize_object(x) ptr x; { seginfo *si; - if (IMMEDIATE(x)) + if (FIXMEDIATE(x)) si = NULL; else si = MaybeSegInfo(ptr_get_segment(x)); @@ -212,7 +212,7 @@ void S_immobilize_object(x) ptr x; { void S_mobilize_object(x) ptr x; { seginfo *si; - if (IMMEDIATE(x)) + if (FIXMEDIATE(x)) si = NULL; else si = MaybeSegInfo(ptr_get_segment(x)); @@ -261,7 +261,7 @@ static IBOOL remove_first_nomorep(x, pls, look) ptr x, *pls; IBOOL look; { IBOOL Slocked_objectp(x) ptr x; { seginfo *si; IGEN g; IBOOL ans; ptr ls; - if (IMMEDIATE(x) || (si = MaybeSegInfo(ptr_get_segment(x))) == NULL || (g = si->generation) == static_generation) return 1; + if (FIXMEDIATE(x) || (si = MaybeSegInfo(ptr_get_segment(x))) == NULL || (g = si->generation) == static_generation) return 1; tc_mutex_acquire(); @@ -299,7 +299,7 @@ void Slock_object(x) ptr x; { seginfo *si; IGEN g; /* weed out pointers that won't be relocated */ - if (!IMMEDIATE(x) && (si = MaybeSegInfo(ptr_get_segment(x))) != NULL && (g = si->generation) != static_generation) { + if (!FIXMEDIATE(x) && (si = MaybeSegInfo(ptr_get_segment(x))) != NULL && (g = si->generation) != static_generation) { ptr tc = get_thread_context(); tc_mutex_acquire(); THREAD_GC(tc)->during_alloc += 1; @@ -323,7 +323,7 @@ void Slock_object(x) ptr x; { void Sunlock_object(x) ptr x; { seginfo *si; IGEN g; - if (!IMMEDIATE(x) && (si = MaybeSegInfo(ptr_get_segment(x))) != NULL && (g = si->generation) != static_generation) { + if (!FIXMEDIATE(x) && (si = MaybeSegInfo(ptr_get_segment(x))) != NULL && (g = si->generation) != static_generation) { ptr tc = get_thread_context(); tc_mutex_acquire(); THREAD_GC(tc)->during_alloc += 1; @@ -548,9 +548,13 @@ void S_addr_tell(ptr p) { segment_tell(addr_get_segment(p)); } -static void check_pointer(ptr *pp, IBOOL address_is_meaningful, ptr base, uptr seg, ISPC s, IBOOL aftergc) { +static void check_pointer(ptr *pp, IBOOL address_is_meaningful, IBOOL is_reference, ptr base, uptr seg, ISPC s, IBOOL aftergc) { ptr p = *pp; - if (!IMMEDIATE(p)) { + + if (is_reference) + p = S_reference_to_object(p); + + if (!FIXMEDIATE(p)) { seginfo *psi = MaybeSegInfo(ptr_get_segment(p)); if (psi != NULL) { if ((psi->space == space_empty) @@ -769,7 +773,7 @@ void S_check_heap(aftergc, mcg) IBOOL aftergc; IGEN mcg; { } 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) { + || s == space_impure_record || s == space_impure_typed_object || s == space_reference_array) { ptr start; /* check for dangling references */ @@ -884,7 +888,7 @@ void S_check_heap(aftergc, mcg) IBOOL aftergc; IGEN mcg; { 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) +#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 { @@ -893,7 +897,7 @@ void S_check_heap(aftergc, mcg) IBOOL aftergc; IGEN mcg; { pp1 = pp2; /* break out of outer loop */ break; } else { - check_pointer(pp1, 1, (ptr)0, seg, s, aftergc); + check_pointer(pp1, 1, (s == space_reference_array), (ptr)0, seg, s, aftergc); } } pp1 += 1; @@ -905,7 +909,7 @@ void S_check_heap(aftergc, mcg) IBOOL aftergc; IGEN mcg; { /* 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` */ + checked dirty bytes already 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; @@ -945,7 +949,7 @@ void S_check_heap(aftergc, mcg) IBOOL aftergc; IGEN mcg; { found_eos = 1; pp1 = pp2; break; - } else if (!IMMEDIATE(p)) { + } else if (!FIXMEDIATE(p)) { seginfo *psi = MaybeSegInfo(ptr_get_segment(p)); if ((psi != NULL) && ((pg = psi->generation) < g)) { if (pg < dirty) dirty = pg; diff --git a/src/ChezScheme/c/number.c b/src/ChezScheme/c/number.c index e2f5196bb2..6b37d7cbbb 100644 --- a/src/ChezScheme/c/number.c +++ b/src/ChezScheme/c/number.c @@ -36,7 +36,7 @@ static ptr big_mul PROTO((ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL sign)); static void big_short_trunc PROTO((ptr tc, ptr x, bigit s, iptr xl, IBOOL qs, IBOOL rs, ptr *q, ptr *r)); static void big_trunc PROTO((ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL qs, IBOOL rs, ptr *q, ptr *r)); static INT normalize PROTO((bigit *xp, bigit *yp, iptr xl, iptr yl)); -static bigit quotient_digit PROTO((bigit *xp, bigit *yp, iptr yl)); +static bigit quotient_digit PROTO((ptr tc, bigit *xp, bigit *yp, iptr yl)); static bigit qhat PROTO((bigit *xp, bigit *yp)); static ptr big_short_gcd PROTO((ptr tc, ptr x, bigit y, iptr xl)); static ptr big_gcd PROTO((ptr tc, ptr x, ptr y, iptr xl, iptr yl)); @@ -636,6 +636,9 @@ static ptr big_mul(tc, x, y, xl, yl, sign) ptr tc, x, y; iptr xl, yl; IBOOL sign PREPARE_BIGNUM(tc, W(tc),xl+yl) for (xi = xl, zp = &BIGIT(W(tc),xl+yl-1); xi-- > 0; ) *zp-- = 0; + /* account for nested loop: */ + USE_TRAP_FUEL(tc, xl * yl); + for (yi=yl,yp= &BIGIT(y,yl-1),zp= &BIGIT(W(tc),xl+yl-1); yi-- > 0; yp--, zp--) if (*yp == 0) *(zp-xl) = 0; @@ -796,11 +799,11 @@ static void big_trunc(tc, x, y, xl, yl, qs, rs, q, r) d = normalize(xp, yp, xl, yl); if (q == (ptr *)NULL) { - for (i = m; i-- > 0 ; xp++) (void) quotient_digit(xp, yp, yl); + for (i = m; i-- > 0 ; xp++) (void) quotient_digit(tc, xp, yp, yl); } else { PREPARE_BIGNUM(tc, W(tc),m) p = &BIGIT(W(tc),0); - for (i = m; i-- > 0 ; xp++) *p++ = quotient_digit(xp, yp, yl); + for (i = m; i-- > 0 ; xp++) *p++ = quotient_digit(tc, xp, yp, yl); *q = copy_normalize(tc, &BIGIT(W(tc),0),m,qs); } @@ -829,10 +832,13 @@ static INT normalize(xp, yp, xl, yl) bigit *xp, *yp; iptr xl, yl; { return shft; } -static bigit quotient_digit(xp, yp, yl) bigit *xp, *yp; iptr yl; { +static bigit quotient_digit(tc, xp, yp, yl) ptr tc; bigit *xp, *yp; iptr yl; { bigit *p1, *p2, q, k, b, prod; iptr i; + /* this function is called in loops, so use fuel every time */ + USE_TRAP_FUEL(tc, yl); + q = qhat(xp, yp); for (i = yl, p1 = xp+yl, p2 = yp+yl-1, k = 0, b = 0; i-- > 0; p1--, p2--) { @@ -934,6 +940,9 @@ static ptr big_gcd(tc, x, y, xl, yl) ptr tc, x, y; iptr xl, yl; { if (asc+shft >= bigit_bits) shft -= bigit_bits; asc += shft; + /* account for nested loops: */ + USE_TRAP_FUEL(tc, xl + yl); + /* shift left or right; adjust lengths, xp and yp */ if (shft < 0) { /* shift right */ for (i = yl--, p = yp++, k = 0; i-- > 0; p++) ERSH(-shft,p,&k) @@ -948,7 +957,7 @@ static ptr big_gcd(tc, x, y, xl, yl) ptr tc, x, y; iptr xl, yl; { } /* destructive remainder x = x rem y */ - for (i = xl-yl+1; i-- > 0; xp++) (void) quotient_digit(xp, yp, yl); + for (i = xl-yl+1; i-- > 0; xp++) (void) quotient_digit(tc, xp, yp, yl); /* strip leading zero bigits. remainder is at most yl bigits long */ for (i = yl ; *xp == 0 && i > 0; xp++, i--); @@ -1121,7 +1130,7 @@ static double big_floatify(tc, x, y, xl, yl, sign) ptr tc, x, y; iptr xl, yl; IB p = &BIGIT(W(tc),0); /* compute 'enough' bigits of the quotient */ - for (i = enough; i-- > 0; xp++) *p++ = quotient_digit(xp, yp, yl); + for (i = enough; i-- > 0; xp++) *p++ = quotient_digit(tc, xp, yp, yl); /* set k if remainder is nonzero */ k = 0; @@ -1313,8 +1322,10 @@ static ptr s_big_ash(tc, xp, xl, sign, cnt) ptr tc; bigit *xp; iptr xl; IBOOL si if ((xl -= (whole_bigits = (cnt = -cnt) / bigit_bits)) <= 0) return sign ? FIX(-1) : FIX(0); cnt -= whole_bigits * bigit_bits; - /* shift by remaining count to scratch bignum, tracking bits shifted off to the right */ - PREPARE_BIGNUM(tc, W(tc),xl) + /* shift by remaining count to scratch bignum, tracking bits shifted off to the right; + prepare a bignum one large than probably needed, in case we have to deal with a + carry bit when rounding down for a negative number */ + PREPARE_BIGNUM(tc, W(tc),xl+1) p1 = &BIGIT(W(tc), 0); p2 = xp; k = 0; @@ -1344,6 +1355,13 @@ static ptr s_big_ash(tc, xp, xl, sign, cnt) ptr tc; bigit *xp; iptr xl; IBOOL si p1 = &BIGIT(W(tc), xl - 1); for (i = xl, k = 1; k != 0 && i-- > 0; p1 -= 1) EADDC(0, *p1, p1, &k) + if (k) { + /* add carry bit back; we prepared a large enough bignum, + and since of all the middle are zero, we don't have to reshift */ + BIGIT(W(tc), xl) = 0; + BIGIT(W(tc), 0) = 1; + xl++; + } } } @@ -1472,6 +1490,23 @@ ptr S_big_positive_bit_field(ptr x, ptr fxstart, ptr fxend) { return copy_normalize(tc, &BIGIT(W(tc), 0), wl, 0); } +/* returns a lower bound on the number of trailing 0 bits in the + binary representation: */ +ptr S_big_trailing_zero_bits(ptr x) { + bigit *xp = &BIGIT(x, 0); + iptr xl = BIGLEN(x), i; + + for (i = xl; i-- > 0; ) { + if (xp[i] != 0) + break; + } + + i = (xl - 1) - i; + i *= bigit_bits; + + return FIX(i); +} + /* logical operations simulate two's complement operations using the following general strategy: diff --git a/src/ChezScheme/c/pb.c b/src/ChezScheme/c/pb.c index b522b80ffa..204a69d0dd 100644 --- a/src/ChezScheme/c/pb.c +++ b/src/ChezScheme/c/pb.c @@ -91,6 +91,23 @@ void S_pb_interp(ptr tc, void *bytecode) { next_ip = ip + 1; switch(INSTR_op(instr)) { + case pb_link: + /* same as pb_mov16_pb_zero_bits_pb_shift0, but with a promise + of collowing pb_mov16_pb_keep_bits_pb_shift1... with the same + destination */ + regs[INSTR_di_dest(instr)] = ((uptr)INSTR_di_imm_unsigned(instr) + | ((uptr)INSTR_di_imm_unsigned(ip[1]) << 16) +#if ptr_bits == 64 + | ((uptr)INSTR_di_imm_unsigned(ip[2]) << 32) + | ((uptr)INSTR_di_imm_unsigned(ip[3]) << 48) +#endif + ); +#if ptr_bits == 64 + next_ip = ip + 4; +#else + next_ip = ip + 2; +#endif + break; case pb_mov16_pb_zero_bits_pb_shift0: regs[INSTR_di_dest(instr)] = (uptr)INSTR_di_imm_unsigned(instr); break; diff --git a/src/ChezScheme/c/prim.c b/src/ChezScheme/c/prim.c index c2194edc97..45812e1f26 100644 --- a/src/ChezScheme/c/prim.c +++ b/src/ChezScheme/c/prim.c @@ -228,7 +228,7 @@ 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(); + S_thread_start_code_write(tc, 0, 0, NULL, 0); new = S_code(tc, CODETYPE(old), CODELEN(old)); @@ -280,15 +280,16 @@ static void s_instantiate_code_object() { } S_flush_instruction_cache(tc); - S_thread_end_code_write(); + S_thread_end_code_write(tc, 0, 0, NULL, 0); AC0(tc) = new; } static void s_link_code_object(co, objs) ptr co, objs; { - ptr t; uptr a, m, n; + ptr t, tc = get_thread_context(); + uptr a, m, n; - S_thread_start_code_write(); + S_thread_start_code_write(tc, 0, 0, NULL, 0); t = CODERELOC(co); m = RELOCSIZE(t); a = 0; @@ -307,7 +308,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(); + S_thread_end_code_write(tc, 0, 0, NULL, 0); } static INT s_check_heap_enabledp(void) { diff --git a/src/ChezScheme/c/prim5.c b/src/ChezScheme/c/prim5.c index 5d1566aef0..bde80442ce 100644 --- a/src/ChezScheme/c/prim5.c +++ b/src/ChezScheme/c/prim5.c @@ -21,7 +21,6 @@ #include <sys/stat.h> #include <limits.h> #include <ctype.h> -#include <time.h> /* locally defined functions */ static INT s_errno PROTO((void)); @@ -38,6 +37,11 @@ static ptr s_ephemeron_pairp PROTO((ptr p)); static ptr s_box_immobile PROTO((ptr p)); static ptr s_make_immobile_vector PROTO((uptr len, ptr fill)); static ptr s_make_immobile_bytevector PROTO((uptr len)); +static ptr s_make_reference_bytevector PROTO((uptr len)); +static ptr s_make_immobile_reference_bytevector PROTO((uptr len)); +static ptr s_reference_bytevectorp PROTO((ptr p)); +static ptr s_reference_star_address_object PROTO((ptr p)); +static ptr s_bytevector_reference_star_ref PROTO((ptr p, uptr offset)); static ptr s_oblist PROTO((void)); static ptr s_bigoddp PROTO((ptr n)); static ptr s_float PROTO((ptr x)); @@ -211,7 +215,7 @@ static ptr s_box_immobile(p) ptr p; { } static ptr s_make_immobile_bytevector(uptr len) { - ptr b = S_bytevector2(get_thread_context(), len, 1); + ptr b = S_bytevector2(get_thread_context(), len, space_immobile_data); S_immobilize_object(b); return b; } @@ -236,6 +240,36 @@ static ptr s_make_immobile_vector(uptr len, ptr fill) { return v; } +static ptr s_make_reference_bytevector(uptr len) { + ptr b = S_bytevector2(get_thread_context(), len, space_reference_array); + memset(&BVIT(b, 0), 0, len); + return b; +} + +static ptr s_make_immobile_reference_bytevector(uptr len) { + ptr b = s_make_reference_bytevector(len); + S_immobilize_object(b); + return b; +} + +static ptr s_reference_bytevectorp(p) ptr p; { + seginfo *si; + return (si = MaybeSegInfo(ptr_get_segment(p))) != NULL && si->space == space_reference_array ? Strue : Sfalse; +} + +static ptr s_reference_star_address_object(ptr p) { + if (p == (ptr)0) + return Sfalse; + else if (MaybeSegInfo(addr_get_segment(p))) + return (ptr)((uptr)p - reference_disp); + else + return Sunsigned((uptr)p); +} + +static ptr s_bytevector_reference_star_ref(ptr p, uptr offset) { + return s_reference_star_address_object(*(ptr *)&BVIT(p, offset)); +} + static ptr s_oblist() { ptr ls = Snil; iptr idx = S_G.oblist_length; @@ -877,53 +911,58 @@ static char *s_getwd() { static ptr s_set_code_byte(p, n, x) ptr p, n, x; { I8 *a; + ptr tc = get_thread_context(); - S_thread_start_code_write(); a = (I8 *)TO_VOIDP((uptr)p + UNFIX(n)); + S_thread_start_code_write(tc, 0, 0, TO_VOIDP(a), sizeof(I8)); *a = (I8)UNFIX(x); - S_thread_end_code_write(); + S_thread_end_code_write(tc, 0, 0, TO_VOIDP(a), sizeof(I8)); return Svoid; } static ptr s_set_code_word(p, n, x) ptr p, n, x; { I16 *a; + ptr tc = get_thread_context(); - S_thread_start_code_write(); a = (I16 *)TO_VOIDP((uptr)p + UNFIX(n)); + S_thread_start_code_write(tc, 0, 0, TO_VOIDP(a), sizeof(I16)); *a = (I16)UNFIX(x); - S_thread_end_code_write(); + S_thread_end_code_write(tc, 0, 0, TO_VOIDP(a), sizeof(I16)); return Svoid; } static ptr s_set_code_long(p, n, x) ptr p, n, x; { I32 *a; + ptr tc = get_thread_context(); - S_thread_start_code_write(); a = (I32 *)TO_VOIDP((uptr)p + UNFIX(n)); + S_thread_start_code_write(tc, 0, 0, TO_VOIDP(a), sizeof(I32)); *a = (I32)(Sfixnump(x) ? UNFIX(x) : Sinteger_value(x)); - S_thread_end_code_write(); + S_thread_end_code_write(tc, 0, 0, TO_VOIDP(a), sizeof(I32)); return Svoid; } static void s_set_code_long2(p, n, h, l) ptr p, n, h, l; { I32 *a; + ptr tc = get_thread_context(); - S_thread_start_code_write(); a = (I32 *)TO_VOIDP((uptr)p + UNFIX(n)); + S_thread_start_code_write(tc, 0, 0, TO_VOIDP(a), sizeof(I32)); *a = (I32)((UNFIX(h) << 16) + UNFIX(l)); - S_thread_end_code_write(); + S_thread_end_code_write(tc, 0, 0, TO_VOIDP(a), sizeof(I32)); } static ptr s_set_code_quad(p, n, x) ptr p, n, x; { I64 *a; + ptr tc = get_thread_context(); - S_thread_start_code_write(); a = (I64 *)TO_VOIDP((uptr)p + UNFIX(n)); + S_thread_start_code_write(tc, 0, 0, TO_VOIDP(a), sizeof(I64)); *a = Sfixnump(x) ? UNFIX(x) : S_int64_value("\\#set-code-quad!", x); - S_thread_end_code_write(); + S_thread_end_code_write(tc, 0, 0, TO_VOIDP(a), sizeof(I64)); return Svoid; } @@ -931,10 +970,8 @@ static ptr s_set_code_quad(p, n, x) ptr p, n, x; { 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; } @@ -947,10 +984,11 @@ static ptr s_flush_instruction_cache() { 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; + ptr tc = get_thread_context(); - S_thread_start_code_write(); + S_thread_start_code_write(tc, 0, 0, NULL, 0); - co = S_code(get_thread_context(), type_code | (flags << code_flags_offset), n); + co = S_code(tc, type_code | (flags << code_flags_offset), n); CODEFREE(co) = free; CODENAME(co) = name; CODEARITYMASK(co) = arity_mark; @@ -960,16 +998,18 @@ static ptr s_make_code(flags, free, name, arity_mark, n, info, pinfos) S_G.profile_counters = Scons(S_weak_cons(co, pinfos), S_G.profile_counters); } - S_thread_end_code_write(); + S_thread_end_code_write(tc, 0, 0, NULL, 0); return co; } static ptr s_make_reloc_table(codeobj, n) ptr codeobj, n; { - S_thread_start_code_write(); + ptr tc = get_thread_context(); + + S_thread_start_code_write(tc, 0, 0, TO_VOIDP(&CODERELOC(codeobj)), sizeof(ptr)); CODERELOC(codeobj) = S_relocation_table(UNFIX(n)); RELOCCODE(CODERELOC(codeobj)) = codeobj; - S_thread_end_code_write(); + S_thread_end_code_write(tc, 0, 0, TO_VOIDP(&CODERELOC(codeobj)), sizeof(ptr)); return Svoid; } @@ -1330,8 +1370,8 @@ static ptr s_set_collect_trip_bytes(n) ptr n; { return Svoid; } -static void c_exit(UNUSED I32 status) { - S_abnormal_exit(); +static void c_exit(I32 status) { + exit(status); } #if defined(__STDC__) || defined(USE_ANSI_PROTOTYPES) @@ -1655,6 +1695,11 @@ void S_prim5_init() { Sforeign_symbol("(cs)box_immobile", (void *)s_box_immobile); Sforeign_symbol("(cs)make_immobile_vector", (void *)s_make_immobile_vector); Sforeign_symbol("(cs)make_immobile_bytevector", (void *)s_make_immobile_bytevector); + Sforeign_symbol("(cs)s_make_reference_bytevector", (void *)s_make_reference_bytevector); + Sforeign_symbol("(cs)s_make_immobile_reference_bytevector", (void *)s_make_immobile_reference_bytevector); + Sforeign_symbol("(cs)s_reference_bytevectorp", (void *)s_reference_bytevectorp); + Sforeign_symbol("(cs)s_reference_star_address_object", (void *)s_reference_star_address_object); + Sforeign_symbol("(cs)s_bytevector_reference_star_ref", (void *)s_bytevector_reference_star_ref); Sforeign_symbol("(cs)continuation_depth", (void *)S_continuation_depth); Sforeign_symbol("(cs)single_continuation", (void *)S_single_continuation); Sforeign_symbol("(cs)c_exit", (void *)c_exit); @@ -1756,6 +1801,7 @@ void S_prim5_init() { Sforeign_symbol("(cs)s_big_positive_bit_field", (void *)S_big_positive_bit_field); Sforeign_symbol("(cs)s_big_eq", (void *)S_big_eq); Sforeign_symbol("(cs)s_big_lt", (void *)S_big_lt); + Sforeign_symbol("(cs)s_big_trailing_zero_bits", (void *)S_big_trailing_zero_bits); Sforeign_symbol("(cs)s_bigoddp", (void *)s_bigoddp); Sforeign_symbol("(cs)s_div", (void *)S_div); Sforeign_symbol("(cs)s_float", (void *)s_float); @@ -1773,6 +1819,7 @@ void S_prim5_init() { Sforeign_symbol("(cs)s_set_random_seed", (void *)s_set_random_seed); Sforeign_symbol("(cs)ss_trunc", (void *)S_trunc); Sforeign_symbol("(cs)ss_trunc_rem", (void *)s_trunc_rem); + Sforeign_symbol("(cs)s_rational", (void *)S_rational); Sforeign_symbol("(cs)sub", (void *)S_sub); Sforeign_symbol("(cs)rem", (void *)S_rem); #ifdef GETWD @@ -2079,7 +2126,12 @@ static void s_free(uptr addr) { } #ifdef FEATURE_ICONV -#ifdef WIN32 +#ifdef DISABLE_ICONV +# define iconv_t int +#define ICONV_OPEN(to, from) -1 +#define ICONV(cd, in, inb, out, outb) -1 +#define ICONV_CLOSE(cd) -1 +#elif defined(WIN32) typedef void *iconv_t; typedef iconv_t (*iconv_open_ft)(const char *tocode, const char *fromcode); typedef size_t (*iconv_ft)(iconv_t cd, char **inbuf, size_t *inbytesleft, char **outbuf, size_t *outbytesleft); diff --git a/src/ChezScheme/c/scheme.c b/src/ChezScheme/c/scheme.c index 196916cdfc..7d19623912 100644 --- a/src/ChezScheme/c/scheme.c +++ b/src/ChezScheme/c/scheme.c @@ -20,7 +20,6 @@ #include <limits.h> #ifdef WIN32 #include <io.h> -#include <time.h> #else #include <sys/time.h> #endif @@ -109,7 +108,7 @@ static void main_init() { VIRTREG(tc, i) = FIX(0); } - S_thread_start_code_write(); + S_thread_start_code_write(tc, 0, 0, NULL, 0); p = S_code(tc, type_code, size_rp_header); CODERELOC(p) = S_relocation_table(0); CODENAME(p) = Sfalse; @@ -123,7 +122,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_thread_end_code_write(tc, 0, 0, NULL, 0); S_protect(&S_G.error_invoke_code_object); S_G.error_invoke_code_object = Snil; @@ -274,6 +273,14 @@ static void idiot_checks() { fprintf(stderr, "sizeof(string_char) [%ld] != string_char_bytes [%d]\n", (long)sizeof(string_char), string_char_bytes); oops = 1; } + if (TYPE((ptr)0, type_untyped) != (ptr)0) { + fprintf(stderr, "tagging with type_untyped changes an address\n"); + oops = 1; + } + if (record_ptr_offset != record_type_disp) { + fprintf(stderr, "record_ptr_offset != record_type_disp\n"); + oops = 1; + } if (UNFIX(fixtest) != -1) { fprintf(stderr, "UNFIX operation failed\n"); oops = 1; @@ -332,7 +339,24 @@ static void idiot_checks() { /* parallel GC relies on not confusing a forward marker with code flags */ fprintf(stderr, "code flags overlap with forwadr_marker\n"); oops = 1; - } + } + + if ((reference_disp != bytevector_data_disp) + || (reference_disp != flvector_data_disp)) { + fprintf(stderr, "reference displacement does not match bytevector or flvector displacement\n"); + oops = 1; + } + + if (reference_disp >= (allocation_segment_tail_padding + /* to determine the minimum distince from the start of an + alocated object to the end of its alloted space, take the + smaller of the allocation alignment or sizeof(double), where + the latter is relevant for a flonum that points into the + imaginary half of an inexactnum */ + + ((byte_alignment < sizeof(double)) ? byte_alignment : sizeof(double)))) { + fprintf(stderr, "reference displacement can extend past the end of an allocation page\n"); + oops = 1; + } if (oops) S_abnormal_exit(); } diff --git a/src/ChezScheme/c/scheme.rc b/src/ChezScheme/c/scheme.rc index 9f63ef0133..fd36598626 100644 --- a/src/ChezScheme/c/scheme.rc +++ b/src/ChezScheme/c/scheme.rc @@ -1,8 +1,8 @@ #include "winver.h" VS_VERSION_INFO VERSIONINFO - FILEVERSION 9,5,3,0 - PRODUCTVERSION 9,5,3,0 + FILEVERSION 9,5,5,0 + PRODUCTVERSION 9,5,5,0 FILEFLAGSMASK 0x3fL FILEFLAGS 0x0L FILEOS VOS__WINDOWS32 @@ -12,13 +12,13 @@ VS_VERSION_INFO VERSIONINFO BLOCK "StringFileInfo" { BLOCK "04090000" { VALUE "CompanyName", "Cisco Systems, Inc." - VALUE "FileDescription", "Chez Scheme Version 9.5.3" - VALUE "FileVersion", "9.5.3" + VALUE "FileDescription", "Chez Scheme Version 9.5.5" + VALUE "FileVersion", "9.5.5" VALUE "InternalName", "scheme.exe" - VALUE "LegalCopyright", "Copyright 1984-2019 Cisco Systems, Inc. Licensed under the Apache License, Version 2.0." + VALUE "LegalCopyright", "Copyright 1984-2020 Cisco Systems, Inc. Licensed under the Apache License, Version 2.0." VALUE "OriginalFilename", "scheme.exe" VALUE "ProductName", "Chez Scheme" - VALUE "ProductVersion", "9.5.3" + VALUE "ProductVersion", "9.5.5" } } BLOCK "VarFileInfo" { diff --git a/src/ChezScheme/c/schlib.c b/src/ChezScheme/c/schlib.c index 243e1f6233..127361edc8 100644 --- a/src/ChezScheme/c/schlib.c +++ b/src/ChezScheme/c/schlib.c @@ -216,7 +216,7 @@ void S_call_help(tc_in, singlep, lock_ts) ptr tc_in; IBOOL singlep; IBOOL lock_t the C stack and we may end up in a garbage collection */ code = CP(tc); if (Sprocedurep(code)) code = CLOSCODE(code); - if (!IMMEDIATE(code) && !Scodep(code)) + if (!FIXMEDIATE(code) && !Scodep(code)) S_error_abort("S_call_help: invalid code pointer"); S_immobilize_object(code); diff --git a/src/ChezScheme/c/schsig.c b/src/ChezScheme/c/schsig.c index 5715f3ada0..d0aee16dc5 100644 --- a/src/ChezScheme/c/schsig.c +++ b/src/ChezScheme/c/schsig.c @@ -25,6 +25,8 @@ static void handle_call_error PROTO((ptr tc, iptr type, ptr x)); static void init_signal_handlers PROTO((void)); static void keyboard_interrupt PROTO((ptr tc)); +static void (*register_modified_signal)(int); + ptr S_get_scheme_arg(tc, n) ptr tc; iptr n; { if (n <= asm_arg_reg_cnt) return REGARG(tc, n); @@ -392,8 +394,8 @@ static void do_error(type, who, s, args) iptr type; const char *who, *s; ptr arg #endif /* PTHREADS */ /* in case error is during fasl read: */ - S_thread_end_code_write(); - + S_thread_end_code_write(tc, static_generation, 0, NULL, 0); + TRAP(tc) = (ptr)1; AC0(tc) = (ptr)1; CP(tc) = S_symbol_value(S_G.error_id); @@ -533,6 +535,10 @@ void S_noncontinuable_interrupt() { do_error(ERROR_NONCONTINUABLE_INTERRUPT,"","",Snil); } +void Sscheme_register_signal_registerer(void (*registerer)(int)) { + register_modified_signal = registerer; +} + #ifdef WIN32 ptr S_dequeue_scheme_signals(UNUSED ptr tc) { return Snil; @@ -726,20 +732,28 @@ static void handle_signal(INT sig, UNUSED siginfo_t *si, UNUSED void *data) { } } +static void no_op_register(UNUSED int sigid) { +} + +#define SIGACTION(id, act_p, old_p) (register_modified_signal(id), sigaction(id, act_p, old_p)) + static void init_signal_handlers() { struct sigaction act; + if (register_modified_signal == NULL) + register_modified_signal = no_op_register; + sigemptyset(&act.sa_mask); /* drop pending keyboard interrupts */ act.sa_flags = 0; act.sa_handler = SIG_IGN; - sigaction(SIGINT, &act, (struct sigaction *)0); + SIGACTION(SIGINT, &act, (struct sigaction *)0); /* ignore broken pipe signals */ act.sa_flags = 0; act.sa_handler = SIG_IGN; - sigaction(SIGPIPE, &act, (struct sigaction *)0); + SIGACTION(SIGPIPE, &act, (struct sigaction *)0); /* set up to catch SIGINT w/no system call restart */ #ifdef SA_INTERRUPT @@ -748,7 +762,7 @@ static void init_signal_handlers() { act.sa_flags = SA_SIGINFO; #endif /* SA_INTERRUPT */ act.sa_sigaction = handle_signal; - sigaction(SIGINT, &act, (struct sigaction *)0); + SIGACTION(SIGINT, &act, (struct sigaction *)0); #ifdef BSDI siginterrupt(SIGINT, 1); #endif @@ -760,14 +774,14 @@ static void init_signal_handlers() { act.sa_flags |= SA_RESTART; #endif /* SA_RESTART */ #ifdef SIGQUIT - sigaction(SIGQUIT, &act, (struct sigaction *)0); + SIGACTION(SIGQUIT, &act, (struct sigaction *)0); #endif /* SIGQUIT */ - sigaction(SIGILL, &act, (struct sigaction *)0); - sigaction(SIGFPE, &act, (struct sigaction *)0); + SIGACTION(SIGILL, &act, (struct sigaction *)0); + SIGACTION(SIGFPE, &act, (struct sigaction *)0); #ifdef SIGBUS - sigaction(SIGBUS, &act, (struct sigaction *)0); + SIGACTION(SIGBUS, &act, (struct sigaction *)0); #endif /* SIGBUS */ - sigaction(SIGSEGV, &act, (struct sigaction *)0); + SIGACTION(SIGSEGV, &act, (struct sigaction *)0); } #endif /* WIN32 */ @@ -775,6 +789,7 @@ static void init_signal_handlers() { void S_schsig_init() { if (S_boot_time) { ptr p; + ptr tc = get_thread_context(); S_protect(&S_G.nuate_id); S_G.nuate_id = S_intern((const unsigned char *)"$nuate"); @@ -786,15 +801,15 @@ 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); + S_thread_start_code_write(tc, 0, 0, NULL, 0); + p = S_code(tc, type_code | (code_flag_continuation << code_flags_offset), 0); CODERELOC(p) = S_relocation_table(0); CODENAME(p) = Sfalse; CODEARITYMASK(p) = FIX(0); CODEFREE(p) = 0; CODEINFO(p) = Sfalse; CODEPINFOS(p) = Snil; - S_thread_end_code_write(); + S_thread_end_code_write(tc, 0, 0, NULL, 0); S_set_symbol_value(S_G.null_continuation_id, S_mkcontinuation(space_new, diff --git a/src/ChezScheme/c/segment.c b/src/ChezScheme/c/segment.c index fbec515adc..5f4608dbd5 100644 --- a/src/ChezScheme/c/segment.c +++ b/src/ChezScheme/c/segment.c @@ -45,6 +45,10 @@ static void add_to_chunk_list PROTO((chunkinfo *chunk, chunkinfo **pchunk_list)) static seginfo *sort_seginfo PROTO((seginfo *si, uptr n)); static seginfo *merge_seginfo PROTO((seginfo *si1, seginfo *si2)); +#if defined(WRITE_XOR_EXECUTE_CODE) +static void enable_code_write PROTO((ptr tc, IGEN maxg, IBOOL on, IBOOL current, void *hint, uptr hint_len)); +#endif + void S_segment_init() { IGEN g; ISPC s; int i; @@ -82,33 +86,42 @@ static void out_of_memory(void) { S_abnormal_exit(); } +#if defined(USE_MMAP) +static int for_code_succeeded = 0; +static void w_and_x_problem(void) { + (void) fprintf(stderr, + "allocation failed for code; maybe write+execute permission is not allowed\n"); + S_abnormal_exit(); +} +#endif + #if defined(USE_MALLOC) void *S_getmem(iptr bytes, IBOOL zerofill, UNUSED IBOOL for_code) { void *addr; if ((addr = malloc(bytes)) == (void *)0) out_of_memory(); - debug(printf("getmem(%p) -> %p\n", bytes, addr)) + debug(printf("getmem(%p) -> %p\n", TO_VOIDP(bytes), addr)) if ((membytes += bytes) > maxmembytes) maxmembytes = membytes; if (zerofill) memset(addr, 0, bytes); return addr; } void S_freemem(void *addr, iptr bytes) { - debug(printf("freemem(%p, %p)\n", addr, bytes)) + debug(printf("freemem(%p, %p)\n", addr, TO_VOIDP(bytes))) free(addr); membytes -= bytes; } #endif #if defined(USE_VIRTUAL_ALLOC) -#include <WinBase.h> +#include <winbase.h> void *S_getmem(iptr bytes, IBOOL zerofill, IBOOL for_code) { void *addr; if ((uptr)bytes < S_pagesize) { if ((addr = malloc(bytes)) == (void *)0) out_of_memory(); - debug(printf("getmem malloc(%p) -> %p\n", bytes, addr)) + debug(printf("getmem malloc(%p) -> %p\n", TO_VOIDP(bytes), addr)) if ((membytes += bytes) > maxmembytes) maxmembytes = membytes; if (zerofill) memset(addr, 0, bytes); } else { @@ -116,7 +129,7 @@ void *S_getmem(iptr bytes, IBOOL zerofill, IBOOL for_code) { 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)) + debug(printf("getmem VirtualAlloc(%p => %p) -> %p\n", TO_VOIDP(bytes), TO_VOIDP(p_bytes), addr)) } return addr; @@ -146,7 +159,7 @@ void *S_getmem(iptr bytes, IBOOL zerofill, IBOOL for_code) { if ((uptr)bytes < S_pagesize) { if ((addr = malloc(bytes)) == (void *)0) out_of_memory(); - debug(printf("getmem malloc(%p) -> %p\n", bytes, addr)) + debug(printf("getmem malloc(%p) -> %p\n", TO_VOIDP(bytes), addr)) if ((membytes += bytes) > maxmembytes) maxmembytes = membytes; if (zerofill) memset(addr, 0, bytes); } else { @@ -159,14 +172,17 @@ void *S_getmem(iptr bytes, IBOOL zerofill, IBOOL for_code) { if ((addr = mmap(NULL, p_bytes, perm, flags|MAP_32BIT, -1, 0)) == (void *)-1) { #endif if ((addr = mmap(NULL, p_bytes, perm, flags, -1, 0)) == (void *)-1) { + if (for_code && !for_code_succeeded) + w_and_x_problem(); out_of_memory(); - debug(printf("getmem mmap(%p) -> %p\n", bytes, addr)) + debug(printf("getmem mmap(%p) -> %p\n", TO_VOIDP(bytes), addr)) } #ifdef MAP_32BIT } #endif + if (for_code) for_code_succeeded = 1; if ((membytes += p_bytes) > maxmembytes) maxmembytes = membytes; - debug(printf("getmem mmap(%p => %p) -> %p\n", bytes, p_bytes, addr)) + debug(printf("getmem mmap(%p => %p) -> %p\n", TO_VOIDP(bytes), TO_VOIDP(p_bytes), addr)) } return addr; @@ -174,12 +190,12 @@ void *S_getmem(iptr bytes, IBOOL zerofill, IBOOL for_code) { void S_freemem(void *addr, iptr bytes) { if ((uptr)bytes < S_pagesize) { - debug(printf("freemem free(%p, %p)\n", addr, bytes)) + debug(printf("freemem free(%p, %p)\n", addr, TO_VOIDP(bytes))) free(addr); membytes -= bytes; } else { uptr n = S_pagesize - 1; iptr p_bytes = (iptr)(((uptr)bytes + n) & ~n); - debug(printf("freemem munmap(%p, %p => %p)\n", addr, bytes, p_bytes)) + debug(printf("freemem munmap(%p, %p => %p)\n", addr, TO_VOIDP(bytes), TO_VOIDP(p_bytes))) munmap(addr, p_bytes); membytes -= p_bytes; } @@ -261,6 +277,9 @@ static void initialize_seginfo(seginfo *si, NO_THREADS_UNUSED thread_gc *creator si->counting_mask = NULL; si->measured_mask = NULL; si->sweep_next = NULL; +#if defined(WRITE_XOR_EXECUTE_CODE) + si->sweep_bytes = 0; +#endif } /* allocation mutex must be held */ @@ -273,7 +292,7 @@ iptr S_find_segments(creator, s, g, n) thread_gc *creator; ISPC s; IGEN g; iptr 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)) + debug(printf("attempting to find %ld segments for space %d, generation %d\n", n, s, g)) chunks = (for_code ? S_code_chunks : S_chunks); @@ -568,18 +587,154 @@ static void contract_segment_table(uptr base, uptr end) { 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 + 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. */ + executable pages. However, on platforms where W^X is enforced + (eg. iOS), we provide a best-effort implementation that flips pages + between W and X for the minimal set of segments possible (depending + on the context) in an effort to minimize the chances of a page + being flipped while a thread is executing code off of it. +*/ -void S_thread_start_code_write(void) { +void S_thread_start_code_write(WX_UNUSED ptr tc, WX_UNUSED IGEN maxg, WX_UNUSED IBOOL current, + WX_UNUSED void *hint, WX_UNUSED uptr hint_len) { +#if defined(WRITE_XOR_EXECUTE_CODE) + enable_code_write(tc, maxg, 1, current, hint, hint_len); +#else S_ENABLE_CODE_WRITE(1); +#endif } -void S_thread_end_code_write(void) { +void S_thread_end_code_write(WX_UNUSED ptr tc, WX_UNUSED IGEN maxg, WX_UNUSED IBOOL current, + WX_UNUSED void *hint, WX_UNUSED uptr hint_len) { +#if defined(WRITE_XOR_EXECUTE_CODE) + enable_code_write(tc, maxg, 0, current, hint, hint_len); +#else S_ENABLE_CODE_WRITE(0); +#endif +} + +#if defined(WRITE_XOR_EXECUTE_CODE) +# if defined(PTHREADS) +static IBOOL is_unused_seg(chunkinfo *chunk, seginfo *si) { + uptr number; + if (si->creator == NULL) { + /* If the seginfo doesn't have a creator, then it's unused so we + can skip the search. */ + return 1; + } + number = si->number; + si = chunk->unused_segs; + while (si != NULL) { + if (si->number == number) { + return 1; + } + si = si->next; + } + return 0; +} +# endif + +static void enable_code_write(ptr tc, IGEN maxg, IBOOL on, IBOOL current, void *hint, uptr hint_len) { + thread_gc *tgc; + chunkinfo *chunk; + seginfo *sip; + iptr i, bytes; + void *addr; + INT flags = (on ? PROT_WRITE : PROT_EXEC) | PROT_READ; + + /* Flip only the segment hinted at by the caller. */ + if (maxg == 0 && hint != NULL) { + uptr seg, start_seg, end_seg; + start_seg = addr_get_segment(TO_PTR(hint)); + end_seg = addr_get_segment((uptr)TO_PTR(hint) + hint_len - 1); + for (seg = start_seg; seg <= end_seg; seg++) { + addr = TO_VOIDP(build_ptr(seg, 0)); + if (mprotect(addr, bytes_per_segment, flags) != 0) { + S_error_abort("bad hint to enable_code_write"); + } + } + return; + } + + /* Flip only the current allocation segments. */ + tgc = THREAD_GC(tc); + if (maxg == 0 && current) { + addr = TO_VOIDP(tgc->base_loc[0][space_code]); + if (addr == NULL) { + return; + } + bytes = ((char*)tgc->next_loc[0][space_code] - (char*)tgc->base_loc[0][space_code] + + tgc->bytes_left[0][space_code] + allocation_segment_tail_padding); + if (mprotect(addr, bytes, flags) != 0) { + S_error_abort("failed to protect current allocation segments"); + } + /* If disabling writes, turn on exec for recently-allocated + segments in addition to the current segments. Clears the + current sweep_next chain so must not be used durring + collection. */ + if (!on) { + while ((sip = tgc->sweep_next[0][space_code]) != NULL) { + tgc->sweep_next[0][space_code] = sip->sweep_next; + addr = TO_VOIDP(sip->sweep_start); + bytes = sip->sweep_bytes; + if (mprotect(addr, bytes, flags) != 0) { + S_error_abort("failed to protect recent allocation segments"); + } + } + } + return; + } + + for (i = 0; i <= PARTIAL_CHUNK_POOLS; i++) { + chunk = S_code_chunks[i]; + while (chunk != NULL) { + addr = chunk->addr; +# if defined(PTHREADS) + bytes = 0; + if (chunk->nused_segs == 0) { + /* None of the segments in the chunk are used so flip the bits + for all of them in one go. */ + bytes = chunk->bytes; + } else { + /* Flip bits for whole runs of segs that are either unused or + whose generation is within the range [0, maxg]. */ + int j; + for (j = 0; j < chunk->segs; j++) { + seginfo si = chunk->sis[j]; + /* When maxg is 0, limit the search to unused segments and + segments that belong to the current thread. */ + if ((maxg == 0 && si.generation == 0 && si.creator == tgc) || + (maxg != 0 && si.generation <= maxg) || + (is_unused_seg(chunk, &si))) { + bytes += bytes_per_segment; + } else { + if (bytes > 0) { + debug(printf("mprotect flags=%d from=%p to=%p maxg=%d (interrupted)\n", flags, addr, TO_VOIDP((char *)addr + bytes), maxg)) + if (mprotect(addr, bytes, flags) != 0) { + S_error_abort("mprotect failed"); + } + } + + addr = TO_VOIDP((char *)chunk->addr + (j + 1) * bytes_per_segment); + bytes = 0; + } + } + } +# else + bytes = chunk->bytes; +# endif + if (bytes > 0) { + debug(printf("mprotect flags=%d from=%p to=%p maxg=%d\n", flags, addr, TO_VOIDP((char *)addr + bytes), maxg)) + if (mprotect(addr, bytes, flags) != 0) { + S_error_abort("mprotect failed"); + } + } + + chunk = chunk->next; + } + } } +#endif diff --git a/src/ChezScheme/c/segment.h b/src/ChezScheme/c/segment.h index b32b8f7bdc..5dbd3a4833 100644 --- a/src/ChezScheme/c/segment.h +++ b/src/ChezScheme/c/segment.h @@ -97,3 +97,40 @@ FORCEINLINE uptr eq_hash(ptr key) { iptr x3 = x2 ^ ((x2 >> 8) & (iptr)0xFF); return (uptr)x3; } + +FORCEINLINE ptr S_object_to_reference(ptr p) { + if (p == Sfalse) + return (ptr)0; + else + return ((ptr)((uptr)(p) + reference_disp)); +} + +FORCEINLINE ptr S_reference_to_object(ptr p) { + if (p == (ptr)0) + return Sfalse; + else + return ((ptr)((uptr)(p) - reference_disp)); +} + +/* An allocation region needs room at the end of a formarding pointer + as a terminator */ +#define allocation_segment_tail_padding ptr_bytes + +/* We take advantage of the fact `reference_disp` is less than the + minimum allocation size plus `allocation_segment_tail_padding`, so + there's no possibility that the referece address for an object will + be off of its GC-managed page (even for a pair or an bytevector + with an empty payload). */ +#define FOREIGN_REFERENCEP(p) (MaybeSegInfo(addr_get_segment(p)) == NULL) + +/* checks whether address is on GC-managed page before adjusting it; + it's not ok to check after adjusting if `reference_disp` is more + than one word */ +FORCEINLINE ptr S_maybe_reference_to_object(ptr p) { + if (p == (ptr)0) + return Sfalse; + else if (MaybeSegInfo(addr_get_segment(p)) == NULL) + return (ptr)0; + else + return ((ptr)((uptr)(p) - reference_disp)); +} diff --git a/src/ChezScheme/c/stats.c b/src/ChezScheme/c/stats.c index 9413c3bfb8..01c9da7fdd 100644 --- a/src/ChezScheme/c/stats.c +++ b/src/ChezScheme/c/stats.c @@ -36,8 +36,6 @@ #include <sys/resource.h> #endif -#include <time.h> - static struct timespec starting_mono_tp; static long adjust_time_zone(ptr dtvec, struct tm *tmxp, ptr given_tzoff); diff --git a/src/ChezScheme/c/thread.c b/src/ChezScheme/c/thread.c index eafad66dfd..31e01c31d1 100644 --- a/src/ChezScheme/c/thread.c +++ b/src/ChezScheme/c/thread.c @@ -93,6 +93,7 @@ ptr S_create_thread_object(who, p_tc) const char *who; ptr p_tc; { tgc->next_loc[g][s] = (ptr)0; tgc->bytes_left[g][s] = 0; tgc->sweep_loc[g][s] = (ptr)0; + tgc->sweep_next[g][s] = NULL; } tgc->bitmask_overhead[g] = 0; } @@ -256,7 +257,7 @@ static IBOOL destroy_thread(tc) ptr tc; { S_scan_dirty((ptr *)EAP(tc), (ptr *)REAL_EAP(tc)); /* close off thread-local allocation */ - S_thread_start_code_write(); + S_thread_start_code_write(tc, static_generation, 0, NULL, 0); { ISPC s; IGEN g; thread_gc *tgc = THREAD_GC(tc); @@ -265,7 +266,7 @@ 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(); + S_thread_end_code_write(tc, static_generation, 0, NULL, 0); alloc_mutex_release(); @@ -276,7 +277,7 @@ static IBOOL destroy_thread(tc) ptr tc; { for (ges = GUARDIANENTRIES(tc); ges != Snil; ges = next) { obj = GUARDIANOBJ(ges); next = GUARDIANNEXT(ges); - if (!IMMEDIATE(obj) && (si = MaybeSegInfo(ptr_get_segment(obj))) != NULL && si->generation != static_generation) { + if (!FIXMEDIATE(obj) && (si = MaybeSegInfo(ptr_get_segment(obj))) != NULL && si->generation != static_generation) { INITGUARDIANNEXT(ges) = target; target = ges; } @@ -455,11 +456,11 @@ void S_condition_free(c) s_thread_cond_t *c; { #ifdef FEATURE_WINDOWS -static inline int s_thread_cond_timedwait(s_thread_cond_t *cond, s_thread_mutex_t *mutex, int typeno, long sec, long nsec) { +static inline int s_thread_cond_timedwait(s_thread_cond_t *cond, s_thread_mutex_t *mutex, int typeno, I64 sec, long nsec) { if (typeno == time_utc) { struct timespec now; S_gettime(time_utc, &now); - sec -= (long)now.tv_sec; + sec -= now.tv_sec; nsec -= now.tv_nsec; if (nsec < 0) { sec -= 1; @@ -470,7 +471,7 @@ static inline int s_thread_cond_timedwait(s_thread_cond_t *cond, s_thread_mutex_ sec = 0; nsec = 0; } - if (SleepConditionVariableCS(cond, mutex, sec*1000 + nsec/1000000)) { + if (SleepConditionVariableCS(cond, mutex, (DWORD)(sec*1000 + (nsec+500000)/1000000))) { return 0; } else if (GetLastError() == ERROR_TIMEOUT) { return ETIMEDOUT; @@ -481,12 +482,12 @@ static inline int s_thread_cond_timedwait(s_thread_cond_t *cond, s_thread_mutex_ #else /* FEATURE_WINDOWS */ -static inline int s_thread_cond_timedwait(s_thread_cond_t *cond, s_thread_mutex_t *mutex, int typeno, long sec, long nsec) { +static inline int s_thread_cond_timedwait(s_thread_cond_t *cond, s_thread_mutex_t *mutex, int typeno, I64 sec, long nsec) { struct timespec t; if (typeno == time_duration) { struct timespec now; S_gettime(time_utc, &now); - t.tv_sec = now.tv_sec + sec; + t.tv_sec = (time_t)(now.tv_sec + sec); t.tv_nsec = now.tv_nsec + nsec; if (t.tv_nsec >= 1000000000) { t.tv_sec += 1; @@ -508,7 +509,7 @@ IBOOL S_condition_wait(c, m, t) s_thread_cond_t *c; scheme_mutex_t *m; ptr t; { s_thread_t self = s_thread_self(); iptr count; INT typeno; - long sec; + I64 sec; long nsec; INT status; IBOOL is_collect; @@ -523,7 +524,7 @@ IBOOL S_condition_wait(c, m, t) s_thread_cond_t *c; scheme_mutex_t *m; ptr t; { if (t != Sfalse) { /* Keep in sync with ts record in s/date.ss */ typeno = Sinteger32_value(Srecord_ref(t,0)); - sec = Sinteger32_value(Scar(Srecord_ref(t,1))); + sec = Sinteger64_value(Scar(Srecord_ref(t,1))); nsec = Sinteger32_value(Scdr(Srecord_ref(t,1))); } else { typeno = 0; diff --git a/src/ChezScheme/c/types.h b/src/ChezScheme/c/types.h index fdb19f88d3..e2c4804d5e 100644 --- a/src/ChezScheme/c/types.h +++ b/src/ChezScheme/c/types.h @@ -92,8 +92,8 @@ typedef int IFASLCODE; /* fasl type codes */ #define find_room(tc, s, g, t, n, x) find_gc_room_T(THREAD_GC(tc), s, g, t, n, ALREADY_PTR, x) #define find_gc_room(tgc, s, g, t, n, x) find_gc_room_T(tgc, s, g, t, n, ALREADY_PTR, x) -#define find_room_voidp(tc, s, g, n, x) find_gc_room_T(THREAD_GC(tc), s, g, typemod, n, TO_VOIDP, x) -#define find_gc_room_voidp(tgc, s, g, n, x) find_gc_room_T(tgc, s, g, typemod, n, TO_VOIDP, x) +#define find_room_voidp(tc, s, g, n, x) find_gc_room_T(THREAD_GC(tc), s, g, type_untyped, n, TO_VOIDP, x) +#define find_gc_room_voidp(tgc, s, g, n, x) find_gc_room_T(tgc, s, g, type_untyped, n, TO_VOIDP, x) /* new-space inline allocation --- no mutex required */ /* Like `find_room`, but always `space_new` and generation 0, @@ -111,7 +111,7 @@ typedef int IFASLCODE; /* fasl type codes */ } while(0) #define newspace_find_room(tc, t, n, x) newspace_find_room_T(tc, t, n, ALREADY_PTR, x) -#define newspace_find_room_voidp(tc, n, x) newspace_find_room_T(tc, typemod, n, TO_VOIDP, x) +#define newspace_find_room_voidp(tc, n, x) newspace_find_room_T(tc, type_untyped, n, TO_VOIDP, x) #ifndef NO_PRESERVE_FLONUM_EQ # define PRESERVE_FLONUM_EQ @@ -158,6 +158,9 @@ typedef struct _seginfo { struct _seginfo *next; /* pointer to the next seginfo (used in occupied_segments and unused_segs) */ struct _seginfo *sweep_next; /* next in list of segments allocated during GC => need to sweep */ ptr sweep_start; /* address within segment to start sweep */ +#if defined(WRITE_XOR_EXECUTE_CODE) + iptr sweep_bytes; /* total number of bytes starting at sweep_start */ +#endif struct _seginfo **dirty_prev; /* pointer to the next pointer on the previous seginfo in the DirtySegments list */ struct _seginfo *dirty_next; /* pointer to the next seginfo on the DirtySegments list */ ptr trigger_ephemerons; /* ephemerons to re-check if object in segment is copied out */ @@ -186,7 +189,7 @@ typedef struct _chunkinfo { iptr base; /* first segment */ iptr bytes; /* size in bytes */ iptr segs; /* size in segments */ - iptr nused_segs; /* number of segments currently in used use */ + iptr nused_segs; /* number of segments currently in use */ struct _chunkinfo **prev; /* pointer to previous chunk's next */ struct _chunkinfo *next; /* next chunk */ struct _seginfo *unused_segs; /* list of unused segments */ @@ -279,7 +282,7 @@ 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) +#define rtd_parent(x) INITVECTIT(RECORDDESCANCESTRY(x), Svector_length(RECORDDESCANCESTRY(x)) - ancestry_parent_offset) /* type tagging macros */ @@ -549,9 +552,20 @@ typedef struct thread_gc { #define SETPTRFIELD(x,disp,y) DIRTYSET(((ptr *)TO_VOIDP((uptr)(x)+disp)),(y)) #define INCRGEN(g) (g = g == S_G.max_nonstatic_generation ? static_generation : g+1) -#define IMMEDIATE(x) (Sfixnump(x) || Simmediatep(x)) +#define FIXMEDIATE(x) (Sfixnump(x) || Simmediatep(x)) + +#define Sbytevector_reference_length(p) (Sbytevector_length(p) >> log2_ptr_bytes) +#define INITBVREFIT(p, i) (*(ptr *)(&BVIT(p, (i) << log2_ptr_bytes))) /* For `memcpy_aligned, that the first two arguments are word-aligned and it would be ok to round up the length to a word size. But probably the compiler does a fine job with plain old `mempcy`. */ #define memcpy_aligned memcpy + +#define USE_TRAP_FUEL(tc, n) do { \ + uptr _amt_ = (uptr)(n); \ + if ((uptr)TRAP(tc) > _amt_) \ + TRAP(tc) = (ptr)((uptr)TRAP(tc) - _amt_); \ + else \ + TRAP(tc) = (ptr)1; \ + } while (0) diff --git a/src/ChezScheme/c/version.h b/src/ChezScheme/c/version.h index 4783f468a4..286716f270 100644 --- a/src/ChezScheme/c/version.h +++ b/src/ChezScheme/c/version.h @@ -16,112 +16,33 @@ #include "config.h" -#if (machine_type == machine_type_arm32le || machine_type == machine_type_tarm32le || machine_type == machine_type_arm64le || machine_type == machine_type_tarm64le) -# define OS_ANY_LINUX -# if (machine_type == machine_type_tarm32le || machine_type == machine_type_tarm64le) -# define PTHREADS -# endif -# define OS_ANY_LINUX -# define LITTLE_ENDIAN_IEEE_DOUBLE -# define FLUSHCACHE -#endif - -#if (machine_type == machine_type_ppc32le || machine_type == machine_type_tppc32le || machine_type == machine_type_ppc64le || machine_type == machine_type_tppc64le) -# define OS_ANY_LINUX -# if (machine_type == machine_type_tppc32le || machine_type == machine_type_tppc64le) -# define PTHREADS -# endif -# define FLUSHCACHE +#if defined(scheme_feature_pthreads) +# define PTHREADS #endif -#if (machine_type == machine_type_i3le || machine_type == machine_type_ti3le || machine_type == machine_type_a6le || machine_type == machine_type_ta6le) -# define OS_ANY_LINUX -# if (machine_type == machine_type_ti3le || machine_type == machine_type_ta6le) -# define PTHREADS -# endif -# define LITTLE_ENDIAN_IEEE_DOUBLE -#endif - -#if (machine_type == machine_type_i3fb || machine_type == machine_type_ti3fb || machine_type == machine_type_a6fb || machine_type == machine_type_ta6fb) -# define OS_ANY_FREEBSD -# if (machine_type == machine_type_ti3fb || machine_type == machine_type_ta6fb) -# define PTHREADS -# endif -# define LITTLE_ENDIAN_IEEE_DOUBLE -#endif +/*****************************************/ +/* Architectures */ -#if (machine_type == machine_type_i3nb || machine_type == machine_type_ti3nb || machine_type == machine_type_a6nb || machine_type == machine_type_ta6nb) -# define OS_ANY_NETBSD -# if (machine_type == machine_type_ti3nb || machine_type == machine_type_ta6nb) -# define PTHREADS -# endif -#endif - -#if (machine_type == machine_type_i3nt || machine_type == machine_type_ti3nt || machine_type == machine_type_a6nt || machine_type == machine_type_ta6nt) -# define OS_ANY_WINDOWS -# if (machine_type == machine_type_ti3nt || machine_type == machine_type_ta6nt) -# define PTHREADS -# endif -#endif - -#if (machine_type == machine_type_i3ob || machine_type == machine_type_ti3ob || machine_type == machine_type_a6ob || machine_type == machine_type_ta6ob) -# define OS_ANY_OPENBSD -# if (machine_type == machine_type_ti3ob || machine_type == machine_type_ta6ob) -# define PTHREADS -# endif -#endif - -#if (machine_type == machine_type_i3osx || machine_type == machine_type_ti3osx || machine_type == machine_type_a6osx || machine_type == machine_type_ta6osx) -# define OS_ANY_MACOSX -# if (machine_type == machine_type_ti3osx || machine_type == machine_type_ta6osx) -# define PTHREADS -# 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 +#if (defined(__powerpc__) || defined(__POWERPC__)) && !defined(__powerpc64__) +# define PORTABLE_BYTECODE_BIGENDIAN +# define BIG_ENDIAN_IEEE_DOUBLE # 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 +#if (defined(__arm__) || defined(__arm64__) || defined(__aarch64__)) # define FLUSHCACHE #endif #if (machine_type == machine_type_pb) -# if (defined(__powerpc__) || defined(__POWERPC__)) && !defined(__powerpc64__) -# define PORTABLE_BYTECODE_BIGENDIAN -# endif -# if defined(__linux__) -# define OS_ANY_LINUX -# ifndef PORTABLE_BYTECODE_BIGENDIAN -# define LITTLE_ENDIAN_IEEE_DOUBLE -# endif -# elif defined(__NetBSD__) -# define OS_ANY_NETBSD -# elif defined(__OpenBSD__) && !defined(__Bitrig__) -# define OS_ANY_OPENBSD -# elif defined(__FreeBSD__) || defined(__FreeBSD_kernel__) -# define OS_ANY_FREEBSD -# ifndef PORTABLE_BYTECODE_BIGENDIAN -# define LITTLE_ENDIAN_IEEE_DOUBLE -# endif -# elif defined(_MSC_VER) || defined(__MINGW32__) -# define OS_ANY_WINDOWS -# elif __APPLE__ -# define OS_ANY_MACOSX -# elif defined(sun) -# define OS_ANY_SOLARIS2 -# endif +# undef FLUSHCACHE +#else +# undef PORTABLE_BYTECODE_BIGENDIAN #endif -#ifdef OS_ANY_LINUX +/*****************************************/ +/* Operating systems */ + +#if defined(__linux__) #define NOBLOCK O_NONBLOCK #define LOAD_SHARED_OBJECT #define USE_MMAP @@ -134,7 +55,9 @@ typedef char *memcpy_t; #define MAKE_NAN(x) { x = 0.0; x = x / x; } #define GETWD(x) getcwd((x),PATH_MAX) typedef int tputsputcchar; -#define LOCKF +#ifndef __ANDROID__ +# define LOCKF +#endif #define DIRMARKERP(c) ((c) == '/') #ifndef DISABLE_X11 # define LIBX11 "libX11.so" @@ -149,10 +72,14 @@ typedef int tputsputcchar; #define NSECCTIME(sb) (sb).st_ctim.tv_nsec #define NSECMTIME(sb) (sb).st_mtim.tv_nsec #define ICONV_INBUF_TYPE char ** +#ifdef __ANDROID__ +# define NOFILE 256 +# define NO_USELOCALE +#endif #define UNUSED __attribute__((__unused__)) #endif -#ifdef OS_ANY_FREEBSD +#if defined(__FreeBSD__) || defined(__FreeBSD_kernel__) #define NOBLOCK O_NONBLOCK #define LOAD_SHARED_OBJECT #define USE_MMAP @@ -181,7 +108,7 @@ typedef int tputsputcchar; #define USE_OSSP_UUID #endif -#ifdef OS_ANY_NETBSD +#if defined(__NetBSD__) #ifdef PTHREADS # define NETBSD #endif @@ -190,7 +117,6 @@ typedef int tputsputcchar; #define USE_MMAP #define MMAP_HEAP #define IEEE_DOUBLE -#define LITTLE_ENDIAN_IEEE_DOUBLE #define LDEXP #define ARCHYPERBOLIC #define GETPAGESIZE() getpagesize() @@ -216,15 +142,15 @@ typedef int tputsputcchar; #define USE_MBRTOWC_L #endif -#ifdef OS_ANY_WINDOWS +#if defined(_MSC_VER) || defined(__MINGW32__) #define GETPAGESIZE() S_getpagesize() #define GETWD(x) GETCWD(x, _MAX_PATH) #define IEEE_DOUBLE -#define LITTLE_ENDIAN_IEEE_DOUBLE #define LOAD_SHARED_OBJECT #define USE_VIRTUAL_ALLOC #define NAN_INCLUDE <math.h> #define MAKE_NAN(x) { x = sqrt(-1.0); } +#define ARCHYPERBOLIC #ifndef PATH_MAX # define PATH_MAX _MAX_PATH #endif @@ -283,13 +209,12 @@ struct timespec; #endif #endif -#ifdef OS_ANY_OPENBSD +#if defined(__OpenBSD__) && !defined(__Bitrig__) #define NOBLOCK O_NONBLOCK #define LOAD_SHARED_OBJECT #define USE_MMAP #define MMAP_HEAP #define IEEE_DOUBLE -#define LITTLE_ENDIAN_IEEE_DOUBLE #define LDEXP #define ARCHYPERBOLIC #define GETPAGESIZE() getpagesize() @@ -314,19 +239,23 @@ typedef int tputsputcchar; #define USE_OSSP_UUID #endif -#ifdef OS_ANY_MACOSX +#if defined(__APPLE__) #define MACOSX #define NOBLOCK O_NONBLOCK #define LOAD_SHARED_OBJECT #define USE_MMAP #define MMAP_HEAP #define IEEE_DOUBLE -#if !defined(__POWERPC__) -# define LITTLE_ENDIAN_IEEE_DOUBLE +/* for both iPhone and iPhoneSimulator */ +#if defined(TARGET_OS_IPHONE) +# define SYSTEM(s) ((void)s, -1) +# define WRITE_XOR_EXECUTE_CODE #endif #if defined(__arm64__) -# define S_MAP_CODE MAP_JIT -# define S_ENABLE_CODE_WRITE(on) pthread_jit_write_protect_np(!(on)) +# if !defined(WRITE_XOR_EXECUTE_CODE) +# define S_MAP_CODE MAP_JIT +# define S_ENABLE_CODE_WRITE(on) pthread_jit_write_protect_np(!(on)) +# endif # define CANNOT_READ_DIRECTLY_INTO_CODE # include <pthread.h> #elif defined(__x86_64__) @@ -343,7 +272,10 @@ typedef int tputsputcchar; #define LOCKF #define DIRMARKERP(c) ((c) == '/') #ifndef DISABLE_X11 -#define LIBX11 "/usr/X11R6/lib/libX11.dylib" +# define DISABLE_X11 +#endif +#ifndef DISABLE_X11 +# define LIBX11 "/usr/X11R6/lib/libX11.dylib" #endif #define _DARWIN_USE_64_BIT_INODE #define SECATIME(sb) (sb).st_atimespec.tv_sec @@ -356,20 +288,12 @@ typedef int tputsputcchar; #define UNUSED __attribute__((__unused__)) #endif -#if (machine_type == machine_type_i3qnx || machine_type == machine_type_ti3qnx) -# define OS_ANY_QNX -# if (machine_type == machine_type_ti3qnx) -# define PTHREADS -# endif -#endif - -#ifdef OS_ANY_QNX +#if defined(__QNX__) #define NOBLOCK O_NONBLOCK #define LOAD_SHARED_OBJECT #define USE_MMAP #define MMAP_HEAP #define IEEE_DOUBLE -#define LITTLE_ENDIAN_IEEE_DOUBLE #define LDEXP #define ARCHYPERBOLIC #define GETPAGESIZE() getpagesize() @@ -393,20 +317,12 @@ typedef int tputsputcchar; #define UNUSED #endif -#if (machine_type == machine_type_i3s2 || machine_type == machine_type_ti3s2 || machine_type == machine_type_a6s2 || machine_type == machine_type_ta6s2) -# define OS_ANY_SOLARIS2 -# if (machine_type == machine_type_ti3s2 || machine_type == machine_type_ta6s2) -# define PTHREADS -# endif -#endif - -#ifdef OS_ANY_SOLARIS2 +#if defined(sun) #define NOBLOCK O_NONBLOCK #define LOAD_SHARED_OBJECT #define USE_MMAP #define MMAP_HEAP #define IEEE_DOUBLE -#define LITTLE_ENDIAN_IEEE_DOUBLE #define LDEXP #define ARCHYPERBOLIC #define LOG1P @@ -433,7 +349,12 @@ typedef char tputsputcchar; #define UNUSED __attribute__((__unused__)) #endif -/* defaults */ +/*****************************************/ +/* Defaults and derived */ + +#ifndef BIG_ENDIAN_IEEE_DOUBLE +# define LITTLE_ENDIAN_IEEE_DOUBLE +#endif #ifndef CHDIR # define CHDIR chdir @@ -497,7 +418,11 @@ typedef char tputsputcchar; #endif #ifndef S_PROT_CODE -# define S_PROT_CODE (PROT_READ | PROT_WRITE | PROT_EXEC) +# ifdef WRITE_XOR_EXECUTE_CODE +# define S_PROT_CODE (PROT_WRITE | PROT_READ) +# else +# define S_PROT_CODE (PROT_READ | PROT_WRITE | PROT_EXEC) +# endif #endif #ifndef S_MAP_CODE # define S_MAP_CODE 0 @@ -506,6 +431,16 @@ typedef char tputsputcchar; # define S_ENABLE_CODE_WRITE(on) do { } while (0) #endif +/* WX_UNUSED indicates that an argument is used only for + WRITE_XOR_EXECUTE_CODE mode */ +#ifndef WX_UNUSED +# ifdef WRITE_XOR_EXECUTE_CODE +# define WX_UNUSED +# else +# define WX_UNUSED UNUSED +# endif +#endif + #ifdef PTHREADS # define NO_THREADS_UNUSED /* empty */ #else diff --git a/src/ChezScheme/c/vfasl.c b/src/ChezScheme/c/vfasl.c index 61de95cb9b..79434d56b1 100644 --- a/src/ChezScheme/c/vfasl.c +++ b/src/ChezScheme/c/vfasl.c @@ -135,9 +135,9 @@ ptr S_vfasl(ptr bv, void *stream, iptr offset, iptr input_len) 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]); + newspace_find_room(tc, type_untyped, sz, vspaces[s]); } else { - find_room(tc, vspace_spaces[s], (to_static ? static_generation : 0), typemod, sz, vspaces[s]); + find_room(tc, vspace_spaces[s], (to_static ? static_generation : 0), type_untyped, sz, vspaces[s]); } if (bv) { memcpy(TO_VOIDP(vspaces[s]), bv_addr, sz); @@ -146,7 +146,7 @@ ptr S_vfasl(ptr bv, void *stream, iptr offset, iptr input_len) ptr dest; #ifdef CANNOT_READ_DIRECTLY_INTO_CODE if (s == vspace_code) - newspace_find_room(tc, typemod, sz, dest); + newspace_find_room(tc, type_untyped, sz, dest); else dest = vspaces[s]; #else @@ -170,7 +170,7 @@ ptr S_vfasl(ptr bv, void *stream, iptr offset, iptr input_len) if (bv) table = TO_PTR(bv_addr); else { - newspace_find_room(tc, typemod, ptr_align(VFASLHEADER_TABLE_SIZE(header)), table); + newspace_find_room(tc, type_untyped, 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"); } @@ -489,7 +489,7 @@ static void relink_code(ptr co, ptr sym_base, ptr *vspaces, uptr *vspace_offsets ptr tc = get_thread_context(); iptr sz = size_reloc_table(RELOCSIZE(t)); ptr new_t; - find_room(tc, space_data, static_generation, typemod, ptr_align(sz), new_t); + find_room(tc, space_data, static_generation, type_untyped, ptr_align(sz), new_t); memcpy(TO_VOIDP(new_t), TO_VOIDP(t), sz); t = new_t; CODERELOC(co) = t; @@ -519,7 +519,7 @@ static void relink_code(ptr co, ptr sym_base, ptr *vspaces, uptr *vspace_offsets /* offset is stored in place of constant-loading code: */ memcpy(&obj, TO_VOIDP((ptr)((uptr)co + a)), sizeof(ptr)); - if (IMMEDIATE(obj)) { + if (FIXMEDIATE(obj)) { if (Sfixnump(obj)) { int tag = VFASL_RELOC_TAG(obj); iptr pos = VFASL_RELOC_POS(obj); diff --git a/src/ChezScheme/c/windows.c b/src/ChezScheme/c/windows.c index 1850d72482..23c0c20acb 100644 --- a/src/ChezScheme/c/windows.c +++ b/src/ChezScheme/c/windows.c @@ -21,6 +21,7 @@ #include <io.h> #include <sys/stat.h> +static ptr s_ErrorStringImp(DWORD dwMessageId, const char *lpcDefault); static ptr s_ErrorString(DWORD dwMessageId); static IUnknown *s_CreateInstance(CLSID *pCLSID, IID *iid); static ptr s_GetRegistry(wchar_t *s); @@ -52,17 +53,10 @@ void *S_ntdlsym(void *h, const char *s) { return (void *)GetProcAddress(h, s); } -/* S_ntdlerror courtesy of Bob Burger, burgerrg@sagian.com */ -char *S_ntdlerror(void) { - static char s[80]; - INT n; - - n = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, NULL, GetLastError(), - 0, (LPTSTR)s, 80, NULL); - if (n == 0) return "unable to load library"; - /* Strip trailing period, newline & return when present */ - if (n >= 3 && s[n-3] == '.') s[n-3] = 0; - return s; +/* Initial version of S_ntdlerror courtesy of Bob Burger + * Modifications by James-Adam Renquinha Henri, jarhmander@gmail.com */ +ptr S_ntdlerror(void) { + return s_ErrorStringImp(GetLastError(), "unable to load library"); } #ifdef FLUSHCACHE @@ -242,33 +236,48 @@ static IUnknown *s_CreateInstance(CLSID *pCLSID, IID *iid) { } static ptr s_ErrorString(DWORD dwMessageId) { - char *lpMsgBuf; + return s_ErrorStringImp(dwMessageId, NULL); +} + +static ptr s_ErrorStringImp(DWORD dwMessageId, const char *lpcDefault) { + wchar_t *lpMsgBuf; DWORD len; + char *u8str; ptr result; - len = FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER | FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS, - NULL, dwMessageId, MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (LPTSTR)&lpMsgBuf, 0, NULL); - /* If FormatMessage fails, use the error code in hexadecimal. */ + len = FormatMessageW(FORMAT_MESSAGE_ALLOCATE_BUFFER | FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS, + NULL, dwMessageId, MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (LPWSTR)&lpMsgBuf, 0, NULL); + /* If FormatMessage fails... */ if (len == 0) { -#define HEXERRBUFSIZ ((sizeof(dwMessageId) * 2) + 3) - char hexerrbuf[HEXERRBUFSIZ]; - snprintf(hexerrbuf, HEXERRBUFSIZ, "0x%x", (unsigned int)dwMessageId); - return Sstring(hexerrbuf); -#undef HEXERRBUFSIZ + if (lpcDefault) { + /* ... use the default string if provided... */ + return Sstring_utf8(lpcDefault, -1); + } else { + /* ...otherwise, use the error code in hexadecimal. */ + char buf[(sizeof(dwMessageId) * 2) + 3]; + int n = snprintf(buf, sizeof(buf), "0x%lx", dwMessageId); + if ((unsigned)n < sizeof(buf)) + return Sstring_utf8(buf, n); + else + return Sstring("??"); + } } - /* Otherwise remove trailing newlines & returns and strip trailing period. */ + /* Otherwise remove trailing newlines & returns and strip trailing period, if present. */ while (len > 0) { - char c = lpMsgBuf[len - 1]; - if (c == '\n' || c == '\r') + wchar_t c = lpMsgBuf[len - 1]; + if (c == L'\n' || c == '\r') len--; - else if (c == '.') { + else if (c == L'.') { len--; break; } else break; } - result = Sstring_of_length(lpMsgBuf, len); + lpMsgBuf[len] = 0; + u8str = Swide_to_utf8(lpMsgBuf); LocalFree(lpMsgBuf); + result = Sstring_utf8(u8str, -1); + free(u8str); return result; } @@ -307,7 +316,7 @@ int S_windows_open_exclusive(char *who, char *path, int flags) { } #endif -#include <Winbase.h> +#include <winbase.h> /* primitive version of flock compatible with Windows 95/98/ME. A better version could be implemented for Windows NT/2000/XP using LockFileEx. */ diff --git a/src/ChezScheme/configure b/src/ChezScheme/configure index 81864a5008..329133e7cc 100755 --- a/src/ChezScheme/configure +++ b/src/ChezScheme/configure @@ -57,9 +57,10 @@ installscriptname="scheme-script" cflagsset=no disablex11=no disablecurses=no +disableiconv=no addflags=yes addwarningflags=no -default_warning_flags="-Wpointer-arith -Wall -Wextra -Werror -Wno-implicit-fallthrough" +default_warning_flags="-Wpointer-arith -Wall -Wextra -Wno-implicit-fallthrough" : ${CC:="gcc"} : ${CPPFLAGS:=""} : ${CFLAGS:=""} @@ -93,22 +94,7 @@ fi case "${CONFIG_UNAME}" in Linux) - if uname -a | egrep 'i386|i686|amd64|athlon|x86_64' > /dev/null 2>&1 ; then - m32=i3le - m64=a6le - tm32=ti3le - tm64=ta6le - elif uname -a | grep -i power > /dev/null 2>&1 ; then - m32=ppc32le - m64="" - tm32=tppc32le - tm64="" - elif uname -a | egrep 'armv|aarch64' > /dev/null 2>&1 ; then - m32=arm32le - m64=arm64le - tm32=tarm32le - tm64=tarm64le - fi + unixsuffix=le installprefix=/usr installmansuffix=share/man ;; @@ -121,32 +107,17 @@ case "${CONFIG_UNAME}" in installmansuffix=man ;; FreeBSD) - if uname -a | egrep 'i386|i686|amd64|athlon|x86_64' > /dev/null 2>&1 ; then - m32=i3fb - m64=a6fb - tm32=ti3fb - tm64=ta6fb - fi + unixsuffix=fb installprefix=/usr/local installmansuffix=man ;; OpenBSD) - if uname -a | egrep 'i386|i686|amd64|athlon|x86_64' > /dev/null 2>&1 ; then - m32=i3ob - m64=a6ob - tm32=ti3ob - tm64=ta6ob - fi + unixsuffix=ob installprefix=/usr/local installmansuffix=man ;; NetBSD) - if uname -a | egrep 'i386|i686|amd64|athlon|x86_64' > /dev/null 2>&1 ; then - m32=i3nb - m64=a6nb - tm32=ti3nb - tm64=ta6nb - fi + unixsuffix=nb installprefix=/usr installmansuffix=share/man gzipmanpages=no @@ -191,6 +162,23 @@ case "${CONFIG_UNAME}" in ;; esac +if [ "$unixsuffix" != "" ] ; then + if uname -a | egrep 'i386|i686|amd64|athlon|x86_64' > /dev/null 2>&1 ; then + m32=i3${unixsuffix} + m64=a6${unixsuffix} + tm32=ti3${unixsuffix} + tm64=ta6${unixsuffix} + elif uname -a | egrep 'power|ppc' > /dev/null 2>&1 ; then + m32=ppc32${unixsuffix} + tm32=tppc32${unixsuffix} + elif uname -a | egrep 'armv|aarch64' > /dev/null 2>&1 ; then + m32=arm32${unixsuffix} + m64=arm64${unixsuffix} + tm32=tarm32${unixsuffix} + tm64=tarm64${unixsuffix} + fi +fi + threads="" bits="" @@ -273,6 +261,9 @@ while [ $# != 0 ] ; do --disable-curses) disablecurses=yes ;; + --disable-iconv) + disableiconv=yes + ;; --disable-auto-flags) addflags=no ;; @@ -356,7 +347,7 @@ if [ "$m" = "pb" ] ; then fi if [ "$bits" = "" ] ; then - if uname -a | egrep 'amd64|x86_64|aarch64|arm64' > /dev/null 2>&1 ; then + if uname -a | egrep 'amd64|x86_64|aarch64|arm64|ppc64|powerpc64' > /dev/null 2>&1 ; then bits=64 else bits=32 @@ -379,6 +370,16 @@ if [ "$m" = "" ] ; then m=pb if [ $bits = 64 ] ; then mpbhost=$m64 ; else mpbhost=$m32 ; fi flagsm=$mpbhost + if [ "$mpbhost" = "" ] ; then + echo "Could not infer current machine type." + echo "" + echo "Event for a pb build, a machine type is needed to select C compiler" + echo "and linker flags. You can use" + echo " $0 --pb -m=<machine type>" + echo "to specify the available machine type, but since it wasn't inferred," + echo "probably your OS and architecture combination is not supported." + exit 1 + fi else m=$defaultm flagsm=$m @@ -407,14 +408,6 @@ if [ "$installman" = "" ] ; then installman=$installprefix/$installmansuffix fi -if [ "$disablex11" = "no" ] ; then - if [ $m = a6osx ] || [ $m = ta6osx ] ; then - if [ ! -d /opt/X11/include/ ] ; then - disablex11=yes - fi - fi -fi - if [ "$help" = "yes" ]; then echo "Purpose:" echo " $0 determines the machine type and constructs a custom Makefile" @@ -428,6 +421,7 @@ 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-iconv disable iconv 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)" @@ -503,61 +497,80 @@ case "${flagsm}" in ;; esac +flagsmuni=`echo $flagsm | sed -e 's/^t//'` +muni=`echo $m | sed -e 's/^t//'` + # 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) + case "${flagsmuni}" in + a6le) CFLAGS="-m64 -msse2 ${optFlags}" ;; - a6fb|ta6fb|a6nb|ta6nb|a6ob|ta6ob) - CFLAGS="-m64 ${optFlags}" - ;; - a6s2|ta6s2) - CFLAGS="-m64 ${optFlags}" + a6nt) + CFLAGS="${optFlags}" ;; - a6osx|ta6osx) + a6*) CFLAGS="-m64 ${optFlags}" ;; - arm64osx|tarm64osx) - CFLAGS="-arch arm64 ${optFlags}" - ;; - a6nt|ta6nt) - CFLAGS="${optFlags}" + i3le) + CFLAGS="-m32 -msse2 ${optFlags}" ;; - arm32le|tarm32le|arm64le|tarm64le) + i3nt) CFLAGS="${optFlags}" ;; - i3le|ti3le) - CFLAGS="-m32 -msse2 ${optFlags}" + i3qnx) + CC=qcc + CFLAGS="-m32 -N2048K ${optFlags}" ;; - i3fb|ti3fb|i3nb|ti3nb|i3ob|ti3ob) + i3*) CFLAGS="-m32 ${optFlags}" ;; - i3s2|ti3s2) + arm32*) CFLAGS="-m32 ${optFlags}" ;; - i3osx|ti3osx) - CFLAGS="-m32 ${optFlags}" + arm64osx) + CFLAGS="-arch arm64 ${optFlags}" ;; - i3nt|ti3nt) + ppc32osx) CFLAGS="${optFlags}" ;; - i3qnx) - CC=qcc - CFLAGS="-m32 -N2048K ${optFlags}" - ;; - ppc32le|tppc32le) + ppc32*) CFLAGS="-m32 ${optFlags}" ;; - ppc32osx|tppc32osx) - CFLAGS="${optFlags}" - ;; esac fi +# architecture-specific for Mf-unix +case "${muni}" in + pb) + Cpu=PORTABLE_BYTECODE + mdarchsrc=pb + ;; + a6*) + Cpu=X86_64 + mdarchsrc=i3le + ;; + i3*) + Cpu=I386 + mdarchsrc=i3le + ;; + arm32*) + Cpu=ARMV6 + mdarchsrc=arm32le + ;; + arm64*) + Cpu=AARCH64 + mdarchsrc=arm32le + ;; + ppc32*) + Cpu=PPC32 + mdarchsrc=ppc32 + ;; +esac + # Add automatic thread compilation flags, unless suppressed by --disable-auto-flags if [ "$addflags" = "yes" ] ; then if [ "$threadFlags" != "" ] ; then @@ -573,6 +586,13 @@ if [ "$disablecurses" = "yes" ]; then ncursesLib= fi +if [ "$disableiconv" = "yes" ]; then + iconvLib= + CPPFLAGS="${CPPFLAGS} -DDISABLE_ICONV" +else + iconvLib="-liconv" +fi + # Add automatic linking flags, unless suppressed by --disable-auto-flags if [ "$addflags" = "yes" ] ; then case "${flagsm}" in @@ -594,22 +614,28 @@ if [ "$addflags" = "yes" ] ; then LIBS="${LIBS} -lm -ldl ${ncursesLib} -lrt" ;; *fb|*ob) - LIBS="${LIBS} -liconv -lm ${ncursesLib}" + LIBS="${LIBS} ${iconvLib} -lm ${ncursesLib}" ;; *nb) - LIBS="${LIBS} /usr/lib/i18n/libiconv_std.a -lm /usr/pkg/lib/libncurses.a" + if [ "$disablecurses" = "no" ]; then + iconvLib="/usr/lib/i18n/libiconv_std.a" + fi + LIBS="${LIBS} ${iconvLib} -lm /usr/pkg/lib/libncurses.a" ;; *s2) LIBS="${LIBS} -lnsl -ldl -lm ${cursesLib} -lrt" ;; *osx) - LIBS="${LIBS} -liconv -lm ${ncursesLib}" + LIBS="${LIBS} ${iconvLib} -lm ${ncursesLib}" ;; *nt) LIBS="${LIBS} -lshell32 -luser32 -lole32 -lrpcrt4 -luuid" ;; 8qnx) - LIBS="${LIBS} -lm /usr/local/lib/libiconv.so -lsocket ${ncursesLib}" + if [ "$disablecurses" = "no" ]; then + iconvLib="/usr/local/lib/libiconv.so" + fi + LIBS="${LIBS} -lm ${iconvLib} -lsocket ${ncursesLib}" ;; esac if [ "$threadLibs" != "" ] ; then @@ -617,6 +643,84 @@ if [ "$addflags" = "yes" ] ; then fi fi +# more compile and link flags for c/Mf-unix and mats/Mf-unix +mdinclude= +mdcppflags= +mdcflags= +mdldflags= +mdlinkflags= +zlibConfigureFlags= +exePostStep=":" + +# compile flags for c/Mf-unix and mats/Mf-unix +case "${flagsmuni}" in + *le) + mdcflags="-fPIC -shared" + ;; + *fb|*ob) + mdcflags="-fPIC -shared" + mdinclude="-I/usr/local/include -I/usr/X11R6/include" + ;; + *nb) + mdcflags="-fPIC -shared" + mdinclude="-I/usr/X11R7/include -I/usr/pkg/include -I/usr/pkg/include/ncurses -I/usr/X11R6/include" + ;; + *osx) + mdcflags="-dynamiclib -undefined dynamic_lookup" + ;; + *s2) + mdcflags="-fPIC -shared" + mdcppflags="-DSOLARIS" + ;; + *qnx) + mdcflags="-fPIC -shared" + mdinclude="-I/usr/local/include" + ;; +esac + +# dynamic linking flags for c/Mf-unix +case "${flagsmuni}" in + a6le) + mdldflags="-melf_x86_64" + ;; + i3le) + mdldflags="-melf_i386" + ;; + *le) + ;; + i3nb) + mdldflags="-m elf_i386" + ;; + *fb|*ob|*nb) + ;; + *osx) + ;; + a6s2) + mdldflags="-melf_x86_64" + ;; + i3s2) + mdldflags="-melf_i386" + ;; + i3qnx) + mdlinkflags="-Wl,--export-dynamic" + mdldflags="-mi386nto" + ;; +esac + +# post-link-executable step for c/Mf-unix +case "${flagsmuni}" in + *nb) + exePostStep='paxctl +m ${Scheme}' + ;; +esac + +# zlib configure flags for c/Mf-unix +case "${flagsmuni}" in + a6*) + zlibConfigureFlags="--64" + ;; +esac + if [ -f boot/$m/scheme.boot -o -f "$srcdir"/boot/$m/scheme.boot ] ; then echo "Configuring for $m" else @@ -671,7 +775,12 @@ case "$srcdir" in ;; esac -"$srcdir"/workarea $m $w $mpbhost +if "$srcdir"/workarea $m $w $mpbhost ; then + : +else + # not a recognized host, or other error + exit 1 +fi sed -e 's/$(m)/'$m'/g'\ -e 's/$(defaultm)/'$defaultm'/g'\ @@ -744,6 +853,15 @@ esac cat > $w/c/Mf-config << END upupsrcdir=$upupsrcdir +m=$m +Cpu=$Cpu +mdarchsrc=$mdarchsrc +mdinclude=$mdinclude +mdcppflags=$mdcppflags +mdldflags=$mdldflags +mdlinkflags=$mdlinkflags +exePostStep=$exePostStep +zlibConfigureFlags= CC=$CC CPPFLAGS=$CPPFLAGS CFLAGS=$CFLAGS @@ -771,3 +889,12 @@ KernelLinkDeps=\${${Kernel}LinkDeps} KernelLinkLibs=\${${Kernel}LinkLibs} C=\${CC} \${CPPFLAGS} \${CFLAGS} \${warningFlags} END + +cat > $w/mats/Mf-config << END +upupsrcdir=$upupsrcdir +m=$m +mdcflags=$mdcflags +CC=$CC +CPPFLAGS=$CPPFLAGS +CFLAGS=$CFLAGS +END diff --git a/src/ChezScheme/csug/gifs/Makefile b/src/ChezScheme/csug/gifs/Makefile index 8676e4c0f6..4253ffd112 100644 --- a/src/ChezScheme/csug/gifs/Makefile +++ b/src/ChezScheme/csug/gifs/Makefile @@ -18,7 +18,7 @@ density=-r90x90 ${density} - |\ pnmcrop |\ ppmtogif -transparent white > $*.gif - /bin/rm -f $*.dvi $*.log *.aux + rm -f $*.dvi $*.log *.aux test -f $*.gif && chmod 644 $*.gif # translate ps file to gif w/o transparent white background @@ -28,7 +28,7 @@ density=-r90x90 ${density} - |\ pnmcrop |\ ppmtogif > $*.gif - /bin/rm -f $*.dvi $*.log *.aux + rm -f $*.dvi $*.log *.aux test -f $*.gif && chmod 644 $*.gif all: ${gifs} @@ -57,7 +57,7 @@ ghostRightarrow.gif: Rightarrow.tex giftrans -g '#000000=#ffffff' |\ giftopnm |\ ppmtogif -transparent white > $*.gif - /bin/rm -f Rightarrow.dvi Rightarrow.log Rightarrow.aux + rm -f Rightarrow.dvi Rightarrow.log Rightarrow.aux test -f $*.gif && chmod 644 $*.gif -clean: ; /bin/rm -f *.gif Make.out +clean: ; rm -f *.gif Make.out diff --git a/src/ChezScheme/csug/math/Makefile b/src/ChezScheme/csug/math/Makefile index 3385fdb546..3392ea87f7 100644 --- a/src/ChezScheme/csug/math/Makefile +++ b/src/ChezScheme/csug/math/Makefile @@ -15,11 +15,11 @@ density=-r90x90 ${density} - |\ pnmcrop |\ ppmtogif -transparent white > $*.gif - /bin/rm -f $*.dvi $*.log $*.aux + rm -f $*.dvi $*.log $*.aux test -f $*.gif && chmod 644 $*.gif all: ${gifs} ${gifs}: mathmacros -clean: ; /bin/rm -f *.gif Make.out +clean: ; rm -f *.gif Make.out diff --git a/src/ChezScheme/examples/Makefile b/src/ChezScheme/examples/Makefile index b1b4e1d1d5..3edfdd05cb 100644 --- a/src/ChezScheme/examples/Makefile +++ b/src/ChezScheme/examples/Makefile @@ -25,4 +25,4 @@ needed: ${obj} all: ; echo "(time (for-each compile-file (map symbol->string '(${src}))))" | ${Scheme} -clean: ; /bin/rm -f $(obj) expr.md +clean: ; rm -f $(obj) expr.md diff --git a/src/ChezScheme/makefiles/Makefile-csug.in b/src/ChezScheme/makefiles/Makefile-csug.in index 19282c55fb..0a5dbfe85b 100644 --- a/src/ChezScheme/makefiles/Makefile-csug.in +++ b/src/ChezScheme/makefiles/Makefile-csug.in @@ -30,7 +30,7 @@ install: target # thrice is not enough when starting from scratch logcheck1: $(x).thirdrun @if [ -n "`grep 'Warning: Label(s) may have changed' $(x).log`" ] ; then\ - /bin/rm -f $(x).thirdrun ;\ + rm -f $(x).thirdrun ;\ $(MAKE) $(x).thirdrun;\ fi @@ -82,7 +82,7 @@ endif $(texsrc): $(moresrc) $(srcdir)/title.tex $(srcdir)/contents.tex $(srcdir)/bibliography.tex: - /bin/rm -f $*.tex + rm -f $*.tex echo "%%% DO NOT EDIT THIS FILE" > $*.tex echo "%%% Edit the .stex version instead" >> $*.tex echo "" >> $*.tex @@ -174,7 +174,7 @@ code: $(stexsrc) echo '(load "code" pretty-print)' | $(Scheme) -q $(x).clean: - -/bin/rm -f $(x).rfm $(x).sfm $(x).prefirstrun $(x).presecondrun\ + -rm -f $(x).rfm $(x).sfm $(x).prefirstrun $(x).presecondrun\ $(x).prethirdrun $(x).ans\ $(x).hprefirstrun $(x).hpresecondrun $(x).hprethirdrun\ tspl.aux tspl.haux tspl.rfm tspl.idx in.hidx\ diff --git a/src/ChezScheme/makefiles/Makefile-release_notes.in b/src/ChezScheme/makefiles/Makefile-release_notes.in index 4435b6fb29..64348a43c3 100644 --- a/src/ChezScheme/makefiles/Makefile-release_notes.in +++ b/src/ChezScheme/makefiles/Makefile-release_notes.in @@ -38,7 +38,7 @@ install: $x.pdf $x.html $(INSTALL) -m 2755 -d $(installdir)/gifs $(INSTALL) -m 0644 --ifdiff gifs/*.gif $(installdir)/gifs $(INSTALL) -m 2755 -d $(installdir)/math - -/bin/rm -rf $(installdir)/$(mathdir) + -rm -rf $(installdir)/$(mathdir) $(INSTALL) -m 2755 -d $(installdir)/$(mathdir) if [ -e $(mathdir)/0.gif ] ; then $(INSTALL) -m 0644 $(mathdir)/*.gif $(installdir)/$(mathdir) ; fi diff --git a/src/ChezScheme/makefiles/Makefile-workarea.in b/src/ChezScheme/makefiles/Makefile-workarea.in index 34204df995..43327e31d7 100644 --- a/src/ChezScheme/makefiles/Makefile-workarea.in +++ b/src/ChezScheme/makefiles/Makefile-workarea.in @@ -32,7 +32,14 @@ uninstall: .PHONY: test test: build (cd mats && $(MAKE) allx) - @echo "test run complete. check $(PREFIX)mats/summary for errors." + +.PHONY: test-some +test-some: build + (cd mats && $(MAKE) partialx) + +.PHONY: test-more +test-more: build + (cd mats && $(MAKE) bullyx) .PHONY: coverage coverage: diff --git a/src/ChezScheme/makefiles/Mf-install.in b/src/ChezScheme/makefiles/Mf-install.in index 05b968eb9c..56074a5eaf 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.58 +Version=csv9.5.5.5 Include=boot/$m PetiteBoot=boot/$m/petite.boot SchemeBoot=boot/$m/scheme.boot @@ -107,6 +107,9 @@ scheme.1 petite.1: scheme.1.in I=./installsh -o "${InstallOwner}" -g "${InstallGroup}" bininstall: ${Bin} + rm -f ${SchemePath} + rm -f ${PetitePath} + rm -f ${SchemeScriptPath} $I -m 555 ${Scheme} ${SchemePath} ln -f ${SchemePath} ${PetitePath} ln -f ${SchemePath} ${SchemeScriptPath} @@ -114,12 +117,12 @@ bininstall: ${Bin} libbininstall: ${LibBin} $I -m 444 ${PetiteBoot} ${LibBin}/petite.boot if [ "${InstallPetiteName}" != "petite" ]; then\ - /bin/rm -f ${LibBin}/${InstallPetiteName}.boot;\ + rm -f ${LibBin}/${InstallPetiteName}.boot;\ ln -f ${LibBin}/petite.boot ${LibBin}/${InstallPetiteName}.boot;\ fi $I -m 444 ${SchemeBoot} ${LibBin}/scheme.boot;\ if [ "${InstallSchemeName}" != "scheme" ]; then\ - /bin/rm -f ${LibBin}/${InstallSchemeName}.boot;\ + rm -f ${LibBin}/${InstallSchemeName}.boot;\ ln -f ${LibBin}/scheme.boot ${LibBin}/${InstallSchemeName}.boot;\ fi ln -f ${LibBin}/scheme.boot ${LibBin}/${InstallScriptName}.boot; diff --git a/src/ChezScheme/makefiles/installsh b/src/ChezScheme/makefiles/installsh index 48f1e4673f..95d85fb47d 100755 --- a/src/ChezScheme/makefiles/installsh +++ b/src/ChezScheme/makefiles/installsh @@ -1,7 +1,8 @@ #! /bin/sh if [ -x /bin/true ]; then TRUE=/bin/true; elif [ -x /usr/bin/true ]; then TRUE=/usr/bin/true; -else echo "Can't find /bin/true or /usr/bin/true" ; exit 1; +elif command -v true &> /dev/null; then TRUE=true; +else echo "Can't find /bin/true or /usr/bin/true and no true command" ; exit 1; fi while ${TRUE} ; do diff --git a/src/ChezScheme/mats/4.ms b/src/ChezScheme/mats/4.ms index 091fb925c1..18c1f037a0 100644 --- a/src/ChezScheme/mats/4.ms +++ b/src/ChezScheme/mats/4.ms @@ -3808,6 +3808,19 @@ (lambda () (set! did (cons 'out did))))] [else did])))) + ;; regression test to make sure the compiler doesn't run out of + ;; registers: + (procedure? (lambda (f a b c) + (#3%call-with-values + (lambda () + (#3%call-with-values + (lambda () + (call-setting-continuation-attachment + 1024 + (lambda () + (#3%$app f a b c)))) + fx+/carry)) + f))) ) ;;; section 4-7: @@ -4210,7 +4223,7 @@ (let loop ([tries 3]) (or (< (/ (measure-guardian-chain-time 10000 get-key ordered?) (measure-guardian-chain-time 1000 get-key ordered?)) - 20) + 50) (and (positive? tries) (loop (sub1 tries)))))) @@ -4807,7 +4820,7 @@ ;; ---------------------------------------- ;; Check interaction of mutation and incremental generation promotion - (with-interrupts-disabled + (parameterize ([collect-request-handler void] [collect-maximum-generation (max (collect-maximum-generation) 2)]) (let ([key "key"]) (let ([e (ephemeron-cons key #f)]) (collect 0 1 1) diff --git a/src/ChezScheme/mats/5_3.ms b/src/ChezScheme/mats/5_3.ms index e7905b2d30..6f325ab5a8 100644 --- a/src/ChezScheme/mats/5_3.ms +++ b/src/ChezScheme/mats/5_3.ms @@ -806,6 +806,14 @@ (equal? (number->string #x100 16) "100") (equal? (number->string #x100 8) "400") (equal? (number->string #x100 16) "100") + (equal? (number->string (* 10 (+ 10 (expt 2 100))) 16) + "A0000000000000000000000064") + (equal? (number->string (* 10 (+ 10 (expt 2 100))) 8) + "24000000000000000000000000000000144") + (equal? (number->string (* 10 (+ 10 (expt 2 100))) 4) + "2200000000000000000000000000000000000000000000001210") + (equal? (number->string (* 10 (+ 10 (expt 2 100))) 2) + "10100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001100100") ) (mat r6rs:number->string @@ -1682,6 +1690,16 @@ (and (exact? x) (exact? y)) (or (inexact? x) (inexact? y))) (g (+ j 1))))))))) + (let ([sb* (foreign-procedure + "(cs)mul" (scheme-object scheme-object) scheme-object)]) + ;; (expt 2 100000) is big enough that all multiplication algorithms + ;; are exercised + ;; we add a power of 3 so that the number isn't too simple + (eqv? (sb* (+ 1 (expt 3 50) (expt 2 100000)) + 3) + (* (+ 1 (expt 3 50) (expt 2 100000)) + 3))) + (error? ; #f is not a fixnum (* 3 #f)) (error? ; #f is not a fixnum @@ -1716,6 +1734,12 @@ (eqv? (/ 1 -2) -1/2) (eqv? (/ 1/2 -2) -1/4) (eqv? (/ 1 -1/2) -2) + (eqv? (/ 1 -1/2) -2) + (eqv? (/ -1 -1/2) 2) + (eqv? (/ 1 3/2) 2/3) + (eqv? (/ -1 3/2) -2/3) + (eqv? (/ 1 -3/2) -2/3) + (eqv? (/ -1 -3/2) 2/3) (fl~= (/ 1.0 2) 0.5) (fl~= (/ 1 2.0) 0.5) (eqv? (/ 0 2.0) 0) @@ -1779,6 +1803,9 @@ (eqv? (/ 1e-300+1e-300i (* 4 #e1e-300+1e-300i)) 0.25+0.0i) (eqv? (/ 0.0+0.0i 1+1e-320i) 0.0+0.0i) (eqv? (/ 0.0+0.0i #e1+1e-320i) 0.0+0.0i) + (eqv? (/ (expt 7 150000) (expt 7 100000)) (expt 7 50000)) + (eqv? (/ (- (expt 7 150000)) (expt 7 100000)) (- (expt 7 50000))) + (eqv? (/ (expt 7 150000) (- (expt 7 100000))) (- (expt 7 50000))) (test-cp0-expansion eqv? '(/ 1 2) 1/2) (test-cp0-expansion eqv? '(/ 1 -2) -1/2) (test-cp0-expansion eqv? '(/ 1/2 -2) -1/4) @@ -2071,6 +2098,7 @@ (fl= (quotient 3.0 -2.0) -1.0) (fl= (quotient -3.0 -2.0) 1.0) (fl= (quotient -3.0 2) -1.0) + (eqv? (quotient (expt 7 150000) (expt 7 100000)) (expt 7 50000)) ;; following returns incorrect result in all versions prior to 5.9b (eq? (quotient (most-negative-fixnum) (- (most-negative-fixnum))) -1) ) @@ -2120,6 +2148,9 @@ (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 (sub1 (expt 7 150000)) (expt 7 100000)) (sub1 (expt 7 100000))) + (eqv? (remainder (- (sub1 (expt 7 150000))) (expt 7 100000)) (- (sub1 (expt 7 100000)))) + (eqv? (remainder (sub1 (expt 7 150000)) (- (expt 7 100000))) (sub1 (expt 7 100000))) ;; following returns incorrect result with naive algorithm, ;; i.e., remainder = (lambda (x,y) (- x (* (quotient x y) y))) (fl= (remainder 1e194 10.0) 8.0) @@ -2168,6 +2199,9 @@ (eqv? (modulo (exact -5.842423430828094e+60) 10) 6) (eqv? (modulo (exact 5.842423430828094e+60) -10) -6) (eqv? (modulo (exact -5.842423430828094e+60) -10) -4) + (eqv? (modulo (sub1 (expt 7 150000)) (expt 7 100000)) (sub1 (expt 7 100000))) + (eqv? (modulo (- (sub1 (expt 7 150000))) (expt 7 100000)) 1) + (eqv? (modulo (sub1 (expt 7 150000)) (- (expt 7 100000))) -1) ) (mat truncate @@ -2836,6 +2870,7 @@ (~= (sqrt 5-12i) (sqrt 5.0-12.0i)) (~= (sqrt -5-12i) (sqrt -5.0-12.0i)) (~= (sqrt 1e38) (sqrt #e1e38)) + (~= (sqrt -1.0-0.0i) 0.0-1.0i) ) (mat isqrt @@ -2898,6 +2933,7 @@ (error? (sin 3 4)) (error? (sin 'a)) (fl~= (sin (/ pi 6)) 0.5) + (~= (sin 1e-30+1e-40i) 1e-30+1e-40i) ) (mat cos @@ -2920,6 +2956,7 @@ (error? (tan 'a)) (fl~= (tan (/ pi 4)) 1.0) (let ([x 4.4]) (~= (tan x) (/ (sin x) (cos x)))) + (~= (tan 1e-30+1e-40i) 1e-30+1e-40i) (fluid-let ([*fuzz* 3e-12]) (let ([x 4.4-5.5i]) (cfl~= (tan x) (/ (sin x) (cos x))))) ) @@ -2993,7 +3030,8 @@ (let ([s (sinh x)]) (~= (* s s) (* 1/2 (- (cosh (* 2 x)) 1))))) (let ([x 5.4+4.5i]) (let ([s (sinh x)]) - (~= (* s s s) (* 1/4 (+ (* -3 (sinh x)) (sinh (* 3 x))))))) + (~= (* s s s) (* 1/4 (+ (* -3 (sinh x)) (sinh (* 3 x))))))) + (~= (sinh 1e-30+1e-40i) 1e-30+1e-40i) ) (mat cosh @@ -3025,6 +3063,7 @@ (fluid-let ([*fuzz* 1e-13]) (let ([x 3-2i]) (~= (tanh x) (/ (sinh x) (cosh x))))) (let ([x 5.4+4.5i]) (~= (tanh (* +i x)) (* +i (tan x)))) + (~= (tanh 1e-30+1e-40i) 1e-30+1e-40i) ) @@ -3282,6 +3321,7 @@ (eqv? (bitwise-arithmetic-shift 0 (- (expt 2 100))) 0) (eqv? (bitwise-arithmetic-shift 0 (expt 2 100)) 0) (eqv? (bitwise-arithmetic-shift 0 (expt 2 100)) 0) + (eqv? (- (expt 16 232)) (bitwise-arithmetic-shift (- 307 (expt 16 240)) -32)) ($test-right-shift (lambda (x n) (bitwise-arithmetic-shift x (- n)))) ) @@ -3330,6 +3370,7 @@ (eqv? (bitwise-arithmetic-shift-right #x-8000000000000000 31) #x-100000000) (eqv? (bitwise-arithmetic-shift-right #x-8000000000000000 32) #x-80000000) (eqv? (bitwise-arithmetic-shift-right #x-8000000000000000 33) #x-40000000) + (eqv? (- (expt 16 232)) (bitwise-arithmetic-shift-right (- 307 (expt 16 240)) 32)) ($test-right-shift (lambda (x n) (bitwise-arithmetic-shift-right x n))) ) @@ -7228,4 +7269,4 @@ (eqv? 16 (fxpopcount #b1111111111111111)) (eqv? 16 (fxpopcount32 #b1111111111111111)) (eqv? 16 (fxpopcount16 #b1111111111111111)) -) + ) diff --git a/src/ChezScheme/mats/5_4.ms b/src/ChezScheme/mats/5_4.ms index b41dd3bf8f..bd13726525 100644 --- a/src/ChezScheme/mats/5_4.ms +++ b/src/ChezScheme/mats/5_4.ms @@ -992,7 +992,7 @@ (error? (string-normalize-nfkc "hello" "goodbye")) (error? (string-normalize-nfkc 'ouch)) (begin - (load "../unicode/unicode-data.ss") + (load (format "~a/../unicode/unicode-data.ss" *mats-dir*)) #t) (let () (import (unicode-data)) @@ -1014,7 +1014,7 @@ (let ([data (map (lambda (x) (map conv (list-head x 5))) (filter (lambda (x) (>= (length x) 5)) (get-unicode-data - "../unicode/UNIDATA/NormalizationTest.txt")))]) + (format "~a/../unicode/UNIDATA/NormalizationTest.txt" *mats-dir*))))]) (define NFD string-normalize-nfd) (define NFKD string-normalize-nfkd) (define NFC string-normalize-nfc) diff --git a/src/ChezScheme/mats/5_6.ms b/src/ChezScheme/mats/5_6.ms index bd4afe218b..6b7f07dd56 100644 --- a/src/ChezScheme/mats/5_6.ms +++ b/src/ChezScheme/mats/5_6.ms @@ -1405,7 +1405,10 @@ (error? (vector-cas! vec1 vec1 2 3)) ; not a fixnum (error? (vector-cas! vec1 (expt 2 100) 2 3)) ; not a fixnum (error? (vector-cas! vec1 -1 2 3)) ; out of range + (error? (vector-cas! vec1 -2 2 3)) ; out of range (error? (vector-cas! vec1 5 2 3)) ; out of range + (error? (vector-cas! vec1 (expt 2 26) 2 3)) ; out of range + (error? (vector-cas! vec1 (expt 2 40) 2 3)) ; out of range ;; make sure `vector-cas!` works with GC generations: (begin diff --git a/src/ChezScheme/mats/6.ms b/src/ChezScheme/mats/6.ms index 3fcf385e99..3ce48ffafd 100644 --- a/src/ChezScheme/mats/6.ms +++ b/src/ChezScheme/mats/6.ms @@ -15,6 +15,8 @@ ;;; sections 6-1 and 6-2: +(define prettytest.ss (format "~a/prettytest.ss" *mats-dir*)) + (mat current-input-port (port? (current-input-port)) (input-port? (current-input-port)) @@ -422,21 +424,21 @@ mode2)) mode1)))) (and - (cmp '() "prettytest.ss" '() "prettytest.ss") - (cmp '(compressed) "prettytest.ss" '() "prettytest.ss") - (cmp '() "prettytest.ss" '(compressed) "prettytest.ss") - (cmp '(compressed) "prettytest.ss" '(compressed) "prettytest.ss") + (cmp '() prettytest.ss '() prettytest.ss) + (cmp '(compressed) prettytest.ss '() prettytest.ss) + (cmp '() prettytest.ss '(compressed) prettytest.ss) + (cmp '(compressed) prettytest.ss '(compressed) prettytest.ss) (begin - (cp '(replace compressed) "prettytest.ss" "testfile.ss") + (cp '(replace compressed) prettytest.ss "testfile.ss") #t) - (cmp '(compressed) "testfile.ss" '() "prettytest.ss") - (not (= (call-with-input-file "testfile.ss" file-length) (call-with-input-file "prettytest.ss" file-length))) + (cmp '(compressed) "testfile.ss" '() prettytest.ss) + (not (= (call-with-input-file "testfile.ss" file-length) (call-with-input-file prettytest.ss file-length))) ; the following test could cause an error with anything but latin-1 codec - #;(not (cmp '() "testfile.ss" '() "prettytest.ss")) + #;(not (cmp '() "testfile.ss" '() prettytest.ss)) (begin - (cp '(compressed append) "prettytest.ss" "testfile.ss") + (cp '(compressed append) prettytest.ss "testfile.ss") #t) - (not (cmp '(compressed) "testfile.ss" '() "prettytest.ss")) + (not (cmp '(compressed) "testfile.ss" '() prettytest.ss)) )) (error? (open-output-file "testfile.ss" '(replace append))) (error? (open-output-file "testfile.ss" '(append truncate))) @@ -819,8 +821,8 @@ (lambda () (close-input-port ip) (close-output-port op)))))]) - (pretty-copy "prettytest.ss" "testfile.ss")) - (let ([p1 (open-input-file "prettytest.ss")] + (pretty-copy prettytest.ss "testfile.ss")) + (let ([p1 (open-input-file prettytest.ss)] [p2 (open-input-file "testfile.ss")]) (dynamic-wind (lambda () #f) @@ -877,8 +879,8 @@ (lambda () (close-input-port ip) (close-output-port op)))))]) - (unpretty-copy "prettytest.ss" "testfile.ss")) - (let ([p1 (open-input-file "prettytest.ss")] + (unpretty-copy prettytest.ss "testfile.ss")) + (let ([p1 (open-input-file prettytest.ss)] [p2 (open-input-file "testfile.ss")]) (dynamic-wind (lambda () #f) @@ -921,7 +923,7 @@ (lambda (p) (fasl-write +nan.0 p))) (call-with-port (open-file-input-port "testfile.ss") fasl-read)) (/ 0.0 0.0)) - (let ([ls (with-input-from-file "prettytest.ss" + (let ([ls (with-input-from-file prettytest.ss (rec f (lambda () (let ([x (read)]) @@ -971,8 +973,8 @@ (open-bytevector-input-port (call-with-bytevector-output-port put-stuff)) (get-stuff fasl-read))))) - (eqv? (fasl-file "prettytest.ss" "testfile.ss") (void)) - (let ([ls (with-input-from-file "prettytest.ss" + (eqv? (fasl-file prettytest.ss "testfile.ss") (void)) + (let ([ls (with-input-from-file prettytest.ss (rec f (lambda () (let ([x (read)]) @@ -1731,6 +1733,30 @@ (lambda () (close-input-port ip))))]) vals) '(atomic eat 1 4)) + (equal? + (call-with-values (lambda () (with-input-from-string "#t" read-token)) list) + '(atomic #t 0 2)) + (equal? + (call-with-values (lambda () (with-input-from-string "#true" read-token)) list) + '(atomic #t 0 5)) + (equal? + (call-with-values (lambda () (with-input-from-string "#True" read-token)) list) + '(atomic #t 0 5)) + (equal? + (call-with-values (lambda () (with-input-from-string "#TRUE" read-token)) list) + '(atomic #t 0 5)) + (equal? + (call-with-values (lambda () (with-input-from-string "#f" read-token)) list) + '(atomic #f 0 2)) + (equal? + (call-with-values (lambda () (with-input-from-string "#false" read-token)) list) + '(atomic #f 0 6)) + (equal? + (call-with-values (lambda () (with-input-from-string "#False" read-token)) list) + '(atomic #f 0 6)) + (equal? + (call-with-values (lambda () (with-input-from-string "#FALSE" read-token)) list) + '(atomic #f 0 6)) ) (define read-test @@ -1863,6 +1889,11 @@ "; Test error \"unexpected end-of-file reading character\"\n#\\" "; Test error \"unexpected end-of-file reading character\"\n#\\new" "; Test error \"unexpected end-of-file reading character\"\n#\\02" + "; Test error \"unexpected end-of-file reading boolean\"\n\n#tr" + "; Test error \"unexpected end-of-file reading boolean\"\n\n#tru" + "; Test error \"unexpected end-of-file reading boolean\"\n\n#fa" + "; Test error \"unexpected end-of-file reading boolean\"\n\n#fal" + "; Test error \"unexpected end-of-file reading boolean\"\n\n#fals" "; Test error \"unexpected end-of-file reading expression comment\"\n\n(define oops '#; ; that's all I've got!\n" "; Test error \"unexpected end-of-file reading gensym\"\n(pretty-print '#{" "; Test error \"unexpected end-of-file reading gensym\"\n(pretty-print '#{foo" @@ -1931,6 +1962,13 @@ "; Test error \"octal character syntax not allowed in #!r6rs mode\"\n\n#!r6rs #\\010\n" "; Test error \"invalid delimiter 1 for character\"\n\n#\\0001\n" "; Test error \"delimiter { is not allowed in #!r6rs mode\"\n\n#!r6rs #\\0{\n" + "; Test error \"invalid delimiter 2 for boolean\"\n\n#t2\n" + "; Test error \"invalid delimiter 2 for boolean\"\n\n#true2\n" + "; Test error \"invalid delimiter 3 for boolean\"\n\n#f3\n" + "; Test error \"invalid delimiter 3 for boolean\"\n\n#false3\n" + "; Test error \"invalid boolean\"\n\n#travis" + "; Test error \"invalid boolean\"\n\n#FALSIFY" + ;; NOTE: there's no "delimiter not allowed in #!r6rs mode" test for r7rs-style booleans because they are not r6rs! "; Test error \"#!eof syntax not allowed in #!r6rs mode\"\n\n#!r6rs #!eof\n" "; Test error \"#!bwp syntax not allowed in #!r6rs mode\"\n\n#!r6rs #!bwp\n" "; Test error \"#vfx(...) fxvector syntax not allowed in #!r6rs mode\"\n\n#!r6rs '#vfx(1 2 3)\n" @@ -1944,7 +1982,12 @@ "; Test error \"123# number syntax not allowed in #!r6rs mode\"\n\n#!r6rs 123#\n" "; Test error \"#x1/2e2 number syntax not allowed in #!r6rs mode\"\n\n#!r6rs 1/2e2\n" "; Test error \"#x.3 number syntax not allowed in #!r6rs mode\"\n\n#!r6rs #x.3\n" - + "; Test error \"alternative boolean syntax not allowed in #!r6rs mode\"\n\n#!r6rs #true\n" + "; Test error \"alternative boolean syntax not allowed in #!r6rs mode\"\n\n#!r6rs #True\n" + "; Test error \"alternative boolean syntax not allowed in #!r6rs mode\"\n\n#!r6rs #TRUE\n" + "; Test error \"alternative boolean syntax not allowed in #!r6rs mode\"\n\n#!r6rs #false\n" + "; Test error \"alternative boolean syntax not allowed in #!r6rs mode\"\n\n#!r6rs #False\n" + "; Test error \"alternative boolean syntax not allowed in #!r6rs mode\"\n\n#!r6rs #FALSE\n" ; following tests adapted from the read0 benchmark distributed by Will ; Clinger, which as of 08/08/2009 appears to be in the public domain, ; with no license, copyright notice, author name, or date. @@ -2573,9 +2616,13 @@ (close-output-port p) #t) (begin + (define make-sure-this-symbol-stays '#{%foo %bar}) (load "testfile.ss") #t) (record? (cadr $$rats) (type-descriptor #{%foo %bar})) + (begin + (define make-sure-this-symbol-stays #f) + #t) (let ([r (cadr $$rats)]) (eq? (%foo-x r) (car $$rats)) (equal? (%foo-y r) '(d e))) @@ -2652,8 +2699,8 @@ (eq? '\x23;foo\x7C;bar '\#foo\|bar) ) -(mat with-source-path - (equal? (source-directories) '(".")) +(mat with-source-path (parameters [current-directory *mats-dir*] [source-directories '(".")] [library-directories '(".")]) + (equal? (separate-eval '(source-directories)) "(\".\")\n") (equal? (with-source-path 'test "I should not be here" list) '("I should not be here")) @@ -2756,7 +2803,7 @@ (begin (system "ln -s ../examples .") (load "examples/fatfib.ss" compile) - (system "/bin/rm examples") + (system "rm -f examples") #t)) (or (windows?) (embedded?) (equal? @@ -2988,6 +3035,18 @@ (error? (get-mode "probably/not/there")) (error? (get-mode "probably/not/there" #f)) (error? (get-mode "probably/not/there" #t)) + (error? (file-access-time "probably/not/there")) + (error? (file-access-time "probably/not/there" #f)) + (error? (file-access-time "probably/not/there" #t)) + (error? (file-change-time "probably/not/there")) + (error? (file-change-time "probably/not/there" #f)) + (error? (file-change-time "probably/not/there" #t)) + (error? (file-modification-time "probably/not/there")) + (error? (file-modification-time "probably/not/there" #f)) + (error? (file-modification-time "probably/not/there" #t)) + ) + +(mat filesystem-operations2 (parameters [current-directory *mats-dir*]) (if (or (windows?) (embedded?)) (fixnum? (get-mode "mat.ss")) (let ([m (get-mode "mat.ss")]) @@ -3033,20 +3092,11 @@ (time? (file-change-time "\\\\?\\c:\\")) (time? (file-modification-time "\\\\?\\c:\\")))) (or (windows?) (embedded?) - (time=? (file-access-time "Makefile") (file-access-time (format "Mf-~a" (machine-type))))) + (time=? (file-access-time "Makefile") (file-access-time "Mf-unix"))) (or (windows?) (embedded?) - (time=? (file-change-time "Makefile") (file-change-time (format "Mf-~a" (machine-type))))) + (time=? (file-change-time "Makefile") (file-change-time "Mf-unix"))) (or (windows?) (embedded?) - (time=? (file-modification-time "Makefile") (file-modification-time (format "Mf-~a" (machine-type))))) - (error? (file-access-time "probably/not/there")) - (error? (file-access-time "probably/not/there" #f)) - (error? (file-access-time "probably/not/there" #t)) - (error? (file-change-time "probably/not/there")) - (error? (file-change-time "probably/not/there" #f)) - (error? (file-change-time "probably/not/there" #t)) - (error? (file-modification-time "probably/not/there")) - (error? (file-modification-time "probably/not/there" #f)) - (error? (file-modification-time "probably/not/there" #t)) + (time=? (file-modification-time "Makefile") (file-modification-time "Mf-unix"))) ) (mat unicode-filesystem-operations diff --git a/src/ChezScheme/mats/7.ms b/src/ChezScheme/mats/7.ms index 00de98f451..685e3d9d89 100644 --- a/src/ChezScheme/mats/7.ms +++ b/src/ChezScheme/mats/7.ms @@ -488,7 +488,7 @@ (separate-eval '(load-program "testfile-mc-foo.so")) "(\"a\" \"b\" \"c\")\n") (touch "testfile-mc-foo.so" "testfile-mc-a.ss") - ((lambda (x ls) (and (member x ls) #t)) + (equal? (let ([mt* (map file-modification-time (list "testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-foo.so"))]) (let ([s (separate-compile '(lambda (x) (parameterize ([compile-program-handler (lambda (ifn ofn) (printf "yippee!\n") (compile-program ifn ofn))] [compile-imported-libraries #t] @@ -501,8 +501,7 @@ (map file-modification-time (list "testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-foo.so")) mt*) s))) - '(((> > >) . "yippee!\n((testfile-mc-a) (testfile-mc-b))\n") - ((> > >) . "yippee!\n((testfile-mc-b) (testfile-mc-a))\n"))) + '((> > >) . "yippee!\n")) (equal? (let ([mt* (map file-modification-time (list "testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-foo.so"))]) (let ([s (separate-compile '(lambda (x) (parameterize ([compile-imported-libraries #t] [compile-file-message #f]) (maybe-compile-program x))) 'mc-foo)]) @@ -512,7 +511,7 @@ (map file-modification-time (list "testfile-mc-a.so" "testfile-mc-b.so" "testfile-mc-foo.so")) mt*) s))) - '((= = =) . "#f\n")) + '((= = =) . "")) (equal? (separate-eval '(load-program "testfile-mc-foo.so")) "(\"a\" \"b\" \"c\")\n") @@ -1122,12 +1121,12 @@ "(aye captain)\n") (equal? (begin - (unless (or (embedded?) (equal? *scheme* (format "../bin/~a/scheme~a" (machine-type) (if (windows?) ".exe" "")))) + (unless (or (embedded?) (equal? *scheme* (format "~a/bin/~a/scheme~a" (path-parent *mats-dir*) (machine-type) (if (windows?) ".exe" "")))) (errorf #f "not testing boot file based on ../boot/~a/petite.boot, since *scheme* isn't ../bin/~a/scheme~a" (machine-type) (machine-type) (if (windows?) ".exe" ""))) (parameterize ([optimize-level 2]) (make-boot-file "testfile.boot" '() - (format "../boot/~a/petite.boot" (machine-type)) + (format "~a/boot/~a/petite.boot" (path-parent *mats-dir*) (machine-type)) "testfile-1.so" "testfile-2.so" "testfile-3.ss" @@ -1153,7 +1152,7 @@ (case (machine-type) [(pb) #t] [else #f]) ; no callables in pb (equal? (begin - (unless (or (embedded?) (equal? *scheme* (format "../bin/~a/scheme~a" (machine-type) (if (windows?) ".exe" "")))) + (unless (or (embedded?) (equal? *scheme* (format "~a/bin/~a/scheme~a" (path-parent *mats-dir*) (machine-type) (if (windows?) ".exe" "")))) (errorf #f "not testing boot file based on ../boot/~a/petite.boot, since *scheme* isn't ../bin/~a/scheme~a" (machine-type) (machine-type) (if (windows?) ".exe" ""))) (mkfile "testfile.ss" @@ -6143,16 +6142,17 @@ evaluating module init (>= (collections) 0) (>= (bytes-deallocated) 0) (let ([b (bytes-deallocated)] [c (collections)]) - (let ([x (make-list 10 'a)]) - (pretty-print x) - (collect) - (and (> (collections) c) (> (bytes-deallocated) b)))) + (with-interrupts-disabled ; ensure allocated list stays in generation 0 until printed + (let ([x (make-list 10 'a)]) + (pretty-print x)) + (collect)) + (and (> (collections) c) (> (bytes-deallocated) b))) (>= (bytes-allocated #f #f) 0) (andmap (lambda (space) (>= (bytes-allocated #f space) 0)) (#%$spaces)) (let () - (define fudge 2000) + (define fudge (if (positive? (heap-check-interval)) 4000 2000)) (define ~= (lambda (x y) (<= (abs (- x y)) fudge))) diff --git a/src/ChezScheme/mats/8.ms b/src/ChezScheme/mats/8.ms index c0519eead2..9408eeaa84 100644 --- a/src/ChezScheme/mats/8.ms +++ b/src/ChezScheme/mats/8.ms @@ -10606,7 +10606,9 @@ (separate-compile 'imno1) #t) (equal? - (parameterize ([console-output-port (open-output-string)]) + (parameterize ([source-directories '(".")] + [library-directories '(".")] + [console-output-port (open-output-string)]) (eval '(lambda () (import (testfile-imno2)) y)) (get-output-string (console-output-port))) "import: did not find source file \"testfile-imno2.chezscheme.sls\"\nimport: found source file \"testfile-imno2.ss\"\nimport: did not find corresponding object file \"testfile-imno2.so\"\nimport: loading source file \"testfile-imno2.ss\"\nimport: did not find source file \"testfile-imno1.chezscheme.sls\"\nimport: found source file \"testfile-imno1.ss\"\nimport: found corresponding object file \"testfile-imno1.so\"\nimport: object file is not older\nimport: visiting object file \"testfile-imno1.so\"\nattempting to 'revisit' previously 'visited' \"testfile-imno1.so\" for library (testfile-imno1) run-time info\n") diff --git a/src/ChezScheme/mats/Mf-a6fb b/src/ChezScheme/mats/Mf-a6fb deleted file mode 100644 index 8876bcf9c5..0000000000 --- a/src/ChezScheme/mats/Mf-a6fb +++ /dev/null @@ -1,27 +0,0 @@ -# Mf-a6fb -# 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 ?= a6fb - -fsrc = foreign1.c foreign2.c foreign3.c foreign4.c -fobj = foreign1.so - -include Mf-base - -foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -fPIC ${threadFlags} -shared -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-a6le b/src/ChezScheme/mats/Mf-a6le deleted file mode 100644 index 77515234fe..0000000000 --- a/src/ChezScheme/mats/Mf-a6le +++ /dev/null @@ -1,27 +0,0 @@ -# Mf-a6le -# 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 ?= a6le - -fsrc = foreign1.c foreign2.c foreign3.c foreign4.c -fobj = foreign1.so - -include Mf-base - -foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -m64 -fPIC ${threadFlags} -shared -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-a6nb b/src/ChezScheme/mats/Mf-a6nb deleted file mode 100644 index 4f15762dff..0000000000 --- a/src/ChezScheme/mats/Mf-a6nb +++ /dev/null @@ -1,27 +0,0 @@ -# Mf-a6nb -# 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 ?= a6nb - -fsrc = foreign1.c foreign2.c foreign3.c foreign4.c -fobj = foreign1.so - -include Mf-base - -foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -fPIC ${threadFlags} -shared -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-a6nt b/src/ChezScheme/mats/Mf-a6nt index 9c6e07c75e..ea6e67896d 100644 --- a/src/ChezScheme/mats/Mf-a6nt +++ b/src/ChezScheme/mats/Mf-a6nt @@ -1,5 +1,5 @@ # Mf-a6nt -# Copyright 1984-2017 Cisco Systems, Inc. +# Copyright 1984-2021 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. @@ -13,7 +13,6 @@ # See the License for the specific language governing permissions and # limitations under the License. -m ?= a6nt fsrc = foreign1.c foreign2.c foreign3.c foreign4.c fobj = foreign1.so @@ -24,7 +23,7 @@ include Mf-base export MSYS_NO_PATHCONV=1 foreign1.so: $(fsrc) - cmd.exe /c "vs.bat amd64 && cl /DWIN32 /DX86_64 /Fe$@ /I${Include} /LD /MD /nologo ../bin/$m/csv953.lib $(fsrc)" + cmd.exe /c "vs.bat amd64 && cl /DWIN32 /DX86_64 /Fe$@ /I${Include} /LD /MD /nologo ../bin/$m/csv955.lib $(fsrc)" -cat_flush: cat_flush.c +cat_flush.exe: cat_flush.c cmd.exe /c "vs.bat amd64 && cl /DWIN32 /DX86_64 /MD /nologo $<" diff --git a/src/ChezScheme/mats/Mf-a6ob b/src/ChezScheme/mats/Mf-a6ob deleted file mode 100644 index 01c2b5b27c..0000000000 --- a/src/ChezScheme/mats/Mf-a6ob +++ /dev/null @@ -1,27 +0,0 @@ -# Mf-a6ob -# 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 ?= a6ob - -fsrc = foreign1.c foreign2.c foreign3.c foreign4.c -fobj = foreign1.so - -include Mf-base - -foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -fPIC ${threadFlags} -shared -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-a6osx b/src/ChezScheme/mats/Mf-a6osx deleted file mode 100644 index bdbe8e6d5c..0000000000 --- a/src/ChezScheme/mats/Mf-a6osx +++ /dev/null @@ -1,27 +0,0 @@ -# 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 ?= a6osx - -fsrc = foreign1.c foreign2.c foreign3.c foreign4.c -fobj = foreign1.so - -include Mf-base - -foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -m64 -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-a6s2 b/src/ChezScheme/mats/Mf-a6s2 deleted file mode 100644 index 5e26b0bcc4..0000000000 --- a/src/ChezScheme/mats/Mf-a6s2 +++ /dev/null @@ -1,27 +0,0 @@ -# Mf-a6s2 -# 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 ?= a6s2 - -fsrc = foreign1.c foreign2.c foreign3.c foreign4.c -fobj = foreign1.so - -include Mf-base - -foreign1.so: ${fsrc} ../boot/$m/scheme.h - gcc -m64 ${threadFlags} -fPIC -shared -I${Include} -o foreign1.so ${fsrc} - -cat_flush: cat_flush.c - gcc -o cat_flush cat_flush.c diff --git a/src/ChezScheme/mats/Mf-arm32le b/src/ChezScheme/mats/Mf-arm32le deleted file mode 100644 index da910c7e40..0000000000 --- a/src/ChezScheme/mats/Mf-arm32le +++ /dev/null @@ -1,27 +0,0 @@ -# Mf-arm32le -# 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 ?= arm32le - -fsrc = foreign1.c foreign2.c foreign3.c foreign4.c -fobj = foreign1.so - -include Mf-base - -foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -fPIC -shared -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-arm64le b/src/ChezScheme/mats/Mf-arm64le deleted file mode 100644 index d2771a467d..0000000000 --- a/src/ChezScheme/mats/Mf-arm64le +++ /dev/null @@ -1,27 +0,0 @@ -# Mf-arm64le -# 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 ?= arm64le - -fsrc = foreign1.c foreign2.c foreign3.c foreign4.c -fobj = foreign1.so - -include Mf-base - -foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -fPIC -shared -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 74007de5df..a4b9e1a315 100644 --- a/src/ChezScheme/mats/Mf-base +++ b/src/ChezScheme/mats/Mf-base @@ -1,5 +1,5 @@ # Mf-base -# Copyright 1984-2017 Cisco Systems, Inc. +# Copyright 1984-2021 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. @@ -18,14 +18,20 @@ # Running "make" or "make all" in this directory runs the mats (test # programs) and produces a report of bugs and errors. Unless you make # changes to the mats or to the system, the report file report-$(conf) -# (where $(conf) is set below) +# (where $(conf) is set below) will be output in the $(outdir) directory. # If an error or bug report occurs, refer to the offending ".mo" file # produced by the mats and mentioned in the bug or error report to # determine what failed. -# Running "make allx" runs a set of mats with various settings. -# "make bullyx" runs a different, more stressful set. +# Running "make allx" runs a set of mats with various settings. "make +# bullyx" runs a different, more stressful set. These targets allow make +# to run the various configurations in parallel (if so configured, e.g. +# with the -j flag). Most output from each parallel execution is directed +# to (separate) files, with status printed to stdout when testing of each +# different configuration begins and ends. In addition, each target +# concatenates the summary file from all configurations run into "summary" +# in the current directory. # Running make with the argument "clean" removes the .so files, .mo # files, report files, and temporary files generated by the mats. @@ -36,6 +42,8 @@ include Mf-config +MatsDir = $(abspath .) + ifeq (${OS},Windows_NT) dirsep = ; else @@ -52,8 +60,8 @@ endif # Scheme is the scheme executable to test, SCHEMEHEAPDIRS tells # it where to find its boot files, and CHEZSCHEMELIBDIRS tells # it where to find libraries. -Scheme = ../bin/$m/scheme${ExeSuffix} -export SCHEMEHEAPDIRS=.${dirsep}../boot/%m +Scheme = $(abspath ../bin/$m/scheme${ExeSuffix}) +export SCHEMEHEAPDIRS=.${dirsep}$(abspath ../boot)/%m export CHEZSCHEMELIBDIRS=. # Include is the directory holding scheme.h. @@ -138,17 +146,20 @@ defaultc = f c = $(defaultc) # set of coverage files to load -coverage-files = ../boot/$m/petite.covin ../boot/$m/scheme.covin +coverage-files = $(abspath ../boot/$m/petite.covin ../boot/$m/scheme.covin) # set of mats to run mats = primvars 3 4 5_1 5_2 5_3 5_4 5_5 bytevector thread profile\ misc cp0 cptypes 5_6 5_7 5_8 6 io format 7 record hash enum 8 fx fl cfl foreign\ ftype unix windows examples ieee date exceptions oop -Examples = ../examples +Examples = $(abspath ../examples) MAKEFLAGS += --no-print-directory +# directory where (most) output for this run will be written +outdir=. + conf = $(eval)-$o-$(spi)-$(cp0)-$(cis) objdir=output-$(conf) objname = $(mats:%=%.mo) @@ -162,25 +173,32 @@ prettysrc = 3.ms 5_3.ms 5_4.ms 5_5.ms bytevector.ms thread.ms profile.ms\ fx.ms fl.ms cfl.ms foreign.ms unix.ms windows.ms examples.ms ieee.ms date.ms\ exceptions.ms +define conf-scheme-code + '(optimize-level $o)'\ + '(#%$$suppress-primitive-inlining #${spi})'\ + '(heap-check-interval ${hci})'\ + '(#%$$enable-check-prelex-flags #${ecpf})'\ + '(compile-profile #$p)'\ + '(collect-notify #${cn})'\ + '(collect-trip-bytes ${ctb})'\ + '(collect-generation-radix ${cgr})'\ + '(collect-maximum-generation ${cmg})'\ + '(in-place-minimum-generation ${ipmg})'\ + '(enable-object-counts #${eoc})'\ + '(commonization-level ${cl})'\ + '(release-minimum-generation ${rmg})'\ + '(compile-interpret-simple #${cis})'\ + '(set! *examples-directory* "${Examples}")'\ + '(enable-cp0 #${cp0})'\ + '(set! *scheme* "${Scheme}")'\ + '(set! *mats-dir* "${MatsDir}")'\ + '(set! $$cat_flush "${MatsDir}/cat_flush${ExeSuffix}")'\ + '(current-eval ${eval})'\ + '(when #$c (coverage-table (load-coverage-files ${coverage-files:%="%"})))' +endef + $(objdir)/%.mo : %.ms mat.so - echo '(optimize-level $o)'\ - '(#%$$suppress-primitive-inlining #${spi})'\ - '(heap-check-interval ${hci})'\ - '(#%$$enable-check-prelex-flags #${ecpf})'\ - '(compile-profile #$p)'\ - '(collect-notify #${cn})'\ - '(collect-trip-bytes ${ctb})'\ - '(collect-generation-radix ${cgr})'\ - '(collect-maximum-generation ${cmg})'\ - '(in-place-minimum-generation ${ipmg})'\ - '(enable-object-counts #${eoc})'\ - '(commonization-level ${cl})'\ - '(compile-interpret-simple #${cis})'\ - '(set! *examples-directory* "${Examples}")'\ - '(enable-cp0 #${cp0})'\ - '(set! *scheme* "${Scheme}")'\ - '(current-eval ${eval})'\ - '(when #$c (coverage-table (load-coverage-files ${coverage-files:%="%"})))'\ + echo $(conf-scheme-code)\ '(time ((mat-file "$(objdir)") "$*"))'\ '(unless (= (#%$$check-heap-errors) 0)'\ ' (fprintf (console-error-port) "check heap detected errors---grep standard output for !!!\n")'\ @@ -189,60 +207,44 @@ $(objdir)/%.mo : %.ms mat.so # same as above except puts the .mo file in . %.mo : %.ms mat.so - echo '(optimize-level $o)'\ - '(#%$$suppress-primitive-inlining #${spi})'\ - '(heap-check-interval ${hci})'\ - '(#%$$enable-check-prelex-flags #${ecpf})'\ - '(compile-profile #$p)'\ - '(collect-notify #${cn})'\ - '(collect-trip-bytes ${ctb})'\ - '(collect-generation-radix ${cgr})'\ - '(collect-maximum-generation ${cmg})'\ - '(in-place-minimum-generation ${ipmg})'\ - '(enable-object-counts #${eoc})'\ - '(commonization-level ${cl})'\ - '(compile-interpret-simple #${cis})'\ - '(set! *examples-directory* "${Examples}")'\ - '(enable-cp0 #${cp0})'\ - '(set! *scheme* "${Scheme}")'\ - '(current-eval ${eval})'\ - '(when #$c (coverage-table (load-coverage-files ${coverage-files:%="%"})))'\ + echo $(conf-scheme-code)\ '(time ((mat-file ".") "$*"))'\ '(parameterize ([source-directories (quote ("." "../s"))]) (when #${pdhtml} (profile-dump-html)))'\ '(unless (= (#%$$check-heap-errors) 0)'\ ' (fprintf (console-error-port) "check heap detected errors---grep standard output for !!!\n")'\ ' (abort))'\ | ${Scheme} -q mat.so ${patchfile} + ! egrep "Bug|Error|invalid memory" $*.mo %.so : %.ss echo '(reset-handler abort) (time (compile-file "$*"))' | ${Scheme} -q ${patchfile} -report: report-$(conf) +report: $(outdir)/report-$(conf) experr: experr-$(conf) -report-$(conf): errors-$(conf) +$(outdir)/report-$(conf): $(outdir)/errors-$(conf) $(MAKE) doreport doreport: experr-$(conf) - rm -f report-$(conf) - -diff experr-$(conf) errors-$(conf) > report-$(conf) 2>&1 + rm -f $(outdir)/report-$(conf) + -diff experr-$(conf) $(outdir)/errors-$(conf) > $(outdir)/report-$(conf) 2>&1 maybe-doreport: - -if [ -f errors-$(conf) ] ; then\ + -if [ -f $(outdir)/errors-$(conf) ] ; then\ $(MAKE) doreport ;\ fi -errors-$(conf): ${obj} +$(outdir)/errors-$(conf): ${obj} $(MAKE) doerrors doerrors: - rm -f errors-$(conf) - -(cd $(objdir); grep '^Error' $(objname)) > errors-$(conf) - -(cd $(objdir); grep '^Bug' $(objname)) >> errors-$(conf) - -(cd $(objdir); grep '^Warning' $(objname)) >> errors-$(conf) + rm -f $(outdir)/errors-$(conf) + -(cd $(objdir); grep '^Error' $(objname)) > $(outdir)/errors-$(conf) + -(cd $(objdir); grep '^Bug' $(objname)) >> $(outdir)/errors-$(conf) + -(cd $(objdir); grep '^Warning' $(objname)) >> $(outdir)/errors-$(conf) -(cd $(objdir); grep '^Expected' $(objname))\ - >> errors-$(conf) + >> $(outdir)/errors-$(conf) fastreport: $(MAKE) doerrors @@ -263,26 +265,56 @@ doallcoverage: mat.so echo '(reset-handler abort) (coverage-percent "run.covout" ${coverage-files:%="%"})' | ${Scheme} -q ${patchfile} mat.so ;\ fi -partialx: - $(MAKE) allxhelp o=0 - $(MAKE) allxhelp o=3 - $(MAKE) allxhelp o=3 cp0=t - $(MAKE) allxhelp o=3 eval=interpret cp0=t rmg=2 - -allx: prettyclean - $(MAKE) allxhelp o=0 eoc=f - $(MAKE) allxhelp o=3 eoc=f - $(MAKE) allxhelp o=0 cp0=t cl=3 - $(MAKE) allxhelp o=3 cp0=t cl=3 - $(MAKE) allxhelp o=0 spi=t rmg=2 p=t - $(MAKE) allxhelp o=3 spi=t rmg=2 p=t - $(MAKE) allxhelp o=0 eval=interpret cl=6 - $(MAKE) allxhelp o=3 eval=interpret cl=6 - $(MAKE) allxhelp o=0 eval=interpret cp0=t rmg=2 - $(MAKE) allxhelp o=3 eval=interpret cp0=t rmg=2 - $(MAKE) allxhelp o=0 eoc=f hci=101 cl=9 - $(MAKE) allxhelp o=3 eval=interpret hci=101 rmg=2 - $(MAKE) doallcoverage +define parallel-config-template +parallel$(1)-0: + -@$$(MAKE) allxphelp outdir=output-$(1)-0 objdir=output-$(1)-0 o=0 $(2) +parallel$(1)-3: + -@$$(MAKE) allxphelp outdir=output-$(1)-3 objdir=output-$(1)-3 o=3 $(2) +endef + +#configs from partialx and allx +$(eval $(call parallel-config-template,1,eoc=f)) +$(eval $(call parallel-config-template,2,cp0=t)) +$(eval $(call parallel-config-template,3,cp0=t cl=3)) +$(eval $(call parallel-config-template,4,spi=t rmg=2 p=t)) +$(eval $(call parallel-config-template,5,eval=interpret cl=6)) +$(eval $(call parallel-config-template,6,eval=interpret cp0=t rmg=2)) +$(eval $(call parallel-config-template,7,eoc=f hci=101 cl=9)) +$(eval $(call parallel-config-template,8,eval=interpret hci=101 rmg=2)) + +#configs from bullyx +$(eval $(call parallel-config-template,b1,allxphelp-target=allxhelpnotall spi=t cp0=f)) +$(eval $(call parallel-config-template,b2,spi=f cp0=f cl=9 ctb='(/ (collect-trip-bytes) 64)' hci=503)) +$(eval $(call parallel-config-template,b3,spi=t cp0=f cis=t cmg=1)) +$(eval $(call parallel-config-template,b4,spi=f cp0=f cis=t cmg=6 hci=101)) +$(eval $(call parallel-config-template,b5,spi=t cp0=t ctb='(/ (collect-trip-bytes) 64)' cgr=6)) +$(eval $(call parallel-config-template,b6,spi=t cp0=f p=t eoc=f hci=101)) +$(eval $(call parallel-config-template,b7,spi=f cp0=t cl=9 p=t hci=101)) +$(eval $(call parallel-config-template,b8,eval=interpret spi=f cp0=f)) +$(eval $(call parallel-config-template,b9,eval=interpret spi=f cp0=t)) +$(eval $(call parallel-config-template,b10,eval=interpret spi=t cp0=f ctb='(/ (collect-trip-bytes) 64)' hci=503)) +$(eval $(call parallel-config-template,b11,eval=interpret spi=t cp0=t cgr=2 hci=101 p=t)) + + +partialx-confs = 1-0 1-3 2-3 6-3 + +allx-confs = 1-0 1-3 3-0 3-3 4-0 4-3 5-0 5-3 6-0 6-3 7-0 8-3 + +bullyx-confs = $(foreach n,1 2 3 4 5 6 7 8 9 10 11,b$(n)-0 b$(n)-3) + +define parallel-target-template +$(1)-targets: $($(1)-confs:%=parallel%) +$(1): prettyclean + @echo building prereqs with output to Make.out + @$$(MAKE) parallel-prereqs > Make.out 2>&1 + @$$(MAKE) $(1)-targets + $(if $(2),@$$(MAKE) $(2)) + cat $($(1)-confs:%=output-%/summary) > summary && cat summary +endef + +$(eval $(call parallel-target-template,partialx)) +$(eval $(call parallel-target-template,allx,doallcoverage)) +$(eval $(call parallel-target-template,bullyx,doallcoverage)) just-reports: for EVAL in compile interpret ; do\ @@ -297,51 +329,56 @@ just-reports: done\ done -bullyx: - -$(MAKE) bully o=0 - -$(MAKE) bully o=3 - -bully: - -$(MAKE) allxhelpnotall spi=t cp0=f - -$(MAKE) allxhelp spi=f cp0=f cl=9 ctb='(/ (collect-trip-bytes) 64)' hci=503 - -$(MAKE) allxhelp spi=t cp0=f cis=t cmg=1 - -$(MAKE) allxhelp spi=f cp0=f cis=t cmg=6 hci=101 - -$(MAKE) allxhelp spi=t cp0=t ctb='(/ (collect-trip-bytes) 64)' cgr=6 - -$(MAKE) allxhelp spi=t cp0=f p=t eoc=f hci=101 - -$(MAKE) allxhelp spi=f cp0=t cl=9 p=t hci=101 - -$(MAKE) allxhelp eval=interpret spi=f cp0=f - -$(MAKE) allxhelp eval=interpret spi=f cp0=t - -$(MAKE) allxhelp eval=interpret spi=t cp0=f ctb='(/ (collect-trip-bytes) 64)' hci=503 - -$(MAKE) allxhelp eval=interpret spi=t cp0=t cgr=2 hci=101 p=t - $(MAKE) doallcoverage allxhelp: $(MAKE) doheader -$(MAKE) all + $(MAKE) errors-$(conf) forpatches=. $(MAKE) dosummary -doheader: - printf "%s" "-------- o=$o" >> summary - if [ "$(spi)" != "$(defaultspi)" ] ; then printf " spi=$(spi)" >> summary ; fi - if [ "$(hci)" != "$(defaulthci)" ] ; then printf " hci=$(hci)" >> summary ; fi - if [ "$(ecpf)" != "$(defaultecpf)" ] ; then printf " ecpf(ecpf)" >> summary ; fi - if [ "$(cp0)" != "$(defaultcp0)" ] ; then printf " cp0=$(cp0)" >> summary ; fi - if [ "$(cis)" != "$(defaultcis)" ] ; then printf " cis=$(cis)" >> summary ; fi - if [ "$p" != "$(defaultp)" ] ; then printf " p=$p" >> summary ; fi - if [ "$(eval)" != "$(defaulteval)" ] ; then printf " eval=$(eval)" >> summary ; fi - if [ "$(ctb)" != "$(defaultctb)" ] ; then printf " ctb=$(ctb)" >> summary ; fi - if [ "$(cgr)" != "$(defaultcgr)" ] ; then printf " cgr=$(cgr)" >> summary ; fi - if [ "$(cmg)" != "$(defaultcmg)" ] ; then printf " cmg=$(cmg)" >> summary ; fi - if [ "$(eoc)" != "$(defaulteoc)" ] ; then printf " eoc=$(eoc)" >> summary ; fi - if [ "$(cl)" != "$(defaultcl)" ] ; then printf " cl=$(cl)" >> summary ; fi - if [ "$(hdrmsg)" != "" ] ; then printf " $(hdrmsg)" >> summary ; fi +# To support an eventual `make patches`, link `errors-$(conf)` to allxhelp output +# if there's not already a representative for the configuration: +forpatches = different-from-outdir +$(forpatches)/errors-$(conf): + ln -s $(outdir)/errors-$(conf) errors-$(conf) + +config-vars = spi hci ecpf cp0 cis p eval ctb cgr cmg eoc cl rmg +full-config-str = $(strip o=$(o) $(foreach var, $(config-vars),$(if $(filter-out $($(var:%=default%)),$($(var))),$(var)=$($(var)))) $(hdrmsg)) + +allxphelp-target = allxhelp +allxphelp: $(outdir) + @echo "matting configuration ($(full-config-str)) with output to $(outdir)/Make.out" + @$(MAKE) $(allxphelp-target) > "$(outdir)/Make.out" 2>&1 + @echo "finished matting configuration $(full-config-str)" + +summary-file=$(outdir)/summary + +$(outdir): + @mkdir -p "$(outdir)" + +doheader: $(outdir) + printf "%s" "-------- o=$o" >> $(summary-file) + if [ "$(spi)" != "$(defaultspi)" ] ; then printf " spi=$(spi)" >> $(summary-file) ; fi + if [ "$(hci)" != "$(defaulthci)" ] ; then printf " hci=$(hci)" >> $(summary-file) ; fi + if [ "$(ecpf)" != "$(defaultecpf)" ] ; then printf " ecpf(ecpf)" >> $(summary-file) ; fi + if [ "$(cp0)" != "$(defaultcp0)" ] ; then printf " cp0=$(cp0)" >> $(summary-file) ; fi + if [ "$(cis)" != "$(defaultcis)" ] ; then printf " cis=$(cis)" >> $(summary-file) ; fi + if [ "$p" != "$(defaultp)" ] ; then printf " p=$p" >> $(summary-file) ; fi + if [ "$(eval)" != "$(defaulteval)" ] ; then printf " eval=$(eval)" >> $(summary-file) ; fi + if [ "$(ctb)" != "$(defaultctb)" ] ; then printf " ctb=$(ctb)" >> $(summary-file) ; fi + if [ "$(cgr)" != "$(defaultcgr)" ] ; then printf " cgr=$(cgr)" >> $(summary-file) ; fi + if [ "$(cmg)" != "$(defaultcmg)" ] ; then printf " cmg=$(cmg)" >> $(summary-file) ; fi + if [ "$(eoc)" != "$(defaulteoc)" ] ; then printf " eoc=$(eoc)" >> $(summary-file) ; fi + if [ "$(cl)" != "$(defaultcl)" ] ; then printf " cl=$(cl)" >> $(summary-file) ; fi + if [ "$(rmg)" != "$(defaultrmg)" ] ; then printf " rmg=$(rmg)" >> $(summary-file) ; fi + if [ "$(hdrmsg)" != "" ] ; then printf " $(hdrmsg)" >> $(summary-file) ; fi dosummary: - printf " --------\n" >> summary - if [ -f report-$(conf) ] ; then\ - cat report-$(conf) >> summary ;\ + printf " --------\n" >> $(summary-file) + if [ -f $(outdir)/report-$(conf) ] ; then\ + cat $(outdir)/report-$(conf) >> $(summary-file) ;\ else \ - printf 'NO REPORT\n' >> summary ;\ + printf 'NO REPORT\n' >> $(summary-file) ;\ fi allxhelpnotall: @@ -356,33 +393,18 @@ all1: ; $(MAKE) all o=1 all2: ; $(MAKE) all o=2 all3: ; $(MAKE) all o=3 -all: makescript$o $(src) oop.ss ht.ss mat.so cat_flush ${fobj} m4test.in m4test.out prettytest.ss ftype.h freq.in freq.out ${patchfile} build-examples - ${Scheme} --verbose -q mat.so ${patchfile} < script.all$o +parallel-prereqs: $(src) oop.ss ht.ss mat.so cat_flush${ExeSuffix} ${fobj} m4test.in m4test.out prettytest.ss ftype.h freq.in freq.out ${patchfile} build-examples + +all: $(outdir) $(outdir)/script.all $(src) oop.ss ht.ss mat.so cat_flush${ExeSuffix} ${fobj} m4test.in m4test.out prettytest.ss ftype.h freq.in freq.out ${patchfile} build-examples + ${Scheme} --verbose -q mat.so ${patchfile} < $(outdir)/script.all $(MAKE) doerrors $(MAKE) doreport $(MAKE) docoverage -script.all$o: Mf-base - -script.all$o makescript$o: - echo '(optimize-level $o)'\ - '(#%$$suppress-primitive-inlining #${spi})'\ - '(heap-check-interval ${hci})'\ - '(#%$$enable-check-prelex-flags #${ecpf})'\ - '(compile-profile #$p)'\ - '(collect-notify #${cn})'\ - '(collect-trip-bytes ${ctb})'\ - '(collect-generation-radix ${cgr})'\ - '(collect-maximum-generation ${cmg})'\ - '(in-place-minimum-generation ${ipmg})'\ - '(enable-object-counts #${eoc})'\ - '(commonization-level ${cl})'\ - '(compile-interpret-simple #${cis})'\ - '(set! *examples-directory* "${Examples}")'\ - '(enable-cp0 #${cp0})'\ - '(set! *scheme* "${Scheme}")'\ - '(current-eval ${eval})'\ - '(when #$c (coverage-table (load-coverage-files ${coverage-files:%="%"})))'\ +$(outdir)/script.all: Mf-base $(outdir) + +$(outdir)/script.all makescript$o: + echo $(conf-scheme-code)\ '(record-run-coverage "$(objdir)/run.covout"'\ ' (lambda ()'\ ' (time (for-each (lambda (x) (time ((mat-file "$(objdir)") x)))'\ @@ -391,14 +413,14 @@ script.all$o makescript$o: ' (unless (= (#%$$check-heap-errors) 0)'\ ' (fprintf (console-error-port) "check heap detected errors---grep standard output for !!!\n")'\ ' (abort))))'\ - > script.all$o + > $(outdir)/script.all source: $(MAKE) source0 o=0 $(MAKE) source2 o=2 $(MAKE) source3 o=3 -source$o: ${src} mat.ss oop.ss ht.ss cat_flush.c ${fsrc} freq.in freq.out m4test.in m4test.out script.all$o prettytest.ss ftype.h +source$o: ${src} mat.ss oop.ss ht.ss cat_flush.c ${fsrc} freq.in freq.out m4test.in m4test.out $(outdir)/script.all prettytest.ss ftype.h rootsrc = $(shell cd ${upupsrcdir}/mats; echo *) ${rootsrc}: @@ -424,7 +446,7 @@ examples.mo ${objdir}/examples.mo: m4test.in m4test.out freq.in freq.out build-e 6.mo ${objdir}/6.mo: prettytest.ss bytevector.mo ${objdir}/bytevector.mo: prettytest.ss io.mo ${objdir}/io.mo: prettytest.ss -unix.mo ${objdir}/unix.mo io.mo ${objdir}/io.mo 6.mo ${objdir}/6.mo: cat_flush +unix.mo ${objdir}/unix.mo io.mo ${objdir}/io.mo 6.mo ${objdir}/6.mo: cat_flush${ExeSuffix} oop.mo ${objdir}/oop.mo: oop.ss ftype.mo ${objdir}/ftype.mo: ftype.h hash.mo ${objdir}/hash.mo: ht.ss @@ -435,7 +457,7 @@ build-examples: prettyclean: rm -f *.o ${mdclean} *.so *.mo *.covout experr* errors* report* summary testfile* testscript\ - ${fobj} prettytest.ss cat_flush so_locations\ + ${fobj} prettytest.ss cat_flush${ExeSuffix} so_locations\ build-examples script.all? *.html experr*.rej experr*.orig rm -rf testdir* rm -rf output-* @@ -457,7 +479,7 @@ experr-compile-$o-f-f-f: root-experr-compile-$o-f-f-f root-experr: # don't list dependencies! rm -f root-experr-compile-$o-f-f-f - cp errors-compile-$o-f-f-f root-experr-compile-$o-f-f-f + cp $(outdir)/errors-compile-$o-f-f-f root-experr-compile-$o-f-f-f # derive spi=t experr files by patching spi=f experr files # cp first in case patch is empty, since patch produces an empty output diff --git a/src/ChezScheme/mats/Mf-i3fb b/src/ChezScheme/mats/Mf-i3fb deleted file mode 100644 index 2a29b2a9a6..0000000000 --- a/src/ChezScheme/mats/Mf-i3fb +++ /dev/null @@ -1,27 +0,0 @@ -# Mf-i3fb -# 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 ?= i3fb - -fsrc = foreign1.c foreign2.c foreign3.c foreign4.c -fobj = foreign1.so - -include Mf-base - -foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -fPIC ${threadFlags} -shared -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-i3le b/src/ChezScheme/mats/Mf-i3le deleted file mode 100644 index 8bee4684fb..0000000000 --- a/src/ChezScheme/mats/Mf-i3le +++ /dev/null @@ -1,27 +0,0 @@ -# Mf-i3le -# 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 ?= i3le - -fsrc = foreign1.c foreign2.c foreign3.c foreign4.c -fobj = foreign1.so - -include Mf-base - -foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -m32 -fPIC ${threadFlags} -shared -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-i3nb b/src/ChezScheme/mats/Mf-i3nb deleted file mode 100644 index dcd50948ee..0000000000 --- a/src/ChezScheme/mats/Mf-i3nb +++ /dev/null @@ -1,27 +0,0 @@ -# Mf-i3nb -# 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 ?= i3nb - -fsrc = foreign1.c foreign2.c foreign3.c foreign4.c -fobj = foreign1.so - -include Mf-base - -foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -fPIC ${threadFlags} -shared -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-i3nt b/src/ChezScheme/mats/Mf-i3nt index 4dfc3238b1..6c18a6be35 100644 --- a/src/ChezScheme/mats/Mf-i3nt +++ b/src/ChezScheme/mats/Mf-i3nt @@ -1,5 +1,5 @@ # Mf-i3nt -# Copyright 1984-2017 Cisco Systems, Inc. +# Copyright 1984-2021 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. @@ -13,7 +13,6 @@ # See the License for the specific language governing permissions and # limitations under the License. -m ?= i3nt fsrc = foreign1.c foreign2.c foreign3.c foreign4.c fobj = foreign1.so @@ -24,7 +23,7 @@ include Mf-base export MSYS_NO_PATHCONV=1 foreign1.so: $(fsrc) - cmd.exe /c "vs.bat x86 && cl /DWIN32 /Fe$@ /I${Include} /LD /MD /nologo ../bin/$m/csv953.lib $(fsrc)" + cmd.exe /c "vs.bat x86 && cl /DWIN32 /Fe$@ /I${Include} /LD /MD /nologo ../bin/$m/csv955.lib $(fsrc)" -cat_flush: cat_flush.c +cat_flush.exe: cat_flush.c cmd.exe /c "vs.bat x86 && cl /DWIN32 /MD /nologo $<" diff --git a/src/ChezScheme/mats/Mf-i3ob b/src/ChezScheme/mats/Mf-i3ob deleted file mode 100644 index cbabe3fe16..0000000000 --- a/src/ChezScheme/mats/Mf-i3ob +++ /dev/null @@ -1,27 +0,0 @@ -# Mf-i3ob -# 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 ?= i3ob - -fsrc = foreign1.c foreign2.c foreign3.c foreign4.c -fobj = foreign1.so - -include Mf-base - -foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -fPIC ${threadFlags} -shared -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-i3osx b/src/ChezScheme/mats/Mf-i3osx deleted file mode 100644 index a2c67a2b04..0000000000 --- a/src/ChezScheme/mats/Mf-i3osx +++ /dev/null @@ -1,27 +0,0 @@ -# Mf-i3osx -# 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 ?= i3osx - -fsrc = foreign1.c foreign2.c foreign3.c foreign4.c -fobj = foreign1.so - -include Mf-base - -foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -m32 -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-i3qnx b/src/ChezScheme/mats/Mf-i3qnx deleted file mode 100644 index 724f2dbb84..0000000000 --- a/src/ChezScheme/mats/Mf-i3qnx +++ /dev/null @@ -1,27 +0,0 @@ -# Mf-i3qnx -# 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 = i3qnx - -fsrc = foreign1.c foreign2.c foreign3.c foreign4.c -fobj = foreign1.so - -include Mf-base - -foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -m32 -fPIC -shared -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-i3s2 b/src/ChezScheme/mats/Mf-i3s2 deleted file mode 100644 index 55f1cb4de1..0000000000 --- a/src/ChezScheme/mats/Mf-i3s2 +++ /dev/null @@ -1,27 +0,0 @@ -# Mf-i3s2 -# 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 ?= i3s2 - -fsrc = foreign1.c foreign2.c foreign3.c foreign4.c -fobj = foreign1.so - -include Mf-base - -foreign1.so: ${fsrc} ../boot/$m/scheme.h - gcc -m32 -fPIC ${threadFlags} -shared -I${Include} -o foreign1.so ${fsrc} - -cat_flush: cat_flush.c - gcc -o cat_flush cat_flush.c diff --git a/src/ChezScheme/mats/Mf-pb b/src/ChezScheme/mats/Mf-pb deleted file mode 100644 index 69b359460c..0000000000 --- a/src/ChezScheme/mats/Mf-pb +++ /dev/null @@ -1,5 +0,0 @@ -# Mf-pb - -m = pb - -include Mf-pbhost diff --git a/src/ChezScheme/mats/Mf-ppc32le b/src/ChezScheme/mats/Mf-ppc32le deleted file mode 100644 index 1e8703a751..0000000000 --- a/src/ChezScheme/mats/Mf-ppc32le +++ /dev/null @@ -1,27 +0,0 @@ -# Mf-ppc32le -# 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 ?= ppc32le - -fsrc = foreign1.c foreign2.c foreign3.c foreign4.c -fobj = foreign1.so - -include Mf-base - -foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -m32 -fPIC ${threadFlags} -shared -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-ppc32osx b/src/ChezScheme/mats/Mf-ppc32osx deleted file mode 100644 index 21599d86b5..0000000000 --- a/src/ChezScheme/mats/Mf-ppc32osx +++ /dev/null @@ -1,14 +0,0 @@ -# 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-ta6fb b/src/ChezScheme/mats/Mf-ta6fb deleted file mode 100644 index 6895aff210..0000000000 --- a/src/ChezScheme/mats/Mf-ta6fb +++ /dev/null @@ -1,7 +0,0 @@ -# Mf-ta6fb - -m = ta6fb - -threadFlags = -pthread - -include Mf-a6fb diff --git a/src/ChezScheme/mats/Mf-ta6le b/src/ChezScheme/mats/Mf-ta6le deleted file mode 100644 index 29ba25c3d1..0000000000 --- a/src/ChezScheme/mats/Mf-ta6le +++ /dev/null @@ -1,7 +0,0 @@ -# Mf-ta6le - -m = ta6le - -threadFlags = -pthread - -include Mf-a6le diff --git a/src/ChezScheme/mats/Mf-ta6nb b/src/ChezScheme/mats/Mf-ta6nb deleted file mode 100644 index 0ed99a5b22..0000000000 --- a/src/ChezScheme/mats/Mf-ta6nb +++ /dev/null @@ -1,7 +0,0 @@ -# Mf-ta6nb - -m = ta6nb - -threadFlags = -pthread - -include Mf-a6nb diff --git a/src/ChezScheme/mats/Mf-ta6nt b/src/ChezScheme/mats/Mf-ta6nt index 9e1fb593ab..53b585efb3 100644 --- a/src/ChezScheme/mats/Mf-ta6nt +++ b/src/ChezScheme/mats/Mf-ta6nt @@ -1,5 +1,4 @@ # Mf-ta6nt -m = ta6nt include Mf-a6nt diff --git a/src/ChezScheme/mats/Mf-ta6ob b/src/ChezScheme/mats/Mf-ta6ob deleted file mode 100644 index e1b8f096e9..0000000000 --- a/src/ChezScheme/mats/Mf-ta6ob +++ /dev/null @@ -1,7 +0,0 @@ -# Mf-ta6ob - -m = ta6ob - -threadFlags = -pthread - -include Mf-a6ob diff --git a/src/ChezScheme/mats/Mf-ta6osx b/src/ChezScheme/mats/Mf-ta6osx deleted file mode 100644 index 2696b70f1e..0000000000 --- a/src/ChezScheme/mats/Mf-ta6osx +++ /dev/null @@ -1,5 +0,0 @@ -# Mf-ta6osx - -m = ta6osx - -include Mf-a6osx diff --git a/src/ChezScheme/mats/Mf-ta6s2 b/src/ChezScheme/mats/Mf-ta6s2 deleted file mode 100644 index f8a11d60c0..0000000000 --- a/src/ChezScheme/mats/Mf-ta6s2 +++ /dev/null @@ -1,7 +0,0 @@ -# Mf-ta6s2 - -m = ta6s2 - -threadFlags = -D_REENTRANT - -include Mf-a6s2 diff --git a/src/ChezScheme/mats/Mf-tarm32le b/src/ChezScheme/mats/Mf-tarm32le deleted file mode 100644 index 6d67e1fd9b..0000000000 --- a/src/ChezScheme/mats/Mf-tarm32le +++ /dev/null @@ -1,5 +0,0 @@ -# Mf-tarm32le - -m = tarm32le - -include Mf-arm32le diff --git a/src/ChezScheme/mats/Mf-tarm64le b/src/ChezScheme/mats/Mf-tarm64le deleted file mode 100644 index 903f81643c..0000000000 --- a/src/ChezScheme/mats/Mf-tarm64le +++ /dev/null @@ -1,5 +0,0 @@ -# Mf-tarm64le - -m = tarm64le - -include Mf-arm64le diff --git a/src/ChezScheme/mats/Mf-tarm64osx b/src/ChezScheme/mats/Mf-tarm64osx deleted file mode 100644 index 520b683f43..0000000000 --- a/src/ChezScheme/mats/Mf-tarm64osx +++ /dev/null @@ -1,5 +0,0 @@ -# Mf-tarm64osx - -m = tarm64osx - -include Mf-arm64osx diff --git a/src/ChezScheme/mats/Mf-ti3fb b/src/ChezScheme/mats/Mf-ti3fb deleted file mode 100644 index c83a9fa332..0000000000 --- a/src/ChezScheme/mats/Mf-ti3fb +++ /dev/null @@ -1,7 +0,0 @@ -# Mf-ti3fb - -m = ti3fb - -threadFlags = -pthread - -include Mf-i3fb diff --git a/src/ChezScheme/mats/Mf-ti3le b/src/ChezScheme/mats/Mf-ti3le deleted file mode 100644 index 70f3832bfb..0000000000 --- a/src/ChezScheme/mats/Mf-ti3le +++ /dev/null @@ -1,7 +0,0 @@ -# Mf-ti3le - -m = ti3le - -threadFlags = -pthread - -include Mf-i3le diff --git a/src/ChezScheme/mats/Mf-ti3nb b/src/ChezScheme/mats/Mf-ti3nb deleted file mode 100644 index eb6f21bd41..0000000000 --- a/src/ChezScheme/mats/Mf-ti3nb +++ /dev/null @@ -1,7 +0,0 @@ -# Mf-ti3nb - -m = ti3nb - -threadFlags = -pthread - -include Mf-i3nb diff --git a/src/ChezScheme/mats/Mf-ti3nt b/src/ChezScheme/mats/Mf-ti3nt index 4a04350802..3be81d0b19 100644 --- a/src/ChezScheme/mats/Mf-ti3nt +++ b/src/ChezScheme/mats/Mf-ti3nt @@ -1,5 +1,4 @@ # Mf-ti3nt -m = ti3nt include Mf-i3nt diff --git a/src/ChezScheme/mats/Mf-ti3ob b/src/ChezScheme/mats/Mf-ti3ob deleted file mode 100644 index 7c63270d5d..0000000000 --- a/src/ChezScheme/mats/Mf-ti3ob +++ /dev/null @@ -1,7 +0,0 @@ -# Mf-ti3ob - -m = ti3ob - -threadFlags = -pthread - -include Mf-i3ob diff --git a/src/ChezScheme/mats/Mf-ti3osx b/src/ChezScheme/mats/Mf-ti3osx deleted file mode 100644 index 2f0c8d7c11..0000000000 --- a/src/ChezScheme/mats/Mf-ti3osx +++ /dev/null @@ -1,5 +0,0 @@ -# Mf-ti3osx - -m = ti3osx - -include Mf-i3osx diff --git a/src/ChezScheme/mats/Mf-ti3s2 b/src/ChezScheme/mats/Mf-ti3s2 deleted file mode 100644 index 7d7bcd125e..0000000000 --- a/src/ChezScheme/mats/Mf-ti3s2 +++ /dev/null @@ -1,7 +0,0 @@ -# Mf-ti3s2 - -m = ti3s2 - -threadFlags = -D_REENTRANT - -include Mf-i3s2 diff --git a/src/ChezScheme/mats/Mf-tppc32le b/src/ChezScheme/mats/Mf-tppc32le deleted file mode 100644 index 34f4571a6e..0000000000 --- a/src/ChezScheme/mats/Mf-tppc32le +++ /dev/null @@ -1,7 +0,0 @@ -# Mf-tppc32le - -m = tppc32le - -threadFlags = -pthread - -include Mf-ppc32le diff --git a/src/ChezScheme/mats/Mf-tppc32osx b/src/ChezScheme/mats/Mf-tppc32osx deleted file mode 100644 index 2a1a6584ed..0000000000 --- a/src/ChezScheme/mats/Mf-tppc32osx +++ /dev/null @@ -1,5 +0,0 @@ -# Mf-tppc32osx - -m ?= tppc32osx - -include Mf-ppc32osx diff --git a/src/ChezScheme/mats/Mf-arm64osx b/src/ChezScheme/mats/Mf-unix index b1d870ab48..73cbf95c20 100644 --- a/src/ChezScheme/mats/Mf-arm64osx +++ b/src/ChezScheme/mats/Mf-unix @@ -1,14 +1,10 @@ -# 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} + $(CC) ${CPPFLAGS} ${CFLAGS} ${mdcflags} -I${Include} -o foreign1.so ${fsrc} cat_flush: cat_flush.c - cc -o cat_flush cat_flush.c + $(CC) ${CPPFLAGS} ${CFLAGS} -o cat_flush cat_flush.c diff --git a/src/ChezScheme/mats/bytevector.ms b/src/ChezScheme/mats/bytevector.ms index 5cd08cd25e..0a7f86ff74 100644 --- a/src/ChezScheme/mats/bytevector.ms +++ b/src/ChezScheme/mats/bytevector.ms @@ -11321,7 +11321,7 @@ (cons (bitwise-and i 255) (loop (+ i 1))))))) (round-trip-bytevector-compress - (call-with-port (open-file-input-port "prettytest.ss") get-bytevector-all)) + (call-with-port (open-file-input-port (format "~a/prettytest.ss" *mats-dir*)) get-bytevector-all)) (error? ;; Need at least 8 bytes for result size (bytevector-uncompress '#vu8())) diff --git a/src/ChezScheme/mats/cp0.ms b/src/ChezScheme/mats/cp0.ms index 00346420c1..151fcb675a 100644 --- a/src/ChezScheme/mats/cp0.ms +++ b/src/ChezScheme/mats/cp0.ms @@ -2614,7 +2614,8 @@ (begin (#%write 'f) #\y) (begin (#%write 'g) ($zzz-ok)))) (begin (#%write 'h) 1))))) - (expansion-matches? + (parameterize ([enable-type-recovery #f]) + (expansion-matches? '(begin (write 'a) ((begin (write 'b) string-ref) (begin (write 'c) @@ -2637,7 +2638,7 @@ (begin (#%write 'e) ($xxx-ok)) (begin (#%write 'f) 'oops) (begin (#%write 'g) ($zzz-ok)))) - (begin (#%write 'h) 1))))) + (begin (#%write 'h) 1)))))) (expansion-matches? `(begin (write 'a) ((begin (write 'b) string-ref) @@ -2730,7 +2731,8 @@ (begin (#%write 'f) 121) (begin (#%write 'g) ($zzz-ok)))) (begin (#%write 'h) 1))))) - (expansion-matches? + (parameterize ([enable-type-recovery #f]) + (expansion-matches? '(begin (write 'a) ((begin (write 'b) fxvector-ref) (begin (write 'c) @@ -2753,7 +2755,7 @@ (begin (#%write 'e) ($xxx-ok)) (begin (#%write 'f) 'oops) (begin (#%write 'g) ($zzz-ok)))) - (begin (#%write 'h) 1))))) + (begin (#%write 'h) 1)))))) (expansion-matches? `(begin (write 'a) ((begin (write 'b) fxvector-ref) @@ -2894,12 +2896,12 @@ (expand/optimize '(lambda (v) (let ([v2 (if (vector? v) v (error))]) - (let ([q (vector-sort v2)] [n (#3%vector-length v)]) + (let ([q (vector-sort < v2)] [n (#3%vector-length v)]) (display "1") (list q n)))))) '(lambda (v) (let ([v2 (begin (if (#2%vector? v) (#2%void) (#2%error)) v)]) - (let ([q (#2%vector-sort v2)] [n (#3%vector-length v)]) + (let ([q (#2%vector-sort #2%< v2)] [n (#3%vector-length v)]) (#2%display "1") (#2%list q n))))) (equivalent-expansion? @@ -2907,11 +2909,11 @@ (expand/optimize '(lambda (v) (let ([v2 (if (vector? v) v (error))]) - (let ([q (vector-sort v2)] [n (or v 72)]) + (let ([q (vector-sort < v2)] [n (or v 72)]) (display "1") (list q n)))))) '(lambda (v) - (let ([q (#2%vector-sort (begin (if (#2%vector? v) (#2%void) (#2%error)) v))] + (let ([q (#2%vector-sort #2%< (begin (if (#2%vector? v) (#2%void) (#2%error)) v))] [n (if v v 72)]) (#2%display "1") (#2%list q n)))) @@ -2923,7 +2925,7 @@ (syntax-rules () [(_ eqprim) (eqtest eqprim #f)] [(_ eqprim generic?) - (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f]) + (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [enable-type-recovery #f]) (let ([arity-mask (procedure-arity-mask eqprim)] [primref `($primitive ,(if (= (optimize-level) 3) 3 2) eqprim)]) (define-syntax ifsafe (syntax-rules () @@ -3163,6 +3165,7 @@ (or (not (enable-cp0)) (not (procedure-known-single-valued? (lambda (f) (#2%$app/value f))))) (or (not (enable-cp0)) + (#%$suppress-primitive-inlining) (eq? (current-eval) interpret) (procedure-known-single-valued? (case-lambda [(f) (#3%$app/value f)] @@ -3171,6 +3174,7 @@ (#3%$app/value f))]))) (or (not (enable-cp0)) + (#%$suppress-primitive-inlining) (eq? (current-eval) interpret) (procedure-known-single-valued? (lambda () (abort 'x)))) (or (not (enable-cp0)) @@ -3179,6 +3183,7 @@ (or (not (enable-cp0)) (not (procedure-known-single-valued? (lambda (f) (#2%$app/no-return f))))) (or (not (enable-cp0)) + (#%$suppress-primitive-inlining) (eq? (current-eval) interpret) (procedure-known-single-valued? (case-lambda [(f) (#3%$app/no-return f)] @@ -3339,3 +3344,28 @@ (expand/optimize '(#3%$app/value x y)) '($app/value x y))) ) + +(mat cross-library-inlining + (begin + ;; Make sure inlining doesn't use the wrong `helper` + (library (cross-library-inlining-test) + (export a b am bm) + (import (rnrs)) + (define-syntax def + (syntax-rules () + [(_ id idm) + (begin + (define (helper x) (if (zero? x) 'id (helper (- x 1)))) + (define (id x) (helper x)) + ;; causes `helper` to be preserved: + (define-syntax idm (syntax-rules () [(_) helper])))])) + (def a am) + (def b bm)) + #t) + (eq? 'a (let () + (import (cross-library-inlining-test)) + (a 10))) + (eq? 'b (let () + (import (cross-library-inlining-test)) + (b 10))) + ) diff --git a/src/ChezScheme/mats/cptypes.ms b/src/ChezScheme/mats/cptypes.ms index c1624af97e..37d4b20863 100644 --- a/src/ChezScheme/mats/cptypes.ms +++ b/src/ChezScheme/mats/cptypes.ms @@ -85,6 +85,12 @@ '(pair? (list)) #f) (cptypes-equivalent-expansion? + '(eq? (newline) (void)) + '(begin (newline) #t)) + (cptypes-equivalent-expansion? + '(eq? (newline) 0) + '(begin (newline) #f)) + (cptypes-equivalent-expansion? '(lambda (x) (vector-set! x 0 0) (vector? x)) '(lambda (x) (vector-set! x 0 0) #t)) (cptypes-equivalent-expansion? @@ -210,6 +216,18 @@ (cptypes-equivalent-expansion? '(lambda (x) (when (and (fixnum? x) (zero? x)) x)) '(lambda (x) (when (and (fixnum? x) (zero? x)) 0))) + (cptypes-equivalent-expansion? + '(lambda (x f) (when (list-assuming-immutable? x) (f x) (list-assuming-immutable? x))) + '(lambda (x f) (when (list-assuming-immutable? x) (f x) #t))) + (not (cptypes-equivalent-expansion? + '(lambda (x f) (when (list? x) (f x) (unless (list? x) 1))) + '(lambda (x f) (when (list? x) (f x) (unless (list? x) 2))))) + (cptypes-equivalent-expansion? + '(lambda (f) (define x '(1 2 3)) (f x) (list-assuming-immutable? x)) + '(lambda (f) (define x '(1 2 3)) (f x) #t)) + (cptypes-equivalent-expansion? + '(lambda () (define x '(1 2 3)) (pair? x)) + '(lambda () (define x '(1 2 3)) #t)) ) (mat cptypes-type-if @@ -558,17 +576,22 @@ (mat cptypes-type-implies? (test-chain '((lambda (x) (eq? x 0)) fixnum? #;exact-integer? real? number?)) + (test-chain* '((lambda (x) (or (eq? x 0) (eq? x 10))) fixnum? #;exact-integer? real? number?)) (test-chain* '(fixnum? integer? real?)) (test-chain* '(fixnum? exact? number?)) ; exact? may raise an error (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? x (expt 256 100))) bignum? real? number?)) (test-chain '((lambda (x) (eqv? 0.0 x)) flonum? real? number?)) + (test-chain* '((lambda (x) (or (eqv? x 0.0) (eqv? x 3.14))) flonum? real? number?)) + (test-chain* '((lambda (x) (or (eq? x 0) (eqv? x 3.14))) real? number?)) (test-chain '(gensym? symbol?)) + (test-chain '((lambda (x) (eq? x 'banana)) symbol?)) (test-chain '(not boolean?)) (test-chain '((lambda (x) (eq? x #t)) boolean?)) (test-chain* '(record? #3%$record?)) (test-chain* '((lambda (x) (eq? x car)) procedure?)) (test-chain* '(record-type-descriptor? #3%$record?)) + (test-chain* '(null? list-assuming-immutable? list? #;(lambda (x) (or (null? x) (pair? x))))) (test-disjoint '(pair? box? #3%$record? number? vector? string? bytevector? fxvector? symbol? char? boolean? null? (lambda (x) (eq? x (void))) @@ -578,13 +601,18 @@ (test-disjoint '(pair? box? fixnum? flonum? (lambda (x) (eq? #t x)))) (test-disjoint '((lambda (x) (eq? x 0)) (lambda (x) (eq? x 1)) flonum?)) (test-disjoint '((lambda (x) (eqv? x 0.0)) (lambda (x) (eqv? x 1.0)) fixnum?)) + (test-disjoint '((lambda (x) (eq? x 'banana)) (lambda (x) (eq? x 'apple)))) (test-disjoint* '(list? record? vector?)) (not (test-disjoint* '(list? null?))) (not (test-disjoint* '(list? pair?))) + (not (test-disjoint* '(list-assuming-immutable? null?))) + (not (test-disjoint* '(list-assuming-immutable? pair?))) + (not (test-disjoint* '(list-assuming-immutable? list?))) ) ; use a gensym to make expansions equivalent (define my-rec (gensym "my-rec")) +(define my-sub-rec (gensym "my-sub-rec")) (mat cptypes-type-record? ; define-record (parameterize ([optimize-level 2]) @@ -670,6 +698,55 @@ (define-record-type ,my-rec (fields a) (sealed #t)) (define-record-type ,(gensym "other-rec") (fields a))) '(my-rec? other-rec?)) + + ;; substituting `record-instance?` + (cptypes-equivalent-expansion? + `(let () + (define-record-type ,my-rec (fields a)) + (define-record-type ,my-sub-rec (fields a) (parent ,my-rec)) + (lambda (x) (and (my-rec? x) (list 'ok (my-sub-rec? x))))) + `(let () + (define-record-type ,my-rec (fields a)) + (define-record-type ,my-sub-rec (fields a) (parent ,my-rec)) + (lambda (x) (and (my-rec? x) (list 'ok (#3%record-instance? x (record-type-descriptor ,my-sub-rec))))))) + + ;; substituting `sealed-record-instance?` + (cptypes-equivalent-expansion? + `(let () + (define-record-type ,my-rec (fields a)) + (define-record-type ,my-sub-rec (fields a) (parent ,my-rec) (sealed #t)) + (lambda (x) (and (my-rec? x) (list 'ok (my-sub-rec? x))))) + `(let () + (define-record-type ,my-rec (fields a)) + (define-record-type ,my-sub-rec (fields a) (parent ,my-rec) (sealed #t)) + (lambda (x) (and (my-rec? x) (list 'ok (#3%$sealed-record-instance? x (record-type-descriptor ,my-sub-rec))))))) + + ;; obviously incompatible rtds + ;; the third pass is needed to eliminate #3%$value + (parameterize ([run-cp0 (lambda (cp0 x) (cp0 (cp0 (cp0 x))))]) + (cptypes-equivalent-expansion? + `(let () + (define-record I (a)) + (define A (make-record-type-descriptor* 'a #f #f #f #f 1 0)) + (lambda (x) (and ((record-predicate A) x) (I? x)))) + `(begin + (make-record-type-descriptor* 'a #f #f #f #f 1 0) + (lambda (x) #f)))) +) + +(mat cptypes-lists + (cptypes-equivalent-expansion? + '(lambda (x) (when (list-assuming-immutable? x) (list? (cdr x)))) + '(lambda (x) (when (list-assuming-immutable? x) (cdr x) #t))) + (cptypes-equivalent-expansion? + '(lambda (x) (when (and (list-assuming-immutable? x) (pair? x)) (list? (cdr x)))) + '(lambda (x) (when (and (list-assuming-immutable? x) (pair? x)) #t))) + (cptypes-equivalent-expansion? + '(lambda (x) (when (list-assuming-immutable? x) (list? (cdr (error 'e ""))))) + '(lambda (x) (when (list-assuming-immutable? x) (error 'e "")))) + (cptypes-equivalent-expansion? + '(lambda (x) (when (vector? x) (list? (#2%cdr x)) 1)) + '(lambda (x) (when (vector? x) (#2%cdr x)))) ) (mat cptypes-unsafe @@ -1125,3 +1202,115 @@ '(lambda (f) (box? (box (f)))) '(lambda (f) (#3%$value (f)) #t)) ) + +(mat cptypes-store-immediate + (cptypes-equivalent-expansion? + '(lambda (v) + (let loop ([i 0]) + (when (fx< i (vector-length v)) + (vector-set! v i i) + (loop (fx+ i 1))))) + '(lambda (v) + (let loop ([i 0]) + (when (fx< i (vector-length v)) + (vector-set! v i (#3%$fixmediate i)) + (loop (fx+ i 1)))))) + (cptypes-equivalent-expansion? + '(lambda (x y) (set-box! x (if (vector? y) #t (error 't)))) + '(lambda (x y) (set-box! x (#3%$fixmediate (if (vector? y) #t (error 't)))))) +) + +(mat cptypes-maybe + (cptypes-equivalent-expansion? + '(lambda (x) (when (or (not x) (vector? x)) (box? x))) + '(lambda (x) (when (or (not x) (vector? x)) #f))) + (not (cptypes-equivalent-expansion? + '(lambda (x) (when (or (not x) (vector? x)) (vector? x))) + '(lambda (x) (when (or (not x) (vector? x)) #t)))) + (cptypes-equivalent-expansion? + '(lambda (x) (when (or (not x) (vector? x)) (when x (vector? x)))) + '(lambda (x) (when (or (not x) (vector? x)) (when x #t)))) + (cptypes-equivalent-expansion? + '(lambda (x) (when (or (not x) (char? x)) (when x (char? x)))) + '(lambda (x) (when (or (not x) (char? x)) (when x #t)))) + (cptypes-equivalent-expansion? + '(lambda (s) (define x (string->number s)) (when x (number? x))) + '(lambda (s) (define x (string->number s)) (when x #t))) + (cptypes-equivalent-expansion? + '(lambda (p) (define x (get-char p)) (not x)) + '(lambda (p) (define x (get-char p)) #f)) + (cptypes-equivalent-expansion? + '(lambda (p) (define x (get-char p)) (box? x)) + '(lambda (p) (define x (get-char p)) #f)) +(cptypes-equivalent-expansion? + '(lambda (p) (define x (get-u8 p)) (when (number? p) (fixnum? p))) + '(lambda (p) (define x (get-u8 p)) (when (number? p) #t))) +) + +(mat cptypes-unreachable + (cptypes-equivalent-expansion? + '(lambda (x) (if (pair? x) (car x) (#3%assert-unreachable))) + '(lambda (x) (#3%car x))) + (not + (cptypes-equivalent-expansion? + '(lambda (x) (if (pair? x) (car x) (#2%assert-unreachable))) + '(lambda (x) (#3%car x)))) +) + +(mat cptypes-bottom + (cptypes-equivalent-expansion? + '(lambda (x) (error 'x "no") (add1 x)) + '(lambda (x) (error 'x "no"))) + (cptypes-equivalent-expansion? + '(lambda (f) (f (error 'x "no") f)) + '(lambda (f) (error 'x "no"))) + (cptypes-equivalent-expansion? + '(lambda (f) ((error 'x "no") f f)) + '(lambda (f) (error 'x "no"))) + (cptypes-equivalent-expansion? + '(lambda (x) (if (error 'x "no") (add1 x) (sub1 x))) + '(lambda (x) (error 'x "no"))) + (cptypes-equivalent-expansion? + '(lambda (x) (+ (error 'x "no") x)) + '(lambda (x) (error 'x "no"))) + (cptypes-equivalent-expansion? + '(lambda (x) (list x (add1 x) (error 'x "no") (sub1 x))) + '(lambda (x) (error 'x "no"))) + (cptypes-equivalent-expansion? + '(lambda (x) (apply x (add1 x) (error 'x "no") (sub1 x))) + '(lambda (x) (error 'x "no"))) + (cptypes-equivalent-expansion? + '(lambda (x) (apply (error 'x "no") (add1 x) (sub1 x))) + '(lambda (x) (error 'x "no"))) + (cptypes-equivalent-expansion? + '(lambda (x) (let* ([x (add1 x)] [y (error 'x "no")]) (+ x y))) + '(lambda (x) (add1 x) (error 'x "no"))) + (cptypes-equivalent-expansion? + '(lambda (x) (list (if (odd? x) (error 'x "no") (error 'x "nah")) 17)) + '(lambda (x) (if (odd? x) (error 'x "no") (error 'x "nah")))) + (cptypes-equivalent-expansion? + '(let ([x #f]) (case-lambda [() x] [(y) (set! x (error 'x "no"))])) + '(let ([x #f]) (case-lambda [() x] [(y) (error 'x "no")]))) + + (cptypes-equivalent-expansion? + '(lambda (x) (+ (call-setting-continuation-attachment 'a (lambda () (error 'x "no"))) 1)) + '(lambda (x) (#%$value (call-setting-continuation-attachment 'a (lambda () (error 'x "no")))))) + (not + (cptypes-equivalent-expansion? + '(lambda (x) (+ (call-setting-continuation-attachment 'a (lambda () (error 'x "no"))) 1)) + '(lambda (x) (call-setting-continuation-attachment 'a (lambda () (error 'x "no")))))) + (cptypes-equivalent-expansion? + '(lambda (x) (+ (call-getting-continuation-attachment 'a (lambda (a) (error 'x "no"))) 1)) + '(lambda (x) (#%$value (call-getting-continuation-attachment 'a (lambda (a) (error 'x "no")))))) + (not + (cptypes-equivalent-expansion? + '(lambda (x) (+ (call-getting-continuation-attachment 'a (lambda (a) (error 'x "no"))) 1)) + '(lambda (x) (call-getting-continuation-attachment 'a (lambda (a) (error 'x "no")))))) + (cptypes-equivalent-expansion? + '(lambda (x) (+ (call-consuming-continuation-attachment 'a (lambda (a) (error 'x "no"))) 1)) + '(lambda (x) (#%$value (call-consuming-continuation-attachment 'a (lambda (a) (error 'x "no")))))) + (not + (cptypes-equivalent-expansion? + '(lambda (x) (+ (call-consuming-continuation-attachment 'a (lambda (a) (error 'x "no"))) 1)) + '(lambda (x) (call-consuming-continuation-attachment 'a (lambda (a) (error 'x "no")))))) +) diff --git a/src/ChezScheme/mats/date.ms b/src/ChezScheme/mats/date.ms index 72c2f464f2..31d3230b74 100644 --- a/src/ChezScheme/mats/date.ms +++ b/src/ChezScheme/mats/date.ms @@ -506,6 +506,11 @@ (and (date? $date-d5) (not (time? $date-d5)))) (date? (make-date 0 0 0 0 1 1 1970 -24)) (date? (make-date 999999999 59 59 23 31 12 2007 24)) + (begin + (define $date-d8 (make-date 999999999 59 59 23 31 12 2007 24)) + #t) + (eqv? (fixnum? 999999999) + (fixnum? (date-nanosecond $date-d8))) (eqv? (date-nanosecond $date-d1) 1) (eqv? (date-second $date-d1) 2) (eqv? (date-minute $date-d1) 3) diff --git a/src/ChezScheme/mats/examples.ms b/src/ChezScheme/mats/examples.ms index f92c5d16d5..99535c6a62 100644 --- a/src/ChezScheme/mats/examples.ms +++ b/src/ChezScheme/mats/examples.ms @@ -42,6 +42,8 @@ (load (format "~a/~a.ss" *examples-directory* str) eval) #t])) +(define (example-file file) (format "~a/~a" *mats-dir* file)) + (define file=? (lambda (fn1 fn2) (let ([p1 (open-input-file fn1)] [p2 (open-input-file fn2)]) @@ -96,8 +98,8 @@ edit> (examples-mat freq ("freq") ;; freq.in and freq.out come from example in TSPL (begin (delete-file "testfile.freq" #f) #t) - (begin (frequency "freq.in" "testfile.freq") - (file=? "testfile.freq" "freq.out")) + (begin (frequency (example-file "freq.in") "testfile.freq") + (file=? "testfile.freq" (example-file "freq.out"))) ) ;-------- freq.in: -------- @@ -133,8 +135,8 @@ edit> ; ) (examples-mat m4 ("m4") - (begin (m4 "testfile.m4" "m4test.in") - (file=? "m4test.out" "testfile.m4")) + (begin (m4 "testfile.m4" (example-file "m4test.in")) + (file=? (example-file "m4test.out") "testfile.m4")) ) (examples-mat macro ("macro") diff --git a/src/ChezScheme/mats/foreign.ms b/src/ChezScheme/mats/foreign.ms index 6ff0133bfc..faf37cc0d3 100644 --- a/src/ChezScheme/mats/foreign.ms +++ b/src/ChezScheme/mats/foreign.ms @@ -179,43 +179,45 @@ (x v ...)) (+ v ...))))))))) +(define foreign1.so (format "~a/foreign1.so" *mats-dir*)) + (machine-case [(i3ob ti3ob a6ob ta6ob a6s2 ta6s2 i3s2 ti3s2 i3qnx ti3qnx) (mat load-shared-object - (file-exists? "foreign1.so") - (begin (load-shared-object "./foreign1.so") #t) + (file-exists? foreign1.so) + (begin (load-shared-object foreign1.so) #t) (begin (load-shared-object "libc.so") #t) (error? (load-shared-object 3)) ) ] [(i3le ti3le a6le ta6le arm32le tarm32le arm64le tarm64le ppc32le tppc32le) (mat load-shared-object - (file-exists? "foreign1.so") - (begin (load-shared-object "./foreign1.so") #t) + (file-exists? foreign1.so) + (begin (load-shared-object foreign1.so) #t) (begin (load-shared-object "libc.so.6") #t) (error? (load-shared-object 3)) ) ] [(i3fb ti3fb a6fb ta6fb) (mat load-shared-object - (file-exists? "foreign1.so") - (begin (load-shared-object "./foreign1.so") #t) + (file-exists? foreign1.so) + (begin (load-shared-object foreign1.so) #t) (begin (load-shared-object "libc.so.7") #t) (error? (load-shared-object 3)) ) ] [(i3nb ti3nb a6nb ta6nb) (mat load-shared-object - (file-exists? "foreign1.so") - (begin (load-shared-object "./foreign1.so") #t) + (file-exists? foreign1.so) + (begin (load-shared-object foreign1.so) #t) (begin (load-shared-object "libc.so") #t) (error? (load-shared-object 3)) ) ] [(i3nt ti3nt a6nt ta6nt) (mat load-shared-object - (file-exists? "foreign1.so") - (begin (load-shared-object "foreign1.so") #t) + (file-exists? foreign1.so) + (begin (load-shared-object foreign1.so) #t) (begin (load-shared-object "msvcrt.dll") #t) (begin (load-shared-object "kernel32.dll") #t) (error? (load-shared-object 3)) @@ -223,8 +225,8 @@ ] [(i3osx ti3osx a6osx ta6osx ppc32osx tppc32osx arm64osx tarm64osx) (mat load-shared-object - (file-exists? "foreign1.so") - (begin (load-shared-object "./foreign1.so") #t) + (file-exists? foreign1.so) + (begin (load-shared-object foreign1.so) #t) (begin (load-shared-object "libc.dylib") #t) #t (error? (load-shared-object 3)) @@ -2531,7 +2533,7 @@ (let () (define *m*) (define *k*) - (define ip (open-file-input-port "mat.ss")) + (define ip (open-file-input-port (format "~a/mat.ss" *mats-dir*))) (define-ftype foo (function (fixnum fixnum) fixnum)) (define f (lambda (n m) @@ -3298,3 +3300,105 @@ 37))]) ]) + +(mat reference-bytevector + (error? (make-reference-bytevector -1)) + (error? (bytevector-reference-ref #vu8(1 2 3) 0)) + (error? (bytevector-reference-ref (make-reference-bytevector 8) -8)) + (error? (bytevector-reference-ref (make-reference-bytevector 8) 'oops)) + (error? (bytevector-reference*-ref (make-reference-bytevector 8) -8)) + (error? (bytevector-reference*-ref (make-reference-bytevector 8) 'oops)) + (error? (reference-address->object #f)) + (error? (reference*-address->object #f)) + + (not (reference-bytevector? #vu8(1 2 3))) + (not (reference-bytevector? 7)) + (begin + (define $reftest-bv (make-reference-bytevector (* 2 (foreign-sizeof 'ptr)))) + (reference-bytevector? $reftest-bv)) + (eqv? (* 2 (foreign-sizeof 'ptr)) (bytevector-length $reftest-bv)) + (eq? #f (bytevector-reference-ref $reftest-bv 0)) + (begin + (define $reftest-bv2 (bytevector 1 2 3 4 5 6)) + (bytevector-reference-set! $reftest-bv 0 $reftest-bv2) + (collect) + (eq? $reftest-bv2 (bytevector-reference-ref $reftest-bv 0))) + (with-interrupts-disabled + (eqv? (if (= (foreign-sizeof 'ptr) 8) + (bytevector-u64-native-ref $reftest-bv 0) + (bytevector-u32-native-ref $reftest-bv 0)) + (object->reference-address $reftest-bv2))) + (with-interrupts-disabled + (and (eq? $reftest-bv2 + (reference-address->object (object->reference-address $reftest-bv2))) + (eq? $reftest-bv2 + (reference*-address->object (object->reference-address $reftest-bv2))))) + (begin + (define $reftest-bv3 (bytevector 5 6 7 8)) + (bytevector-reference-set! $reftest-bv (foreign-sizeof 'ptr) $reftest-bv3) + (collect) + (eq? $reftest-bv2 (bytevector-reference-ref $reftest-bv 0))) + (eq? $reftest-bv3 (bytevector-reference-ref $reftest-bv (foreign-sizeof 'ptr))) + (eq? $reftest-bv3 (bytevector-reference*-ref $reftest-bv (foreign-sizeof 'ptr))) + + (let () + (lock-object $reftest-bv3) + (let ([p (if (= (foreign-sizeof 'ptr) 8) + (bytevector-u64-native-ref $reftest-bv 8) + (bytevector-u32-native-ref $reftest-bv 4))]) + (foreign-set! 'unsigned-8 p 1 77) + (equal? $reftest-bv3 #vu8(5 77 7 8)))) + + (begin + (unlock-object $reftest-bv3) + (define $reftest-mem4 (foreign-alloc 20)) + (if (= (foreign-sizeof 'ptr) 8) + (bytevector-u64-native-set! $reftest-bv 8 $reftest-mem4) + (bytevector-u32-native-set! $reftest-bv 4 $reftest-mem4)) + (eqv? $reftest-mem4 (bytevector-reference*-ref $reftest-bv (foreign-sizeof 'ptr)))) + + (begin + (foreign-free $reftest-mem4) + (define $reftest-flv (flvector 3.0 6.0 7.0)) + (bytevector-reference-set! $reftest-bv 0 $reftest-flv) + (collect) + (eq? $reftest-flv (bytevector-reference-ref $reftest-bv 0))) + (with-interrupts-disabled + (eqv? (if (= (foreign-sizeof 'ptr) 8) + (bytevector-u64-native-ref $reftest-bv 0) + (bytevector-u32-native-ref $reftest-bv 0)) + (object->reference-address $reftest-flv))) + (with-interrupts-disabled + (eq? $reftest-flv + (reference-address->object (object->reference-address $reftest-flv)))) + + (let () + (lock-object $reftest-flv) + (let ([p (if (= (foreign-sizeof 'ptr) 8) + (bytevector-u64-native-ref $reftest-bv 0) + (bytevector-u32-native-ref $reftest-bv 0))]) + (foreign-set! 'double p 8 77.0) + (equal? $reftest-flv #vfl(3.0 77.0 7.0)))) + + (let ([b (box 45)]) + (bytevector-reference-set! $reftest-bv 0 b) + (collect) + (eq? b (bytevector-reference-ref $reftest-bv 0))) + + (reference-bytevector? (make-immobile-reference-bytevector 16)) + (let* ([i (make-immobile-reference-bytevector 16)] + [p (#%$object-address i 0)] + [cp (object->reference-address i)]) + (collect) + (and (eqv? p (#%$object-address i 0)) + (eqv? cp (object->reference-address i)))) + (let ([i (make-immobile-reference-bytevector 16)]) + (bytevector-reference-set! i 0 '#(hello)) + (collect) + (equal? '#(hello) (bytevector-reference-ref i 0))) + + (begin + (bytevector-reference-set! $reftest-bv 0 #f) + (eq? #f (bytevector-reference-ref $reftest-bv 0))) +) + diff --git a/src/ChezScheme/mats/ftype.ms b/src/ChezScheme/mats/ftype.ms index 002b9d1d8e..1e53ec26b4 100644 --- a/src/ChezScheme/mats/ftype.ms +++ b/src/ChezScheme/mats/ftype.ms @@ -511,7 +511,7 @@ (define C-test-code (lambda (ftype-defn* path* ndefs npaths i* j*) (let ([ndefs (length ftype-defn*)]) - (printf "#include \"ftype.h\"\n\ + (printf "#include \"~a/ftype.h\"\n\ #define offset(x, y) (int)((char *)&y - (char *)&x)\n\ EXPORT int *foo() {\n\ ~{~a\n~}\ @@ -520,6 +520,7 @@ ~{~a\n~}\ return a;\ }\n" + *mats-dir* (map (lambda (ftype-defn) (format "typedef ~a typedef_~a ~a;" @@ -557,9 +558,11 @@ [(a6osx a6osx) (system (format "cc -m64 -dynamiclib -o ~a ~a" testfile.so testfile.c))] [(a6nt ta6nt) - (system (format "set cl= && ..\\c\\vs.bat amd64 && cl /DWIN32 /Fe~a /LD /MD /nologo ~a" testfile.so testfile.c))] + (system (format "set cl= && ~a\\..\\c\\vs.bat amd64 && cl /DWIN32 /Fe~a /LD /MD /nologo ~a" + (patch-exec-path *mats-dir*) testfile.so testfile.c))] [(i3nt ti3nt) - (system (format "set cl= && ..\\c\\vs.bat x86 && cl /DWIN32 /Fe~a /LD /MD /nologo ~a" testfile.so testfile.c))] + (system (format "set cl= && ~a\\..\\c\\vs.bat x86 && cl /DWIN32 /Fe~a /LD /MD /nologo ~a" + (patch-exec-path *mats-dir*) testfile.so testfile.c))] [(arm32le tarm32le arm64le tarm64le) (system (format "cc -fPIC -shared -o ~a ~a" testfile.so testfile.c))] [else ; this should work for most intel-based systems that use gcc... diff --git a/src/ChezScheme/mats/hash.ms b/src/ChezScheme/mats/hash.ms index 2918e7097a..c76e106310 100644 --- a/src/ChezScheme/mats/hash.ms +++ b/src/ChezScheme/mats/hash.ms @@ -4594,6 +4594,11 @@ (mat ht (begin - (display-string (separate-eval '(parameterize ([source-directories '("." "../s" "../../s")]) (load "ht.ss")))) + (display-string (separate-eval `(parameterize ([source-directories + (list + ,*mats-dir* + ,(format "~a/../s" *mats-dir*) + ,(format "~a/../../s" *mats-dir*))]) + (load "ht.ss")))) #t) ) diff --git a/src/ChezScheme/mats/io.ms b/src/ChezScheme/mats/io.ms index f7fa30ad94..10e9af3883 100644 --- a/src/ChezScheme/mats/io.ms +++ b/src/ChezScheme/mats/io.ms @@ -20,6 +20,8 @@ ; are enabled in io.ss (define (custom-port-warning? x) #t) +(define prettytest.ss (format "~a/prettytest.ss" *mats-dir*)) + (mat port-operations (error? (close-port cons)) ; the following several clauses test various open-file-output-port options @@ -510,12 +512,12 @@ (not (file-port? (open-input-string "hello"))) (or (threaded?) (= (port-file-descriptor (console-input-port)) 0)) (or (threaded?) (= (port-file-descriptor (console-output-port)) 1)) - (> (let ([ip (open-input-file "mat.ss")]) + (> (let ([ip (open-input-file prettytest.ss)]) (let ([n (and (file-port? ip) (port-file-descriptor ip))]) (close-port ip) n)) 1) - (> (let ([ip (open-input-file "mat.ss" 'compressed)]) + (> (let ([ip (open-input-file prettytest.ss 'compressed)]) (let ([n (and (file-port? ip) (port-file-descriptor ip))]) (close-port ip) n)) @@ -2111,7 +2113,7 @@ (error? (file-buffer-size (+ (most-positive-fixnum) 1))) (error? (file-buffer-size 1024.0)) (parameterize ([file-buffer-size (* (file-buffer-size) 2)]) - (let ([ip (open-file-input-port "prettytest.ss")]) + (let ([ip (open-file-input-port prettytest.ss)]) (let ([n (bytevector-length (binary-port-input-buffer ip))]) (close-input-port ip) (eqv? n (file-buffer-size))))) @@ -2162,11 +2164,11 @@ (lambda (op) (put-bytevector op (get-bytevector-all ip)))))) (fnlength ofn)) (define (compress-file-test fmt) - (let ([orig (fnlength "prettytest.ss")] - [low (compress-file "prettytest.ss" "testfile.ss" fmt 'low)] - [medium (compress-file "prettytest.ss" "testfile.ss" fmt 'medium)] - [high (compress-file "prettytest.ss" "testfile.ss" fmt 'high)] - [maximum (compress-file "prettytest.ss" "testfile.ss" fmt 'maximum)]) + (let ([orig (fnlength prettytest.ss)] + [low (compress-file prettytest.ss "testfile.ss" fmt 'low)] + [medium (compress-file prettytest.ss "testfile.ss" fmt 'medium)] + [high (compress-file prettytest.ss "testfile.ss" fmt 'high)] + [maximum (compress-file prettytest.ss "testfile.ss" fmt 'maximum)]) (define-syntax test1 (syntax-rules () [(_ level) @@ -2229,28 +2231,28 @@ (test (+ 1 i))))) (loop)))))))))))) (and - (cmp (open-file-input-port "prettytest.ss") - (open-file-input-port "prettytest.ss")) - (cmp (open-file-input-port "prettytest.ss" (file-options compressed)) - (open-file-input-port "prettytest.ss")) - (cmp (open-file-input-port "prettytest.ss") - (open-file-input-port "prettytest.ss" (file-options compressed))) - (cmp (open-file-input-port "prettytest.ss" (file-options compressed)) - (open-file-input-port "prettytest.ss" (file-options compressed))) + (cmp (open-file-input-port prettytest.ss) + (open-file-input-port prettytest.ss)) + (cmp (open-file-input-port prettytest.ss (file-options compressed)) + (open-file-input-port prettytest.ss)) + (cmp (open-file-input-port prettytest.ss) + (open-file-input-port prettytest.ss (file-options compressed))) + (cmp (open-file-input-port prettytest.ss (file-options compressed)) + (open-file-input-port prettytest.ss (file-options compressed))) (begin - (cp (open-file-input-port "prettytest.ss") + (cp (open-file-input-port prettytest.ss) (open-file-output-port "testfile.ss" (file-options replace compressed))) #t) (cmp (open-file-input-port "testfile.ss" (file-options compressed)) - (open-file-input-port "prettytest.ss")) + (open-file-input-port prettytest.ss)) (not (cmp (open-file-input-port "testfile.ss") - (open-file-input-port "prettytest.ss"))) + (open-file-input-port prettytest.ss))) (begin - (cp (open-file-input-port "prettytest.ss") + (cp (open-file-input-port prettytest.ss) (open-file-output-port "testfile.ss" (file-options no-fail no-truncate append compressed))) #t) (not (cmp (open-file-input-port "testfile.ss" (file-options compressed)) - (open-file-input-port "prettytest.ss"))))) + (open-file-input-port prettytest.ss))))) ; test workaround for bogus gzclose error return for empty input files (and (eqv? (call-with-port @@ -3186,24 +3188,24 @@ (if compressed? (file-options compressed replace) (file-options replace)) (buffer-mode block) (make-transcoder codec))) - (time (cmp (in "prettytest.ss" #f (latin-1-codec)) (in "prettytest.ss" #f (latin-1-codec)))) - (time (cmp (in "prettytest.ss" #t (latin-1-codec)) (in "prettytest.ss" #f (latin-1-codec)))) - (time (cmp (in "prettytest.ss" #f (latin-1-codec)) (in "prettytest.ss" #t (latin-1-codec)))) - (time (cmp (in "prettytest.ss" #t (latin-1-codec)) (in "prettytest.ss" #t (latin-1-codec)))) - (time (cmp (in "prettytest.ss" #f (utf-8-codec)) (in "prettytest.ss" #f (utf-8-codec)))) - (time (cmp (in "prettytest.ss" #t (utf-8-codec)) (in "prettytest.ss" #f (utf-8-codec)))) - (time (cmp (in "prettytest.ss" #f (utf-8-codec)) (in "prettytest.ss" #t (utf-8-codec)))) - (time (cmp (in "prettytest.ss" #t (utf-8-codec)) (in "prettytest.ss" #t (utf-8-codec)))) - (cp (in "prettytest.ss" #f (latin-1-codec)) (out "testfile.ss" #t (latin-1-codec))) - (cmp (in "prettytest.ss" #f (latin-1-codec)) (in "testfile.ss" #t (latin-1-codec))) - (cmp (in "prettytest.ss" #t (latin-1-codec)) (in "testfile.ss" #t (latin-1-codec))) - (cmp (in "prettytest.ss" #f (utf-8-codec)) (in "testfile.ss" #t (utf-8-codec))) - (cmp (in "prettytest.ss" #t (utf-8-codec)) (in "testfile.ss" #t (utf-8-codec))) - (cp (in "prettytest.ss" #f (utf-8-codec)) (out "testfile.ss" #t (utf-8-codec))) - (cmp (in "prettytest.ss" #f (latin-1-codec)) (in "testfile.ss" #t (latin-1-codec))) - (cmp (in "prettytest.ss" #t (latin-1-codec)) (in "testfile.ss" #t (latin-1-codec))) - (cmp (in "prettytest.ss" #f (utf-8-codec)) (in "testfile.ss" #t (utf-8-codec))) - (cmp (in "prettytest.ss" #t (utf-8-codec)) (in "testfile.ss" #t (utf-8-codec))) + (time (cmp (in prettytest.ss #f (latin-1-codec)) (in prettytest.ss #f (latin-1-codec)))) + (time (cmp (in prettytest.ss #t (latin-1-codec)) (in prettytest.ss #f (latin-1-codec)))) + (time (cmp (in prettytest.ss #f (latin-1-codec)) (in prettytest.ss #t (latin-1-codec)))) + (time (cmp (in prettytest.ss #t (latin-1-codec)) (in prettytest.ss #t (latin-1-codec)))) + (time (cmp (in prettytest.ss #f (utf-8-codec)) (in prettytest.ss #f (utf-8-codec)))) + (time (cmp (in prettytest.ss #t (utf-8-codec)) (in prettytest.ss #f (utf-8-codec)))) + (time (cmp (in prettytest.ss #f (utf-8-codec)) (in prettytest.ss #t (utf-8-codec)))) + (time (cmp (in prettytest.ss #t (utf-8-codec)) (in prettytest.ss #t (utf-8-codec)))) + (cp (in prettytest.ss #f (latin-1-codec)) (out "testfile.ss" #t (latin-1-codec))) + (cmp (in prettytest.ss #f (latin-1-codec)) (in "testfile.ss" #t (latin-1-codec))) + (cmp (in prettytest.ss #t (latin-1-codec)) (in "testfile.ss" #t (latin-1-codec))) + (cmp (in prettytest.ss #f (utf-8-codec)) (in "testfile.ss" #t (utf-8-codec))) + (cmp (in prettytest.ss #t (utf-8-codec)) (in "testfile.ss" #t (utf-8-codec))) + (cp (in prettytest.ss #f (utf-8-codec)) (out "testfile.ss" #t (utf-8-codec))) + (cmp (in prettytest.ss #f (latin-1-codec)) (in "testfile.ss" #t (latin-1-codec))) + (cmp (in prettytest.ss #t (latin-1-codec)) (in "testfile.ss" #t (latin-1-codec))) + (cmp (in prettytest.ss #f (utf-8-codec)) (in "testfile.ss" #t (utf-8-codec))) + (cmp (in prettytest.ss #t (utf-8-codec)) (in "testfile.ss" #t (utf-8-codec))) #t) ; test workaround for bogus gzclose error return for empty input files (and @@ -3222,7 +3224,7 @@ (let () (define pretty-test-string (call-with-port - (open-file-input-port "prettytest.ss" + (open-file-input-port prettytest.ss (file-options) (buffer-mode none) (native-transcoder)) get-string-all)) (define cp ; doesn't close the ports @@ -3269,11 +3271,11 @@ (if compressed? (file-options compressed replace) (file-options replace)) (buffer-mode block) (make-transcoder codec))) - (time (cmp (in "prettytest.ss" #f (latin-1-codec)) (open-string-input-port pretty-test-string))) - (time (cmp (open-string-input-port pretty-test-string) (in "prettytest.ss" #f (latin-1-codec)))) + (time (cmp (in prettytest.ss #f (latin-1-codec)) (open-string-input-port pretty-test-string))) + (time (cmp (open-string-input-port pretty-test-string) (in prettytest.ss #f (latin-1-codec)))) (let-values ([(op retrieve) (open-string-output-port)]) (cp (open-string-input-port pretty-test-string) op) - (cmp (in "prettytest.ss" #f (latin-1-codec)) (open-string-input-port (retrieve)))) + (cmp (in prettytest.ss #f (latin-1-codec)) (open-string-input-port (retrieve)))) #t) ) diff --git a/src/ChezScheme/mats/mat.ss b/src/ChezScheme/mats/mat.ss index 8c660d2a75..73c6bd0238 100644 --- a/src/ChezScheme/mats/mat.ss +++ b/src/ChezScheme/mats/mat.ss @@ -230,19 +230,22 @@ (lambda (mat) (unless (string? mat) (errorf 'mat-file "~s is not a string" mat)) - (let ([ifn (format "~a.ms" mat)] [ofn (format "~a/~a.mo" dir mat)]) - (printf "matting ~a with output to ~a~%" ifn ofn) - (delete-file ofn #f) - (parameterize ([mat-output (open-output-file ofn)]) - (dynamic-wind - (lambda () #f) - (lambda () - (let ([go (lambda () (mat-load ifn))] [universe-ct (coverage-table)]) - (if universe-ct - (let-values ([(ct . ignore) (with-profile-tracker go)]) - (store-coverage universe-ct ct (format "~a/~a.covout" dir mat))) - (go)))) - (lambda () (close-output-port (mat-output))))))))) + (let ([ifn (format "~a.ms" mat)] [ofn (format "~a.mo" mat)]) + (parameterize ([current-directory dir] + [source-directories (cons ".." (source-directories))] + [library-directories (cons ".." (library-directories))]) + (printf "matting ~a with output to ~a/~a~%" ifn dir ofn) + (delete-file ofn #f) + (parameterize ([mat-output (open-output-file ofn)]) + (dynamic-wind + (lambda () #f) + (lambda () + (let ([go (lambda () (mat-load ifn))] [universe-ct (coverage-table)]) + (if universe-ct + (let-values ([(ct . ignore) (with-profile-tracker go)]) + (store-coverage universe-ct ct (format "~a.covout" mat))) + (go)))) + (lambda () (close-output-port (mat-output)))))))))) (set! record-run-coverage (lambda (covout th) diff --git a/src/ChezScheme/mats/misc.ms b/src/ChezScheme/mats/misc.ms index 3c88348f38..734b193440 100644 --- a/src/ChezScheme/mats/misc.ms +++ b/src/ChezScheme/mats/misc.ms @@ -1113,7 +1113,7 @@ (let ([th (fork-thread (lambda () (let ([bstr (make-bytevector N)]) - (box-cas! ready #f 'go) + (set-box! ready 'go) ;; Block so that thread becomes deactivated (mutex-acquire m) (mutex-release m) @@ -1514,8 +1514,8 @@ ) (mat source-directories - (equal? (source-directories) '(".")) - (equal? (parameterize ((source-directories (cons "/a" (source-directories)))) + (equal? (separate-eval '(source-directories)) "(\".\")\n") + (equal? (parameterize ((source-directories (list "/a" "."))) (source-directories)) '("/a" ".")) (error? (source-directories 'a)) @@ -1866,7 +1866,7 @@ (begin (with-output-to-file "testfile-sff.ss" (lambda () - (printf "#! ../bin/~a/scheme --script\n" (machine-type)) + (printf "#! ~a --script\n" *scheme*) (pretty-print '(define (hello) (import (chezscheme)) (printf "hello\n"))) (pretty-print '(hello))) 'replace) @@ -1971,13 +1971,13 @@ ) (mat $fasl-file-equal? - (begin + (let ([fn (format "~a/fatfib.ss" *examples-directory*)]) (parameterize ([generate-inspector-information #t]) - (compile-file "../examples/fatfib.ss" "testfile-fatfib1.so")) + (compile-file fn "testfile-fatfib1.so")) (parameterize ([generate-inspector-information #t]) - (compile-file "../examples/fatfib.ss" "testfile-fatfib2.so")) + (compile-file fn "testfile-fatfib2.so")) (parameterize ([generate-inspector-information #f]) - (compile-file "../examples/fatfib.ss" "testfile-fatfib3.so")) + (compile-file fn "testfile-fatfib3.so")) #t) (error? ; not a string (#%$fasl-file-equal? 'testfile-fatfib1.so "testfile-fatfib2.so")) @@ -4797,9 +4797,11 @@ (ok-name? (procedure-name should-be-named-j) "j") (or (not (enable-cp0)) + (#%$suppress-primitive-inlining) (let ([gx (make-guardian)]) (ok-name? (procedure-name gx) "gx"))) (or (not (enable-cp0)) + (#%$suppress-primitive-inlining) (ok-name? (procedure-name (result-should-be-named-mk-CP)) "mk-CP")) (or (not (enable-cp0)) diff --git a/src/ChezScheme/mats/patch-compile-0-f-f-t b/src/ChezScheme/mats/patch-compile-0-f-f-t index 78aaac2c07..2964557177 100644 --- a/src/ChezScheme/mats/patch-compile-0-f-f-t +++ b/src/ChezScheme/mats/patch-compile-0-f-f-t @@ -1,24 +1,24 @@ -*** errors-compile-0-f-f-f 2019-02-12 01:00:43.726170571 -0500 ---- errors-compile-0-f-f-t 2019-02-12 01:14:58.071195602 -0500 +*** errors-compile-0-f-f-f 2021-05-04 16:18:50.000000000 -0600 +--- errors-compile-0-f-f-t 2021-05-04 16:17:06.000000000 -0600 *************** -*** 3660,3666 **** +*** 3995,4001 **** misc.mo:Expected error in mat compute-composition: "compute-composition: invalid generation -1". misc.mo:Expected error in mat compute-composition: "compute-composition: invalid generation "static"". misc.mo:Expected error in mat make-object-finder: "make-object-finder: 17 is not a procedure". ! misc.mo:Expected error in mat make-object-finder: "make-object-finder: invalid generation 5". misc.mo:Expected error in mat make-object-finder: "make-object-finder: invalid generation oldgen". misc.mo:Expected error in mat make-object-finder: "make-object-finder: invalid generation -1". - misc.mo:Expected error in mat make-object-finder: "incorrect number of arguments to #<procedure find-next>". ---- 3660,3666 ---- + misc.mo:Expected error in mat make-object-finder: "incorrect number of arguments 1 to #<procedure find-next>". +--- 3995,4001 ---- misc.mo:Expected error in mat compute-composition: "compute-composition: invalid generation -1". misc.mo:Expected error in mat compute-composition: "compute-composition: invalid generation "static"". misc.mo:Expected error in mat make-object-finder: "make-object-finder: 17 is not a procedure". ! misc.mo:Expected error in mat make-object-finder: "make-object-finder: invalid generation 7". misc.mo:Expected error in mat make-object-finder: "make-object-finder: invalid generation oldgen". misc.mo:Expected error in mat make-object-finder: "make-object-finder: invalid generation -1". - misc.mo:Expected error in mat make-object-finder: "incorrect number of arguments to #<procedure find-next>". + misc.mo:Expected error in mat make-object-finder: "incorrect number of arguments 1 to #<procedure find-next>". *************** -*** 7159,7169 **** +*** 7707,7717 **** 7.mo:Expected error in mat sstats: "set-sstats-gc-bytes!: twelve is not an exact integer". 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation yuk". 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation -1". @@ -30,7 +30,7 @@ 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu". 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu". 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu". ---- 7159,7169 ---- +--- 7707,7717 ---- 7.mo:Expected error in mat sstats: "set-sstats-gc-bytes!: twelve is not an exact integer". 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation yuk". 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation -1". @@ -43,9 +43,9 @@ 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu". 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu". *************** -*** 8595,8607 **** - 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". +*** 9222,9234 **** + 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". @@ -57,9 +57,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". ---- 8595,8607 ---- - 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". +--- 9222,9234 ---- + 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". diff --git a/src/ChezScheme/mats/patch-compile-0-f-t-f b/src/ChezScheme/mats/patch-compile-0-f-t-f index d1b2d42d2e..ecdc602b64 100644 --- a/src/ChezScheme/mats/patch-compile-0-f-t-f +++ b/src/ChezScheme/mats/patch-compile-0-f-t-f @@ -1,5 +1,5 @@ -*** 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 +*** errors-compile-0-f-f-f 2021-02-23 12:07:37.000000000 -0700 +--- errors-compile-0-f-t-f 2021-02-23 11:37:54.000000000 -0700 *************** *** 200,206 **** 3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable a". @@ -182,10 +182,10 @@ 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". *************** -*** 7846,7884 **** +*** 7850,7888 **** 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>". + record.mo:Expected error in mat record23: "make-record-type: cannot extend sealed record type #<record type foo> as bar". ! record.mo:Expected error in mat record25: "invalid value 1.0 for foreign type int". ! record.mo:Expected error in mat record25: "invalid value 2.0 for foreign type unsigned". ! record.mo:Expected error in mat record25: "invalid value three for foreign type unsigned-int". @@ -222,10 +222,10 @@ 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". ---- 7846,7884 ---- +--- 7850,7888 ---- 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>". + record.mo:Expected error in mat record23: "make-record-type: cannot extend sealed record type #<record type foo> as bar". ! record.mo:Expected error in mat record25: "make-r25-bar: invalid value 1.0 for foreign type int". ! record.mo:Expected error in mat record25: "make-r25-bar: invalid value 2.0 for foreign type unsigned". ! record.mo:Expected error in mat record25: "make-r25-bar: invalid value three for foreign type unsigned-int". @@ -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". *************** -*** 7893,7949 **** +*** 7897,7953 **** 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". @@ -276,7 +276,7 @@ ! record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 3 to #<procedure constructor>". ! 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>". + record.mo:Expected error in mat r6rs-records-procedural: "make-record-type-descriptor: cannot extend sealed record type #<record type bar> as foo". record.mo:Expected error in mat r6rs-records-syntactic: "invalid syntax point". ! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 0 to #<procedure constructor>". ! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 1 to #<procedure constructor>". @@ -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". ---- 7893,7949 ---- +--- 7897,7953 ---- 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". @@ -334,7 +334,7 @@ ! record.mo:Expected error in mat r6rs-records-procedural: "incorrect argument count in call (n (+ z 7) w "what?")". ! record.mo:Expected error in mat r6rs-records-procedural: "incorrect argument count in call ((p x 17) y (quote #(oops)))". 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>". + record.mo:Expected error in mat r6rs-records-procedural: "make-record-type-descriptor: cannot extend sealed record type #<record type bar> as foo". record.mo:Expected error in mat r6rs-records-syntactic: "invalid syntax point". ! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 0 to #<procedure make-point>". ! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 1 to #<procedure make-point>". diff --git a/src/ChezScheme/mats/patch-compile-0-t-f-f b/src/ChezScheme/mats/patch-compile-0-t-f-f index 4a1b92c34b..58f13e6f3f 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-11-23 06:11:33.000000000 -0700 ---- errors-compile-0-t-f-f 2020-11-23 05:42:16.000000000 -0700 +*** errors-compile-0-f-f-f 2021-02-23 12:07:37.000000000 -0700 +--- errors-compile-0-t-f-f 2021-02-23 11:44:27.000000000 -0700 *************** *** 168,174 **** 3.mo:Expected error in mat case-lambda: "incorrect number of arguments 2 to #<procedure foo>". @@ -171,8 +171,8 @@ 5_2.mo:Expected error in mat c....r-errors: "cddddr: incorrect list structure (a . b)". ! 5_2.mo:Expected error in mat list*: "incorrect argument count in call (list*)". ! 5_2.mo:Expected error in mat cons*: "incorrect argument count in call (cons*)". - 5_2.mo:Expected error in mat list-ref: "list-ref: a is not a proper list". - 5_2.mo:Expected error in mat list-ref: "list-ref: (a b . c) is not a proper list". + 5_2.mo:Expected error in mat list-ref: "list-ref: index 0 reaches a non-pair in a". + 5_2.mo:Expected error in mat list-ref: "list-ref: index 4 reaches a non-pair in (a b . c)". 5_2.mo:Expected error in mat list-ref: "list-ref: index 4 is out of range for list (a b)". --- 693,700 ---- 5_2.mo:Expected error in mat c....r-errors: "cddadr: incorrect list structure (a . b)". @@ -180,8 +180,8 @@ 5_2.mo:Expected error in mat c....r-errors: "cddddr: incorrect list structure (a . b)". ! 5_2.mo:Expected error in mat list*: "incorrect number of arguments -1 to #<procedure list*>". ! 5_2.mo:Expected error in mat cons*: "incorrect number of arguments -1 to #<procedure cons*>". - 5_2.mo:Expected error in mat list-ref: "list-ref: a is not a proper list". - 5_2.mo:Expected error in mat list-ref: "list-ref: (a b . c) is not a proper list". + 5_2.mo:Expected error in mat list-ref: "list-ref: index 0 reaches a non-pair in a". + 5_2.mo:Expected error in mat list-ref: "list-ref: index 4 reaches a non-pair in (a b . c)". 5_2.mo:Expected error in mat list-ref: "list-ref: index 4 is out of range for list (a b)". *************** *** 781,793 **** @@ -4481,24 +4481,24 @@ 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". *************** -*** 7899,7905 **** +*** 7903,7909 **** 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>". ! record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 3 to #<procedure constructor>". 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>". ---- 7899,7905 ---- + record.mo:Expected error in mat r6rs-records-procedural: "make-record-type-descriptor: cannot extend sealed record type #<record type bar> as foo". +--- 7903,7909 ---- 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>". ! 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: "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>". + record.mo:Expected error in mat r6rs-records-procedural: "make-record-type-descriptor: cannot extend sealed record type #<record type bar> as foo". *************** -*** 7989,8103 **** +*** 7993,8107 **** 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". ---- 7989,8103 ---- +--- 7993,8107 ---- 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". *************** -*** 8120,8242 **** +*** 8124,8246 **** 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". ---- 8120,8242 ---- +--- 8124,8246 ---- 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,7 +4980,7 @@ 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". *************** -*** 8244,8275 **** +*** 8248,8279 **** 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". @@ -5013,7 +5013,7 @@ 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>". ---- 8244,8275 ---- +--- 8248,8279 ---- 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". @@ -5047,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>". *************** -*** 8385,8392 **** +*** 8389,8396 **** 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)". @@ -5056,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>". ---- 8385,8392 ---- +--- 8389,8396 ---- 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)". @@ -5066,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>". *************** -*** 9003,9018 **** +*** 9007,9022 **** 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". @@ -5083,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*>". ---- 9003,9018 ---- +--- 9007,9022 ---- 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". @@ -5101,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*>". *************** -*** 9109,9131 **** +*** 9113,9135 **** 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". @@ -5125,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". ---- 9109,9131 ---- +--- 9113,9135 ---- 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". @@ -5150,7 +5150,7 @@ 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". *************** -*** 9167,9179 **** +*** 9171,9183 **** 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". @@ -5164,7 +5164,7 @@ 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". ---- 9167,9179 ---- +--- 9171,9183 ---- 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". @@ -5179,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". *************** -*** 9228,9240 **** +*** 9232,9244 **** 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". @@ -5193,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". ---- 9228,9240 ---- +--- 9232,9244 ---- 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". @@ -5208,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". *************** -*** 9340,9349 **** +*** 9344,9353 **** 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". @@ -5219,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". ---- 9340,9349 ---- +--- 9344,9353 ---- 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". @@ -5231,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". *************** -*** 9357,9390 **** +*** 9361,9394 **** 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". @@ -5266,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". ---- 9357,9390 ---- +--- 9361,9394 ---- 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". @@ -5302,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". *************** -*** 9394,9437 **** +*** 9398,9441 **** 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". @@ -5347,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". ---- 9394,9437 ---- +--- 9398,9441 ---- 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". @@ -5393,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". *************** -*** 9440,9450 **** +*** 9444,9454 **** 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>". @@ -5405,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". ---- 9440,9450 ---- +--- 9444,9454 ---- 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>". @@ -5418,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". *************** -*** 9504,9513 **** +*** 9508,9517 **** 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". @@ -5429,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". ---- 9504,9513 ---- +--- 9508,9517 ---- 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". @@ -5441,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". *************** -*** 9523,9532 **** +*** 9527,9536 **** 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". @@ -5452,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". ---- 9523,9532 ---- +--- 9527,9536 ---- 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". @@ -5464,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". *************** -*** 9542,9551 **** +*** 9546,9555 **** 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". @@ -5475,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". ---- 9542,9551 ---- +--- 9546,9555 ---- 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". @@ -5487,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". *************** -*** 9561,9571 **** +*** 9565,9575 **** 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". @@ -5499,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". ---- 9561,9571 ---- +--- 9565,9575 ---- 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". @@ -5512,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". *************** -*** 9588,9597 **** +*** 9592,9601 **** 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". @@ -5523,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". ---- 9588,9597 ---- +--- 9592,9601 ---- 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". @@ -5535,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". *************** -*** 9607,9624 **** +*** 9611,9628 **** 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". @@ -5554,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". ---- 9607,9624 ---- +--- 9611,9628 ---- 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". @@ -5574,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". *************** -*** 9626,9632 **** +*** 9630,9636 **** 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". @@ -5582,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". ---- 9626,9632 ---- +--- 9630,9636 ---- 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". @@ -5591,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". *************** -*** 9634,9640 **** +*** 9638,9644 **** 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". @@ -5599,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". ---- 9634,9640 ---- +--- 9638,9644 ---- 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". @@ -5608,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". *************** -*** 9642,9648 **** +*** 9646,9652 **** 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". @@ -5616,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". ---- 9642,9648 ---- +--- 9646,9652 ---- 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". @@ -5625,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". *************** -*** 9650,9656 **** +*** 9654,9660 **** 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". @@ -5633,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". ---- 9650,9656 ---- +--- 9654,9660 ---- 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". @@ -5642,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". *************** -*** 9658,9697 **** +*** 9662,9701 **** 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". @@ -5683,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". ---- 9658,9697 ---- +--- 9662,9701 ---- 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". @@ -5725,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". *************** -*** 9701,9707 **** +*** 9705,9711 **** 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". @@ -5733,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". ---- 9701,9707 ---- +--- 9705,9711 ---- 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". @@ -5742,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". *************** -*** 9711,9800 **** +*** 9715,9804 **** 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". @@ -5833,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". ---- 9711,9800 ---- +--- 9715,9804 ---- 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". @@ -5925,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". *************** -*** 9813,9848 **** +*** 9817,9852 **** 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". @@ -5962,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". ---- 9813,9848 ---- +--- 9817,9852 ---- 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". @@ -6000,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". *************** -*** 9850,9857 **** +*** 9854,9861 **** 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". @@ -6009,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". ---- 9850,9857 ---- +--- 9854,9861 ---- 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". @@ -6019,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". *************** -*** 9859,9865 **** +*** 9863,9869 **** 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". @@ -6027,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". ---- 9859,9865 ---- +--- 9863,9869 ---- 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". @@ -6036,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". *************** -*** 9867,9873 **** +*** 9871,9877 **** 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". @@ -6044,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". ---- 9867,9873 ---- +--- 9871,9877 ---- 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". @@ -6053,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". *************** -*** 9875,9888 **** +*** 9879,9892 **** 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". @@ -6068,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". ---- 9875,9888 ---- +--- 9879,9892 ---- 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". @@ -6084,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". *************** -*** 9928,9934 **** +*** 9932,9938 **** 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". @@ -6092,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". ---- 9928,9934 ---- +--- 9932,9938 ---- 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". @@ -6101,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". *************** -*** 9938,9951 **** +*** 9942,9955 **** 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". @@ -6116,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"". ---- 9938,9951 ---- +--- 9942,9955 ---- 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". @@ -6132,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"". *************** -*** 9980,9987 **** +*** 9984,9991 **** 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". @@ -6141,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"". ---- 9980,9987 ---- +--- 9984,9991 ---- 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". @@ -6151,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"". *************** -*** 10480,10492 **** +*** 10484,10496 **** 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". @@ -6165,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". ---- 10480,10492 ---- +--- 10484,10496 ---- 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". @@ -6180,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". *************** -*** 10514,10585 **** +*** 10518,10589 **** 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". @@ -6253,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". ---- 10514,10585 ---- +--- 10518,10589 ---- 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". @@ -6327,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". *************** -*** 10587,10600 **** +*** 10591,10604 **** 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". @@ -6342,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". ---- 10587,10600 ---- +--- 10591,10604 ---- 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". @@ -6358,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". *************** -*** 10620,10680 **** +*** 10624,10684 **** 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"". @@ -6420,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". ---- 10620,10680 ---- +--- 10624,10684 ---- 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-0-t-f-t b/src/ChezScheme/mats/patch-compile-0-t-f-t index cfe0bed51c..4dda700169 100644 --- a/src/ChezScheme/mats/patch-compile-0-t-f-t +++ b/src/ChezScheme/mats/patch-compile-0-t-f-t @@ -1,24 +1,24 @@ -*** errors-compile-0-t-f-f 2019-02-12 01:30:17.595345564 -0500 ---- errors-compile-0-t-f-t 2019-02-12 01:05:15.184684883 -0500 +*** errors-compile-0-t-f-f 2021-05-04 16:23:16.000000000 -0600 +--- errors-compile-0-t-f-t 2021-05-04 16:17:10.000000000 -0600 *************** -*** 3660,3666 **** +*** 3995,4001 **** misc.mo:Expected error in mat compute-composition: "compute-composition: invalid generation -1". misc.mo:Expected error in mat compute-composition: "compute-composition: invalid generation "static"". misc.mo:Expected error in mat make-object-finder: "make-object-finder: 17 is not a procedure". ! misc.mo:Expected error in mat make-object-finder: "make-object-finder: invalid generation 5". misc.mo:Expected error in mat make-object-finder: "make-object-finder: invalid generation oldgen". misc.mo:Expected error in mat make-object-finder: "make-object-finder: invalid generation -1". - misc.mo:Expected error in mat make-object-finder: "incorrect number of arguments to #<procedure find-next>". ---- 3660,3666 ---- + misc.mo:Expected error in mat make-object-finder: "incorrect number of arguments 1 to #<procedure find-next>". +--- 3995,4001 ---- misc.mo:Expected error in mat compute-composition: "compute-composition: invalid generation -1". misc.mo:Expected error in mat compute-composition: "compute-composition: invalid generation "static"". misc.mo:Expected error in mat make-object-finder: "make-object-finder: 17 is not a procedure". ! misc.mo:Expected error in mat make-object-finder: "make-object-finder: invalid generation 2". misc.mo:Expected error in mat make-object-finder: "make-object-finder: invalid generation oldgen". misc.mo:Expected error in mat make-object-finder: "make-object-finder: invalid generation -1". - misc.mo:Expected error in mat make-object-finder: "incorrect number of arguments to #<procedure find-next>". + misc.mo:Expected error in mat make-object-finder: "incorrect number of arguments 1 to #<procedure find-next>". *************** -*** 7159,7169 **** +*** 7707,7717 **** 7.mo:Expected error in mat sstats: "set-sstats-gc-bytes!: twelve is not an exact integer". 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation yuk". 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation -1". @@ -30,7 +30,7 @@ 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu". 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu". 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu". ---- 7159,7169 ---- +--- 7707,7717 ---- 7.mo:Expected error in mat sstats: "set-sstats-gc-bytes!: twelve is not an exact integer". 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation yuk". 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation -1". diff --git a/src/ChezScheme/mats/patch-compile-0-t-t-f b/src/ChezScheme/mats/patch-compile-0-t-t-f index e9f0921ec6..bd895f574f 100644 --- a/src/ChezScheme/mats/patch-compile-0-t-t-f +++ b/src/ChezScheme/mats/patch-compile-0-t-t-f @@ -1,7 +1,7 @@ -*** errors-compile-0-t-f-f 2019-02-12 01:30:17.595345564 -0500 ---- errors-compile-0-t-t-f 2019-02-12 01:20:09.150192807 -0500 +*** errors-compile-0-t-f-f 2021-05-04 16:23:16.000000000 -0600 +--- errors-compile-0-t-t-f 2021-05-04 16:40:04.000000000 -0600 *************** -*** 144,150 **** +*** 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". @@ -9,7 +9,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". ---- 144,150 ---- +--- 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". @@ -18,7 +18,7 @@ 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". *************** -*** 3702,3708 **** +*** 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". @@ -26,7 +26,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". ---- 3702,3708 ---- +--- 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". @@ -35,7 +35,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". *************** -*** 7169,7176 **** +*** 7717,7724 **** 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". @@ -44,7 +44,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)". ---- 7169,7176 ---- +--- 7717,7724 ---- 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". @@ -54,7 +54,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)". *************** -*** 7178,7192 **** +*** 7726,7740 **** 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". @@ -70,7 +70,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". ---- 7178,7192 ---- +--- 7726,7740 ---- 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". @@ -87,7 +87,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". *************** -*** 7199,7224 **** +*** 7747,7772 **** 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>". @@ -114,7 +114,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". ---- 7199,7224 ---- +--- 7747,7772 ---- 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>". @@ -142,10 +142,10 @@ 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". *************** -*** 7349,7387 **** +*** 7901,7939 **** 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>". + record.mo:Expected error in mat record23: "make-record-type: cannot extend sealed record type #<record type foo> as bar". ! record.mo:Expected error in mat record25: "invalid value 1.0 for foreign type int". ! record.mo:Expected error in mat record25: "invalid value 2.0 for foreign type unsigned". ! record.mo:Expected error in mat record25: "invalid value three for foreign type unsigned-int". @@ -157,7 +157,7 @@ ! 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". - record.mo:Expected error in mat record25: "incorrect number of arguments to #<procedure make-r25-bar>". + record.mo:Expected error in mat record25: "incorrect number of arguments 18 to #<procedure make-r25-bar>". ! 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". @@ -182,10 +182,10 @@ 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". ---- 7349,7387 ---- +--- 7901,7939 ---- 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>". + record.mo:Expected error in mat record23: "make-record-type: cannot extend sealed record type #<record type foo> as bar". ! record.mo:Expected error in mat record25: "make-r25-bar: invalid value 1.0 for foreign type int". ! record.mo:Expected error in mat record25: "make-r25-bar: invalid value 2.0 for foreign type unsigned". ! record.mo:Expected error in mat record25: "make-r25-bar: invalid value three for foreign type unsigned-int". @@ -197,7 +197,7 @@ ! record.mo:Expected error in mat record25: "make-r25-bar: invalid value #\9 for foreign type uptr". ! record.mo:Expected error in mat record25: "make-r25-bar: invalid value 10 for foreign type float". ! record.mo:Expected error in mat record25: "make-r25-bar: invalid value 11.0+0.0i for foreign type double". - record.mo:Expected error in mat record25: "incorrect number of arguments to #<procedure make-r25-bar>". + record.mo:Expected error in mat record25: "incorrect number of arguments 18 to #<procedure make-r25-bar>". ! record.mo:Expected error in mat record25: "make-r25-bar: invalid value 12.0 for foreign type long-long". ! record.mo:Expected error in mat record25: "make-r25-bar: invalid value 13.0 for foreign type unsigned-long-long". ! record.mo:Expected error in mat record25: "set-r25-bar-a!: invalid value 3.0 for foreign type int". @@ -223,77 +223,77 @@ 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". *************** -*** 7407,7442 **** +*** 7959,7994 **** 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>". + record.mo:Expected error in mat r6rs-records-procedural: "make-record-type-descriptor: cannot extend sealed record type #<record type bar> as foo". record.mo:Expected error in mat r6rs-records-syntactic: "invalid syntax point". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure constructor>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure constructor>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure constructor>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure predicate>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure predicate>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 0 to #<procedure constructor>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 1 to #<procedure constructor>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 3 to #<procedure constructor>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 0 to #<procedure predicate>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 2 to #<procedure predicate>". record.mo:Expected error in mat r6rs-records-syntactic: "variable point-x-set! is not bound". record.mo:Expected error in mat r6rs-records-syntactic: "variable point-y-set! is not bound". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure accessor>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure accessor>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 0 to #<procedure accessor>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 2 to #<procedure accessor>". record.mo:Expected error in mat r6rs-records-syntactic: "record-mutator: field 0 of #<record type point> is immutable". record.mo:Expected error in mat r6rs-records-syntactic: "record-mutator: field 1 of #<record type point> is immutable". record.mo:Expected error in mat r6rs-records-syntactic: "invalid syntax point". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure constructor>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure constructor>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure constructor>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure predicate>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure predicate>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 0 to #<procedure constructor>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 1 to #<procedure constructor>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 3 to #<procedure constructor>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 0 to #<procedure predicate>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 2 to #<procedure predicate>". record.mo:Expected error in mat r6rs-records-syntactic: "variable point-x-set! is not bound". record.mo:Expected error in mat r6rs-records-syntactic: "variable point-y-set! is not bound". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure accessor>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure accessor>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure mutator>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure mutator>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure mutator>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure mutator>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure mutator>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure mutator>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure mutator>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure mutator>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure mutator>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 0 to #<procedure accessor>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 2 to #<procedure accessor>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 0 to #<procedure mutator>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 1 to #<procedure mutator>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 3 to #<procedure mutator>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 0 to #<procedure mutator>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 1 to #<procedure mutator>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 3 to #<procedure mutator>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 0 to #<procedure mutator>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 1 to #<procedure mutator>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 3 to #<procedure mutator>". record.mo:Expected error in mat r6rs-records-syntactic: "record-rtd: #<ex3> is not a record". record.mo:Expected error in mat r6rs-records-syntactic: "record-rtd: #<ex3> is not a record". record.mo:Expected error in mat r6rs-records-syntactic: "parent record type is sealed ex3". ---- 7407,7442 ---- +--- 7959,7994 ---- 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>". + record.mo:Expected error in mat r6rs-records-procedural: "make-record-type-descriptor: cannot extend sealed record type #<record type bar> as foo". record.mo:Expected error in mat r6rs-records-syntactic: "invalid syntax point". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure make-point>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure make-point>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure make-point>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure point?>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure point?>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 0 to #<procedure make-point>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 1 to #<procedure make-point>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 3 to #<procedure make-point>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 0 to #<procedure point?>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 2 to #<procedure point?>". record.mo:Expected error in mat r6rs-records-syntactic: "variable point-x-set! is not bound". record.mo:Expected error in mat r6rs-records-syntactic: "variable point-y-set! is not bound". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure point-x>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure point-y>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 0 to #<procedure point-x>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 2 to #<procedure point-y>". record.mo:Expected error in mat r6rs-records-syntactic: "record-mutator: field 0 of #<record type point> is immutable". record.mo:Expected error in mat r6rs-records-syntactic: "record-mutator: field 1 of #<record type point> is immutable". record.mo:Expected error in mat r6rs-records-syntactic: "invalid syntax point". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure make-point>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure make-point>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure make-point>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure point?>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure point?>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 0 to #<procedure make-point>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 1 to #<procedure make-point>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 3 to #<procedure make-point>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 0 to #<procedure point?>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 2 to #<procedure point?>". record.mo:Expected error in mat r6rs-records-syntactic: "variable point-x-set! is not bound". record.mo:Expected error in mat r6rs-records-syntactic: "variable point-y-set! is not bound". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure point-x>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure point-y>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure frob-widget-set!>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure frob-widget-set!>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure frob-widget-set!>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure frob-widget-set!>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure frob-widget-set!>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure frob-widget-set!>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure setwid!>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure setwid!>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure setwid!>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 0 to #<procedure point-x>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 2 to #<procedure point-y>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 0 to #<procedure frob-widget-set!>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 1 to #<procedure frob-widget-set!>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 3 to #<procedure frob-widget-set!>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 0 to #<procedure frob-widget-set!>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 1 to #<procedure frob-widget-set!>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 3 to #<procedure frob-widget-set!>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 0 to #<procedure setwid!>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 1 to #<procedure setwid!>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 3 to #<procedure setwid!>". record.mo:Expected error in mat r6rs-records-syntactic: "record-rtd: #<ex3> is not a record". record.mo:Expected error in mat r6rs-records-syntactic: "record-rtd: #<ex3> is not a record". record.mo:Expected error in mat r6rs-records-syntactic: "parent record type is sealed ex3". diff --git a/src/ChezScheme/mats/patch-interpret-0-f-f-f b/src/ChezScheme/mats/patch-interpret-0-f-f-f index 886fe6888e..52ba046b39 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-11-23 06:11:33.000000000 -0700 ---- errors-interpret-0-f-f-f 2020-11-23 05:51:54.000000000 -0700 +*** errors-compile-0-f-f-f 2021-02-23 12:07:37.000000000 -0700 +--- errors-interpret-0-f-f-f 2021-02-23 11:52:01.000000000 -0700 *************** *** 18,25 **** primvars.mo:Expected error testing (environment (quote (chezscheme)) (quote (chezscheme)) (quote #f)): Exception in environment: invalid library reference #f @@ -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". *************** -*** 7857,7863 **** +*** 7861,7867 **** 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". ---- 7857,7863 ---- +--- 7861,7867 ---- 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,24 +243,24 @@ 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". *************** -*** 7899,7905 **** +*** 7903,7909 **** 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>". ! record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 3 to #<procedure constructor>". 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>". ---- 7899,7905 ---- + record.mo:Expected error in mat r6rs-records-procedural: "make-record-type-descriptor: cannot extend sealed record type #<record type bar> as foo". +--- 7903,7909 ---- 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>". ! 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: "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>". + record.mo:Expected error in mat r6rs-records-procedural: "make-record-type-descriptor: cannot extend sealed record type #<record type bar> as foo". *************** -*** 9167,9179 **** +*** 9171,9183 **** 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". @@ -274,7 +274,7 @@ 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". ---- 9167,9179 ---- +--- 9171,9183 ---- 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". @@ -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". *************** -*** 9953,9977 **** +*** 9957,9981 **** 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". ---- 9953,9977 ---- +--- 9957,9981 ---- 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". *************** -*** 9984,10015 **** +*** 9988,10019 **** 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>". ---- 9984,10015 ---- +--- 9988,10019 ---- 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>". *************** -*** 10017,10042 **** +*** 10021,10046 **** 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>". ---- 10017,10042 ---- +--- 10021,10046 ---- 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>". *************** -*** 10048,10082 **** +*** 10052,10086 **** 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>". ---- 10048,10082 ---- +--- 10052,10086 ---- 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>". *************** -*** 10683,10692 **** +*** 10687,10696 **** 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". ---- 10683,10692 ---- +--- 10687,10696 ---- 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 7d0b20bfc3..7ac73279cf 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-11-23 05:33:39.000000000 -0700 ---- errors-interpret-0-f-t-f 2020-11-23 06:01:59.000000000 -0700 +*** errors-compile-0-f-t-f 2021-02-23 11:37:54.000000000 -0700 +--- errors-interpret-0-f-t-f 2021-02-23 12:00:05.000000000 -0700 *************** *** 18,25 **** primvars.mo:Expected error testing (environment (quote (chezscheme)) (quote (chezscheme)) (quote #f)): Exception in environment: invalid library reference #f @@ -306,10 +306,10 @@ 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". *************** -*** 7846,7884 **** +*** 7850,7888 **** 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>". + record.mo:Expected error in mat record23: "make-record-type: cannot extend sealed record type #<record type foo> as bar". ! record.mo:Expected error in mat record25: "make-r25-bar: invalid value 1.0 for foreign type int". ! record.mo:Expected error in mat record25: "make-r25-bar: invalid value 2.0 for foreign type unsigned". ! record.mo:Expected error in mat record25: "make-r25-bar: invalid value three for foreign type unsigned-int". @@ -346,10 +346,10 @@ 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". ---- 7846,7884 ---- +--- 7850,7888 ---- 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>". + record.mo:Expected error in mat record23: "make-record-type: cannot extend sealed record type #<record type foo> as bar". ! record.mo:Expected error in mat record25: "invalid value 1.0 for foreign type int". ! record.mo:Expected error in mat record25: "invalid value 2.0 for foreign type unsigned". ! record.mo:Expected error in mat record25: "invalid value three for foreign type unsigned-int". @@ -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". *************** -*** 7893,7949 **** +*** 7897,7953 **** 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". @@ -400,7 +400,7 @@ ! record.mo:Expected error in mat r6rs-records-procedural: "incorrect argument count in call (n (+ z 7) w "what?")". ! record.mo:Expected error in mat r6rs-records-procedural: "incorrect argument count in call ((p x 17) y (quote #(oops)))". 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>". + record.mo:Expected error in mat r6rs-records-procedural: "make-record-type-descriptor: cannot extend sealed record type #<record type bar> as foo". record.mo:Expected error in mat r6rs-records-syntactic: "invalid syntax point". ! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 0 to #<procedure make-point>". ! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 1 to #<procedure make-point>". @@ -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". ---- 7893,7949 ---- +--- 7897,7953 ---- 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". @@ -458,7 +458,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: "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>". + record.mo:Expected error in mat r6rs-records-procedural: "make-record-type-descriptor: cannot extend sealed record type #<record type bar> as foo". record.mo:Expected error in mat r6rs-records-syntactic: "invalid syntax point". ! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 0 to #<procedure constructor>". ! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 1 to #<procedure constructor>". @@ -504,7 +504,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: "cannot extend define-record-type parent fratrat". *************** -*** 9167,9179 **** +*** 9171,9183 **** 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". @@ -518,7 +518,7 @@ 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". ---- 9167,9179 ---- +--- 9171,9183 ---- 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". @@ -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". *************** -*** 10683,10692 **** +*** 10687,10696 **** 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". ---- 10683,10692 ---- +--- 10687,10696 ---- 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-t-f-f b/src/ChezScheme/mats/patch-interpret-0-t-f-f index 97369bd840..4d5edd228c 100644 --- a/src/ChezScheme/mats/patch-interpret-0-t-f-f +++ b/src/ChezScheme/mats/patch-interpret-0-t-f-f @@ -1,142 +1,154 @@ -*** errors-compile-0-t-f-f 2019-02-12 01:30:17.595345564 -0500 ---- errors-interpret-0-t-f-f 2019-02-12 03:03:25.069665634 -0500 +*** errors-compile-0-t-f-f 2021-05-04 16:23:16.000000000 -0600 +--- errors-interpret-0-t-f-f 2021-05-04 16:34:53.000000000 -0600 *************** -*** 1,7 **** +*** 18,25 **** + primvars.mo:Expected error testing (environment (quote (chezscheme)) (quote (chezscheme)) (quote #f)): Exception in environment: invalid library reference #f + primvars.mo:Expected error testing (base-exception-handler (quote 0)): Exception in default-exception-handler: 0 is not a procedure + primvars.mo:Expected error testing (base-exception-handler (quote #f)): Exception in default-exception-handler: #f is not a procedure +! primvars.mo:Expected error testing (eval 1.0+2.0i (quote ((a . b)))): Exception in compile: ((a . b)) is not an environment +! primvars.mo:Expected error testing (eval 1.0+2.0i (quote #f)): Exception in compile: #f is not an environment + primvars.mo:Expected error testing (expand 1.0+2.0i (quote ((a . b)))): Exception in sc-expand: ((a . b)) is not an environment + 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 +--- 18,25 ---- + primvars.mo:Expected error testing (environment (quote (chezscheme)) (quote (chezscheme)) (quote #f)): Exception in environment: invalid library reference #f + primvars.mo:Expected error testing (base-exception-handler (quote 0)): Exception in default-exception-handler: 0 is not a procedure + primvars.mo:Expected error testing (base-exception-handler (quote #f)): Exception in default-exception-handler: #f is not a procedure +! primvars.mo:Expected error testing (eval 1.0+2.0i (quote ((a . b)))): Exception in interpret: ((a . b)) is not an environment +! primvars.mo:Expected error testing (eval 1.0+2.0i (quote #f)): Exception in interpret: #f is not an environment + primvars.mo:Expected error testing (expand 1.0+2.0i (quote ((a . b)))): Exception in sc-expand: ((a . b)) is not an environment + 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 +*************** +*** 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 to #<procedure>". -! primvars.mo:Expected error in mat parameterize: "incorrect number of arguments to #<procedure x>". + primvars.mo:Expected error in mat make-parameter: "incorrect number of arguments 1 to #<procedure>". +! primvars.mo:Expected error in mat parameterize: "incorrect number of arguments 0 to #<procedure x>". 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". ---- 1,13 ---- -+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 1 at line 1005, char 4 of 6.ms -+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 2 at line 1007, char 4 of 6.ms -+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 5 at line 1014, char 4 of 6.ms -+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 6 at line 1016, char 4 of 6.ms -+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 9 at line 1023, char 4 of 6.ms -+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 10 at line 1025, char 4 of 6.ms +--- 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 to #<procedure>". -! primvars.mo:Expected error in mat parameterize: "incorrect number of arguments to #<procedure>". + primvars.mo:Expected error in mat make-parameter: "incorrect number of arguments 1 to #<procedure>". +! primvars.mo:Expected error in mat parameterize: "incorrect number of arguments 0 to #<procedure>". 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". *************** -*** 28,98 **** +*** 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". -! 3.mo:Expected error in mat matrest1: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest2: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest2: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest3: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest3: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest3: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest4: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest4: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest4: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest4: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest5: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest5: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest5: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest5: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest5: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest6: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest6: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest6: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest6: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest6: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest6: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest7: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest7: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest7: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest7: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest7: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest7: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest7: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest8: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest8: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest8: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest8: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest8: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest8: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest8: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest8: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest9: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest9: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest9: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest9: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest9: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest9: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest9: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest9: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest9: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest10: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest10: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest10: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest10: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest10: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest10: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest10: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest10: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest10: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest10: "incorrect number of arguments to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest1: "incorrect number of arguments 0 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest2: "incorrect number of arguments 1 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest2: "incorrect number of arguments 0 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest3: "incorrect number of arguments 2 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest3: "incorrect number of arguments 1 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest3: "incorrect number of arguments 0 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest4: "incorrect number of arguments 3 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest4: "incorrect number of arguments 2 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest4: "incorrect number of arguments 1 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest4: "incorrect number of arguments 0 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest5: "incorrect number of arguments 4 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest5: "incorrect number of arguments 3 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest5: "incorrect number of arguments 2 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest5: "incorrect number of arguments 1 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest5: "incorrect number of arguments 0 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest6: "incorrect number of arguments 5 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest6: "incorrect number of arguments 4 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest6: "incorrect number of arguments 3 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest6: "incorrect number of arguments 2 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest6: "incorrect number of arguments 1 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest6: "incorrect number of arguments 0 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest7: "incorrect number of arguments 6 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest7: "incorrect number of arguments 5 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest7: "incorrect number of arguments 4 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest7: "incorrect number of arguments 3 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest7: "incorrect number of arguments 2 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest7: "incorrect number of arguments 1 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest7: "incorrect number of arguments 0 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest8: "incorrect number of arguments 7 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest8: "incorrect number of arguments 6 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest8: "incorrect number of arguments 5 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest8: "incorrect number of arguments 4 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest8: "incorrect number of arguments 3 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest8: "incorrect number of arguments 2 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest8: "incorrect number of arguments 1 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest8: "incorrect number of arguments 0 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest9: "incorrect number of arguments 8 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest9: "incorrect number of arguments 7 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest9: "incorrect number of arguments 6 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest9: "incorrect number of arguments 5 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest9: "incorrect number of arguments 4 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest9: "incorrect number of arguments 3 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest9: "incorrect number of arguments 2 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest9: "incorrect number of arguments 1 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest9: "incorrect number of arguments 0 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest10: "incorrect number of arguments 9 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest10: "incorrect number of arguments 8 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest10: "incorrect number of arguments 7 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest10: "incorrect number of arguments 6 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest10: "incorrect number of arguments 5 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest10: "incorrect number of arguments 4 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest10: "incorrect number of arguments 3 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest10: "incorrect number of arguments 2 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest10: "incorrect number of arguments 1 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest10: "incorrect number of arguments 0 to #<procedure matrestf>". 3.mo:Expected error in mat application: "attempt to apply non-procedure ((a b c))". 3.mo:Expected error in mat case-lambda: "incorrect argument count in call ((case-lambda))". 3.mo:Expected error in mat case-lambda: "incorrect argument count in call (f 3 4 5)". -! 3.mo:Expected error in mat case-lambda: "incorrect number of arguments to #<procedure foo>". -! 3.mo:Expected error in mat case-lambda: "incorrect number of arguments to #<procedure foo>". -! 3.mo:Expected error in mat case-lambda: "incorrect number of arguments to #<procedure foo>". -! 3.mo:Expected error in mat case-lambda: "incorrect number of arguments to #<procedure foo>". -! 3.mo:Expected error in mat case-lambda: "incorrect number of arguments to #<procedure foo>". -! 3.mo:Expected error in mat case-lambda: "incorrect number of arguments to #<procedure foo>". -! 3.mo:Expected error in mat case-lambda: "incorrect number of arguments to #<procedure foo>". +! 3.mo:Expected error in mat case-lambda: "incorrect number of arguments 1 to #<procedure foo>". +! 3.mo:Expected error in mat case-lambda: "incorrect number of arguments 2 to #<procedure foo>". +! 3.mo:Expected error in mat case-lambda: "incorrect number of arguments 4 to #<procedure foo>". +! 3.mo:Expected error in mat case-lambda: "incorrect number of arguments 1 to #<procedure foo>". +! 3.mo:Expected error in mat case-lambda: "incorrect number of arguments 2 to #<procedure foo>". +! 3.mo:Expected error in mat case-lambda: "incorrect number of arguments 4 to #<procedure foo>". +! 3.mo:Expected error in mat case-lambda: "incorrect number of arguments 2 to #<procedure foo>". 3.mo:Expected error in mat let: "incorrect argument count in call ((lambda (x . r) ((...) 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". ---- 34,104 ---- +--- 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". -! 3.mo:Expected error in mat matrest1: "incorrect number of arguments to #<procedure>". -! 3.mo:Expected error in mat matrest2: "incorrect number of arguments to #<procedure>". -! 3.mo:Expected error in mat matrest2: "incorrect number of arguments to #<procedure>". -! 3.mo:Expected error in mat matrest3: "incorrect number of arguments to #<procedure>". -! 3.mo:Expected error in mat matrest3: "incorrect number of arguments to #<procedure>". +! 3.mo:Expected error in mat matrest1: "incorrect number of arguments 0 to #<procedure>". +! 3.mo:Expected error in mat matrest2: "incorrect number of arguments 1 to #<procedure>". +! 3.mo:Expected error in mat matrest2: "incorrect number of arguments 0 to #<procedure>". ! 3.mo:Expected error in mat matrest3: "incorrect number of arguments to #<procedure>". +! 3.mo:Expected error in mat matrest3: "incorrect number of arguments 1 to #<procedure>". +! 3.mo:Expected error in mat matrest3: "incorrect number of arguments 0 to #<procedure>". ! 3.mo:Expected error in mat matrest4: "incorrect number of arguments to #<procedure>". ! 3.mo:Expected error in mat matrest4: "incorrect number of arguments to #<procedure>". -! 3.mo:Expected error in mat matrest4: "incorrect number of arguments to #<procedure>". -! 3.mo:Expected error in mat matrest4: "incorrect number of arguments to #<procedure>". +! 3.mo:Expected error in mat matrest4: "incorrect number of arguments 1 to #<procedure>". +! 3.mo:Expected error in mat matrest4: "incorrect number of arguments 0 to #<procedure>". ! 3.mo:Expected error in mat matrest5: "incorrect number of arguments to #<procedure>". ! 3.mo:Expected error in mat matrest5: "incorrect number of arguments to #<procedure>". ! 3.mo:Expected error in mat matrest5: "incorrect number of arguments to #<procedure>". -! 3.mo:Expected error in mat matrest5: "incorrect number of arguments to #<procedure>". -! 3.mo:Expected error in mat matrest5: "incorrect number of arguments to #<procedure>". -! 3.mo:Expected error in mat matrest6: "incorrect number of arguments to #<procedure>". -! 3.mo:Expected error in mat matrest6: "incorrect number of arguments to #<procedure>". +! 3.mo:Expected error in mat matrest5: "incorrect number of arguments 1 to #<procedure>". +! 3.mo:Expected error in mat matrest5: "incorrect number of arguments 0 to #<procedure>". ! 3.mo:Expected error in mat matrest6: "incorrect number of arguments to #<procedure>". ! 3.mo:Expected error in mat matrest6: "incorrect number of arguments to #<procedure>". ! 3.mo:Expected error in mat matrest6: "incorrect number of arguments to #<procedure>". ! 3.mo:Expected error in mat matrest6: "incorrect number of arguments to #<procedure>". +! 3.mo:Expected error in mat matrest6: "incorrect number of arguments 1 to #<procedure>". +! 3.mo:Expected error in mat matrest6: "incorrect number of arguments 0 to #<procedure>". ! 3.mo:Expected error in mat matrest7: "incorrect number of arguments to #<procedure>". ! 3.mo:Expected error in mat matrest7: "incorrect number of arguments to #<procedure>". ! 3.mo:Expected error in mat matrest7: "incorrect number of arguments to #<procedure>". ! 3.mo:Expected error in mat matrest7: "incorrect number of arguments to #<procedure>". ! 3.mo:Expected error in mat matrest7: "incorrect number of arguments to #<procedure>". -! 3.mo:Expected error in mat matrest7: "incorrect number of arguments to #<procedure>". -! 3.mo:Expected error in mat matrest7: "incorrect number of arguments to #<procedure>". -! 3.mo:Expected error in mat matrest8: "incorrect number of arguments to #<procedure>". +! 3.mo:Expected error in mat matrest7: "incorrect number of arguments 1 to #<procedure>". +! 3.mo:Expected error in mat matrest7: "incorrect number of arguments 0 to #<procedure>". ! 3.mo:Expected error in mat matrest8: "incorrect number of arguments to #<procedure>". ! 3.mo:Expected error in mat matrest8: "incorrect number of arguments to #<procedure>". ! 3.mo:Expected error in mat matrest8: "incorrect number of arguments to #<procedure>". ! 3.mo:Expected error in mat matrest8: "incorrect number of arguments to #<procedure>". ! 3.mo:Expected error in mat matrest8: "incorrect number of arguments to #<procedure>". ! 3.mo:Expected error in mat matrest8: "incorrect number of arguments to #<procedure>". -! 3.mo:Expected error in mat matrest8: "incorrect number of arguments to #<procedure>". -! 3.mo:Expected error in mat matrest9: "incorrect number of arguments to #<procedure>". +! 3.mo:Expected error in mat matrest8: "incorrect number of arguments 1 to #<procedure>". +! 3.mo:Expected error in mat matrest8: "incorrect number of arguments 0 to #<procedure>". ! 3.mo:Expected error in mat matrest9: "incorrect number of arguments to #<procedure>". ! 3.mo:Expected error in mat matrest9: "incorrect number of arguments to #<procedure>". ! 3.mo:Expected error in mat matrest9: "incorrect number of arguments to #<procedure>". @@ -144,9 +156,8 @@ ! 3.mo:Expected error in mat matrest9: "incorrect number of arguments to #<procedure>". ! 3.mo:Expected error in mat matrest9: "incorrect number of arguments to #<procedure>". ! 3.mo:Expected error in mat matrest9: "incorrect number of arguments to #<procedure>". -! 3.mo:Expected error in mat matrest9: "incorrect number of arguments to #<procedure>". -! 3.mo:Expected error in mat matrest10: "incorrect number of arguments to #<procedure>". -! 3.mo:Expected error in mat matrest10: "incorrect number of arguments to #<procedure>". +! 3.mo:Expected error in mat matrest9: "incorrect number of arguments 1 to #<procedure>". +! 3.mo:Expected error in mat matrest9: "incorrect number of arguments 0 to #<procedure>". ! 3.mo:Expected error in mat matrest10: "incorrect number of arguments to #<procedure>". ! 3.mo:Expected error in mat matrest10: "incorrect number of arguments to #<procedure>". ! 3.mo:Expected error in mat matrest10: "incorrect number of arguments to #<procedure>". @@ -155,6 +166,8 @@ ! 3.mo:Expected error in mat matrest10: "incorrect number of arguments to #<procedure>". ! 3.mo:Expected error in mat matrest10: "incorrect number of arguments to #<procedure>". ! 3.mo:Expected error in mat matrest10: "incorrect number of arguments to #<procedure>". +! 3.mo:Expected error in mat matrest10: "incorrect number of arguments 1 to #<procedure>". +! 3.mo:Expected error in mat matrest10: "incorrect number of arguments 0 to #<procedure>". 3.mo:Expected error in mat application: "attempt to apply non-procedure ((a b c))". 3.mo:Expected error in mat case-lambda: "incorrect argument count in call ((case-lambda))". 3.mo:Expected error in mat case-lambda: "incorrect argument count in call (f 3 4 5)". @@ -169,26 +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". *************** -*** 4076,4091 **** - 6.mo:Expected error in mat pretty-print: "incorrect number of arguments to #<procedure pretty-format>". - 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 warning in mat cp1in-verify-format-warnings: "compile: too few arguments for control string "~a~~~s" in call to format". -- 6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too many arguments for control string "~a~a~a~s" in call to format". - 6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too few arguments for control string "~a~~~s" in call to format at line 1, char 28 of testfile.ss". - 6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too many arguments for control string "~a~a~a~s" in call to format at line 1, char 28 of testfile.ss". -- 6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too few arguments for control string "abc~s" in call to printf". -- 6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too many arguments for control string "~%~abc~adef~ag~s~~~%" in call to printf". - 6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too few arguments for control string "abc~s" in call to printf at line 1, char 28 of testfile.ss". - 6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too many arguments for control string "~%~abc~adef~ag~s~~~%" in call to printf at line 1, char 28 of testfile.ss". -- 6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too few arguments for control string "abc~s" in call to fprintf". -- 6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too many arguments for control string "~%~abc~adef~ag~s~~~%" in call to fprintf". - 6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too few arguments for control string "abc~s" in call to fprintf at line 1, char 29 of testfile.ss". - 6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too many arguments for control string "~%~abc~adef~ag~s~~~%" in call to fprintf at line 1, char 29 of testfile.ss". - 6.mo:Expected error in mat print-parameters: "write: cycle detected; proceeding with (print-graph #t)". ---- 4082,4091 ---- -*************** -*** 7032,7038 **** +*** 7517,7523 **** 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 @@ -196,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". ---- 7032,7038 ---- +--- 7517,7523 ---- 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 @@ -205,15 +199,15 @@ 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". *************** -*** 7360,7366 **** +*** 7912,7918 **** 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". -! record.mo:Expected error in mat record25: "incorrect number of arguments to #<procedure make-r25-bar>". +! record.mo:Expected error in mat record25: "incorrect number of arguments 18 to #<procedure make-r25-bar>". 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". ---- 7360,7366 ---- +--- 7912,7918 ---- 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". @@ -222,7 +216,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". *************** -*** 9362,9386 **** +*** 10008,10032 **** 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". @@ -248,7 +242,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". ---- 9362,9386 ---- +--- 10008,10032 ---- 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". @@ -275,8 +269,8 @@ 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". *************** -*** 9393,9424 **** - foreign.mo:Expected error in mat foreign-sizeof: "incorrect number of arguments to #<procedure foreign-sizeof>". +*** 10039,10070 **** + foreign.mo:Expected error in mat foreign-sizeof: "incorrect number of arguments 2 to #<procedure foreign-sizeof>". 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"". @@ -308,8 +302,8 @@ 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>". ---- 9393,9424 ---- - foreign.mo:Expected error in mat foreign-sizeof: "incorrect number of arguments to #<procedure foreign-sizeof>". +--- 10039,10070 ---- + foreign.mo:Expected error in mat foreign-sizeof: "incorrect number of arguments 2 to #<procedure foreign-sizeof>". 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_star_to_u8_star: invalid foreign-procedure argument "hello"". @@ -342,7 +336,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>". *************** -*** 9426,9451 **** +*** 10072,10097 **** 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>". @@ -369,7 +363,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>". ---- 9426,9451 ---- +--- 10072,10097 ---- 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>". @@ -397,7 +391,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>". *************** -*** 9456,9490 **** +*** 10103,10137 **** 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>". @@ -433,7 +427,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>". ---- 9456,9490 ---- +--- 10103,10137 ---- 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>". @@ -470,25 +464,25 @@ 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>". *************** -*** 10091,10100 **** +*** 10738,10747 **** 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 ...)))". -! oop.mo:Expected error in mat oop: "incorrect number of arguments to #<procedure make-<a>>". -! oop.mo:Expected error in mat oop: "incorrect number of arguments to #<procedure make-<a>>". -! oop.mo:Expected error in mat oop: "incorrect number of arguments to #<procedure m1>". -! oop.mo:Expected error in mat oop: "incorrect number of arguments to #<procedure m1>". +! oop.mo:Expected error in mat oop: "incorrect number of arguments 0 to #<procedure make-<a>>". +! oop.mo:Expected error in mat oop: "incorrect number of arguments 2 to #<procedure make-<a>>". +! oop.mo:Expected error in mat oop: "incorrect number of arguments 1 to #<procedure m1>". +! oop.mo:Expected error in mat oop: "incorrect number of arguments 3 to #<procedure m1>". 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". ---- 10091,10100 ---- +--- 10738,10747 ---- 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 ...)))". -! oop.mo:Expected error in mat oop: "incorrect number of arguments to #<procedure>". -! oop.mo:Expected error in mat oop: "incorrect number of arguments to #<procedure>". -! oop.mo:Expected error in mat oop: "incorrect number of arguments to #<procedure>". -! oop.mo:Expected error in mat oop: "incorrect number of arguments to #<procedure>". +! oop.mo:Expected error in mat oop: "incorrect number of arguments 0 to #<procedure>". +! oop.mo:Expected error in mat oop: "incorrect number of arguments 2 to #<procedure>". +! oop.mo:Expected error in mat oop: "incorrect number of arguments 1 to #<procedure>". +! oop.mo:Expected error in mat oop: "incorrect number of arguments 3 to #<procedure>". 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". diff --git a/src/ChezScheme/mats/patch-interpret-0-t-t-f b/src/ChezScheme/mats/patch-interpret-0-t-t-f index 21a71432cb..1e5f434591 100644 --- a/src/ChezScheme/mats/patch-interpret-0-t-t-f +++ b/src/ChezScheme/mats/patch-interpret-0-t-t-f @@ -1,142 +1,154 @@ -*** errors-compile-0-t-t-f 2019-02-12 01:20:09.150192807 -0500 ---- errors-interpret-0-t-t-f 2019-02-12 03:10:46.824077889 -0500 +*** errors-compile-0-t-t-f 2021-05-04 16:40:04.000000000 -0600 +--- errors-interpret-0-t-t-f 2021-05-04 16:40:21.000000000 -0600 *************** -*** 1,7 **** +*** 18,25 **** + primvars.mo:Expected error testing (environment (quote (chezscheme)) (quote (chezscheme)) (quote #f)): Exception in environment: invalid library reference #f + primvars.mo:Expected error testing (base-exception-handler (quote 0)): Exception in default-exception-handler: 0 is not a procedure + primvars.mo:Expected error testing (base-exception-handler (quote #f)): Exception in default-exception-handler: #f is not a procedure +! primvars.mo:Expected error testing (eval 1.0+2.0i (quote ((a . b)))): Exception in compile: ((a . b)) is not an environment +! primvars.mo:Expected error testing (eval 1.0+2.0i (quote #f)): Exception in compile: #f is not an environment + primvars.mo:Expected error testing (expand 1.0+2.0i (quote ((a . b)))): Exception in sc-expand: ((a . b)) is not an environment + 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 +--- 18,25 ---- + primvars.mo:Expected error testing (environment (quote (chezscheme)) (quote (chezscheme)) (quote #f)): Exception in environment: invalid library reference #f + primvars.mo:Expected error testing (base-exception-handler (quote 0)): Exception in default-exception-handler: 0 is not a procedure + primvars.mo:Expected error testing (base-exception-handler (quote #f)): Exception in default-exception-handler: #f is not a procedure +! primvars.mo:Expected error testing (eval 1.0+2.0i (quote ((a . b)))): Exception in interpret: ((a . b)) is not an environment +! primvars.mo:Expected error testing (eval 1.0+2.0i (quote #f)): Exception in interpret: #f is not an environment + primvars.mo:Expected error testing (expand 1.0+2.0i (quote ((a . b)))): Exception in sc-expand: ((a . b)) is not an environment + 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 +*************** +*** 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 to #<procedure>". -! primvars.mo:Expected error in mat parameterize: "incorrect number of arguments to #<procedure x>". + primvars.mo:Expected error in mat make-parameter: "incorrect number of arguments 1 to #<procedure>". +! primvars.mo:Expected error in mat parameterize: "incorrect number of arguments 0 to #<procedure x>". 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". ---- 1,13 ---- -+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 1 at line 1005, char 4 of 6.ms -+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 2 at line 1007, char 4 of 6.ms -+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 5 at line 1014, char 4 of 6.ms -+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 6 at line 1016, char 4 of 6.ms -+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 9 at line 1023, char 4 of 6.ms -+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 10 at line 1025, char 4 of 6.ms +--- 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 to #<procedure>". -! primvars.mo:Expected error in mat parameterize: "incorrect number of arguments to #<procedure>". + primvars.mo:Expected error in mat make-parameter: "incorrect number of arguments 1 to #<procedure>". +! primvars.mo:Expected error in mat parameterize: "incorrect number of arguments 0 to #<procedure>". 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". *************** -*** 28,98 **** +*** 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". -! 3.mo:Expected error in mat matrest1: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest2: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest2: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest3: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest3: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest3: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest4: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest4: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest4: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest4: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest5: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest5: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest5: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest5: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest5: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest6: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest6: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest6: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest6: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest6: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest6: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest7: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest7: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest7: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest7: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest7: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest7: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest7: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest8: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest8: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest8: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest8: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest8: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest8: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest8: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest8: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest9: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest9: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest9: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest9: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest9: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest9: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest9: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest9: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest9: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest10: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest10: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest10: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest10: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest10: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest10: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest10: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest10: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest10: "incorrect number of arguments to #<procedure matrestf>". -! 3.mo:Expected error in mat matrest10: "incorrect number of arguments to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest1: "incorrect number of arguments 0 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest2: "incorrect number of arguments 1 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest2: "incorrect number of arguments 0 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest3: "incorrect number of arguments 2 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest3: "incorrect number of arguments 1 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest3: "incorrect number of arguments 0 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest4: "incorrect number of arguments 3 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest4: "incorrect number of arguments 2 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest4: "incorrect number of arguments 1 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest4: "incorrect number of arguments 0 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest5: "incorrect number of arguments 4 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest5: "incorrect number of arguments 3 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest5: "incorrect number of arguments 2 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest5: "incorrect number of arguments 1 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest5: "incorrect number of arguments 0 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest6: "incorrect number of arguments 5 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest6: "incorrect number of arguments 4 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest6: "incorrect number of arguments 3 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest6: "incorrect number of arguments 2 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest6: "incorrect number of arguments 1 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest6: "incorrect number of arguments 0 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest7: "incorrect number of arguments 6 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest7: "incorrect number of arguments 5 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest7: "incorrect number of arguments 4 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest7: "incorrect number of arguments 3 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest7: "incorrect number of arguments 2 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest7: "incorrect number of arguments 1 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest7: "incorrect number of arguments 0 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest8: "incorrect number of arguments 7 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest8: "incorrect number of arguments 6 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest8: "incorrect number of arguments 5 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest8: "incorrect number of arguments 4 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest8: "incorrect number of arguments 3 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest8: "incorrect number of arguments 2 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest8: "incorrect number of arguments 1 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest8: "incorrect number of arguments 0 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest9: "incorrect number of arguments 8 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest9: "incorrect number of arguments 7 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest9: "incorrect number of arguments 6 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest9: "incorrect number of arguments 5 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest9: "incorrect number of arguments 4 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest9: "incorrect number of arguments 3 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest9: "incorrect number of arguments 2 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest9: "incorrect number of arguments 1 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest9: "incorrect number of arguments 0 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest10: "incorrect number of arguments 9 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest10: "incorrect number of arguments 8 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest10: "incorrect number of arguments 7 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest10: "incorrect number of arguments 6 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest10: "incorrect number of arguments 5 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest10: "incorrect number of arguments 4 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest10: "incorrect number of arguments 3 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest10: "incorrect number of arguments 2 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest10: "incorrect number of arguments 1 to #<procedure matrestf>". +! 3.mo:Expected error in mat matrest10: "incorrect number of arguments 0 to #<procedure matrestf>". 3.mo:Expected error in mat application: "attempt to apply non-procedure ((a b c))". 3.mo:Expected error in mat case-lambda: "incorrect argument count in call ((case-lambda))". 3.mo:Expected error in mat case-lambda: "incorrect argument count in call (f 3 4 5)". -! 3.mo:Expected error in mat case-lambda: "incorrect number of arguments to #<procedure foo>". -! 3.mo:Expected error in mat case-lambda: "incorrect number of arguments to #<procedure foo>". -! 3.mo:Expected error in mat case-lambda: "incorrect number of arguments to #<procedure foo>". -! 3.mo:Expected error in mat case-lambda: "incorrect number of arguments to #<procedure foo>". -! 3.mo:Expected error in mat case-lambda: "incorrect number of arguments to #<procedure foo>". -! 3.mo:Expected error in mat case-lambda: "incorrect number of arguments to #<procedure foo>". -! 3.mo:Expected error in mat case-lambda: "incorrect number of arguments to #<procedure foo>". +! 3.mo:Expected error in mat case-lambda: "incorrect number of arguments 1 to #<procedure foo>". +! 3.mo:Expected error in mat case-lambda: "incorrect number of arguments 2 to #<procedure foo>". +! 3.mo:Expected error in mat case-lambda: "incorrect number of arguments 4 to #<procedure foo>". +! 3.mo:Expected error in mat case-lambda: "incorrect number of arguments 1 to #<procedure foo>". +! 3.mo:Expected error in mat case-lambda: "incorrect number of arguments 2 to #<procedure foo>". +! 3.mo:Expected error in mat case-lambda: "incorrect number of arguments 4 to #<procedure foo>". +! 3.mo:Expected error in mat case-lambda: "incorrect number of arguments 2 to #<procedure foo>". 3.mo:Expected error in mat let: "incorrect argument count in call ((lambda (x . r) ((...) 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". ---- 34,104 ---- +--- 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". -! 3.mo:Expected error in mat matrest1: "incorrect number of arguments to #<procedure>". -! 3.mo:Expected error in mat matrest2: "incorrect number of arguments to #<procedure>". -! 3.mo:Expected error in mat matrest2: "incorrect number of arguments to #<procedure>". -! 3.mo:Expected error in mat matrest3: "incorrect number of arguments to #<procedure>". -! 3.mo:Expected error in mat matrest3: "incorrect number of arguments to #<procedure>". +! 3.mo:Expected error in mat matrest1: "incorrect number of arguments 0 to #<procedure>". +! 3.mo:Expected error in mat matrest2: "incorrect number of arguments 1 to #<procedure>". +! 3.mo:Expected error in mat matrest2: "incorrect number of arguments 0 to #<procedure>". ! 3.mo:Expected error in mat matrest3: "incorrect number of arguments to #<procedure>". +! 3.mo:Expected error in mat matrest3: "incorrect number of arguments 1 to #<procedure>". +! 3.mo:Expected error in mat matrest3: "incorrect number of arguments 0 to #<procedure>". ! 3.mo:Expected error in mat matrest4: "incorrect number of arguments to #<procedure>". ! 3.mo:Expected error in mat matrest4: "incorrect number of arguments to #<procedure>". -! 3.mo:Expected error in mat matrest4: "incorrect number of arguments to #<procedure>". -! 3.mo:Expected error in mat matrest4: "incorrect number of arguments to #<procedure>". +! 3.mo:Expected error in mat matrest4: "incorrect number of arguments 1 to #<procedure>". +! 3.mo:Expected error in mat matrest4: "incorrect number of arguments 0 to #<procedure>". ! 3.mo:Expected error in mat matrest5: "incorrect number of arguments to #<procedure>". ! 3.mo:Expected error in mat matrest5: "incorrect number of arguments to #<procedure>". ! 3.mo:Expected error in mat matrest5: "incorrect number of arguments to #<procedure>". -! 3.mo:Expected error in mat matrest5: "incorrect number of arguments to #<procedure>". -! 3.mo:Expected error in mat matrest5: "incorrect number of arguments to #<procedure>". -! 3.mo:Expected error in mat matrest6: "incorrect number of arguments to #<procedure>". -! 3.mo:Expected error in mat matrest6: "incorrect number of arguments to #<procedure>". +! 3.mo:Expected error in mat matrest5: "incorrect number of arguments 1 to #<procedure>". +! 3.mo:Expected error in mat matrest5: "incorrect number of arguments 0 to #<procedure>". ! 3.mo:Expected error in mat matrest6: "incorrect number of arguments to #<procedure>". ! 3.mo:Expected error in mat matrest6: "incorrect number of arguments to #<procedure>". ! 3.mo:Expected error in mat matrest6: "incorrect number of arguments to #<procedure>". ! 3.mo:Expected error in mat matrest6: "incorrect number of arguments to #<procedure>". +! 3.mo:Expected error in mat matrest6: "incorrect number of arguments 1 to #<procedure>". +! 3.mo:Expected error in mat matrest6: "incorrect number of arguments 0 to #<procedure>". ! 3.mo:Expected error in mat matrest7: "incorrect number of arguments to #<procedure>". ! 3.mo:Expected error in mat matrest7: "incorrect number of arguments to #<procedure>". ! 3.mo:Expected error in mat matrest7: "incorrect number of arguments to #<procedure>". ! 3.mo:Expected error in mat matrest7: "incorrect number of arguments to #<procedure>". ! 3.mo:Expected error in mat matrest7: "incorrect number of arguments to #<procedure>". -! 3.mo:Expected error in mat matrest7: "incorrect number of arguments to #<procedure>". -! 3.mo:Expected error in mat matrest7: "incorrect number of arguments to #<procedure>". -! 3.mo:Expected error in mat matrest8: "incorrect number of arguments to #<procedure>". +! 3.mo:Expected error in mat matrest7: "incorrect number of arguments 1 to #<procedure>". +! 3.mo:Expected error in mat matrest7: "incorrect number of arguments 0 to #<procedure>". ! 3.mo:Expected error in mat matrest8: "incorrect number of arguments to #<procedure>". ! 3.mo:Expected error in mat matrest8: "incorrect number of arguments to #<procedure>". ! 3.mo:Expected error in mat matrest8: "incorrect number of arguments to #<procedure>". ! 3.mo:Expected error in mat matrest8: "incorrect number of arguments to #<procedure>". ! 3.mo:Expected error in mat matrest8: "incorrect number of arguments to #<procedure>". ! 3.mo:Expected error in mat matrest8: "incorrect number of arguments to #<procedure>". -! 3.mo:Expected error in mat matrest8: "incorrect number of arguments to #<procedure>". -! 3.mo:Expected error in mat matrest9: "incorrect number of arguments to #<procedure>". +! 3.mo:Expected error in mat matrest8: "incorrect number of arguments 1 to #<procedure>". +! 3.mo:Expected error in mat matrest8: "incorrect number of arguments 0 to #<procedure>". ! 3.mo:Expected error in mat matrest9: "incorrect number of arguments to #<procedure>". ! 3.mo:Expected error in mat matrest9: "incorrect number of arguments to #<procedure>". ! 3.mo:Expected error in mat matrest9: "incorrect number of arguments to #<procedure>". @@ -144,9 +156,8 @@ ! 3.mo:Expected error in mat matrest9: "incorrect number of arguments to #<procedure>". ! 3.mo:Expected error in mat matrest9: "incorrect number of arguments to #<procedure>". ! 3.mo:Expected error in mat matrest9: "incorrect number of arguments to #<procedure>". -! 3.mo:Expected error in mat matrest9: "incorrect number of arguments to #<procedure>". -! 3.mo:Expected error in mat matrest10: "incorrect number of arguments to #<procedure>". -! 3.mo:Expected error in mat matrest10: "incorrect number of arguments to #<procedure>". +! 3.mo:Expected error in mat matrest9: "incorrect number of arguments 1 to #<procedure>". +! 3.mo:Expected error in mat matrest9: "incorrect number of arguments 0 to #<procedure>". ! 3.mo:Expected error in mat matrest10: "incorrect number of arguments to #<procedure>". ! 3.mo:Expected error in mat matrest10: "incorrect number of arguments to #<procedure>". ! 3.mo:Expected error in mat matrest10: "incorrect number of arguments to #<procedure>". @@ -155,6 +166,8 @@ ! 3.mo:Expected error in mat matrest10: "incorrect number of arguments to #<procedure>". ! 3.mo:Expected error in mat matrest10: "incorrect number of arguments to #<procedure>". ! 3.mo:Expected error in mat matrest10: "incorrect number of arguments to #<procedure>". +! 3.mo:Expected error in mat matrest10: "incorrect number of arguments 1 to #<procedure>". +! 3.mo:Expected error in mat matrest10: "incorrect number of arguments 0 to #<procedure>". 3.mo:Expected error in mat application: "attempt to apply non-procedure ((a b c))". 3.mo:Expected error in mat case-lambda: "incorrect argument count in call ((case-lambda))". 3.mo:Expected error in mat case-lambda: "incorrect argument count in call (f 3 4 5)". @@ -169,26 +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". *************** -*** 4076,4091 **** - 6.mo:Expected error in mat pretty-print: "incorrect number of arguments to #<procedure pretty-format>". - 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 warning in mat cp1in-verify-format-warnings: "compile: too few arguments for control string "~a~~~s" in call to format". -- 6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too many arguments for control string "~a~a~a~s" in call to format". - 6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too few arguments for control string "~a~~~s" in call to format at line 1, char 28 of testfile.ss". - 6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too many arguments for control string "~a~a~a~s" in call to format at line 1, char 28 of testfile.ss". -- 6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too few arguments for control string "abc~s" in call to printf". -- 6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too many arguments for control string "~%~abc~adef~ag~s~~~%" in call to printf". - 6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too few arguments for control string "abc~s" in call to printf at line 1, char 28 of testfile.ss". - 6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too many arguments for control string "~%~abc~adef~ag~s~~~%" in call to printf at line 1, char 28 of testfile.ss". -- 6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too few arguments for control string "abc~s" in call to fprintf". -- 6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too many arguments for control string "~%~abc~adef~ag~s~~~%" in call to fprintf". - 6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too few arguments for control string "abc~s" in call to fprintf at line 1, char 29 of testfile.ss". - 6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too many arguments for control string "~%~abc~adef~ag~s~~~%" in call to fprintf at line 1, char 29 of testfile.ss". - 6.mo:Expected error in mat print-parameters: "write: cycle detected; proceeding with (print-graph #t)". ---- 4082,4091 ---- -*************** -*** 7032,7038 **** +*** 7517,7523 **** 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 @@ -196,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". ---- 7032,7038 ---- +--- 7517,7523 ---- 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 @@ -205,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". *************** -*** 7169,7176 **** +*** 7717,7724 **** 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". @@ -214,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)". ---- 7169,7176 ---- +--- 7717,7724 ---- 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". @@ -224,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)". *************** -*** 7178,7192 **** +*** 7726,7740 **** 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". @@ -240,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". ---- 7178,7192 ---- +--- 7726,7740 ---- 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". @@ -257,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". *************** -*** 7199,7224 **** +*** 7747,7772 **** 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>". @@ -284,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". ---- 7199,7224 ---- +--- 7747,7772 ---- 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>". @@ -312,10 +306,10 @@ 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". *************** -*** 7349,7387 **** +*** 7901,7939 **** 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>". + record.mo:Expected error in mat record23: "make-record-type: cannot extend sealed record type #<record type foo> as bar". ! record.mo:Expected error in mat record25: "make-r25-bar: invalid value 1.0 for foreign type int". ! record.mo:Expected error in mat record25: "make-r25-bar: invalid value 2.0 for foreign type unsigned". ! record.mo:Expected error in mat record25: "make-r25-bar: invalid value three for foreign type unsigned-int". @@ -327,7 +321,7 @@ ! record.mo:Expected error in mat record25: "make-r25-bar: invalid value #\9 for foreign type uptr". ! record.mo:Expected error in mat record25: "make-r25-bar: invalid value 10 for foreign type float". ! record.mo:Expected error in mat record25: "make-r25-bar: invalid value 11.0+0.0i for foreign type double". -! record.mo:Expected error in mat record25: "incorrect number of arguments to #<procedure make-r25-bar>". +! record.mo:Expected error in mat record25: "incorrect number of arguments 18 to #<procedure make-r25-bar>". ! record.mo:Expected error in mat record25: "make-r25-bar: invalid value 12.0 for foreign type long-long". ! record.mo:Expected error in mat record25: "make-r25-bar: invalid value 13.0 for foreign type unsigned-long-long". ! record.mo:Expected error in mat record25: "set-r25-bar-a!: invalid value 3.0 for foreign type int". @@ -352,10 +346,10 @@ 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". ---- 7349,7387 ---- +--- 7901,7939 ---- 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>". + record.mo:Expected error in mat record23: "make-record-type: cannot extend sealed record type #<record type foo> as bar". ! record.mo:Expected error in mat record25: "invalid value 1.0 for foreign type int". ! record.mo:Expected error in mat record25: "invalid value 2.0 for foreign type unsigned". ! record.mo:Expected error in mat record25: "invalid value three for foreign type unsigned-int". @@ -393,100 +387,100 @@ 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". *************** -*** 7407,7442 **** +*** 7959,7994 **** 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>". + record.mo:Expected error in mat r6rs-records-procedural: "make-record-type-descriptor: cannot extend sealed record type #<record type bar> as foo". record.mo:Expected error in mat r6rs-records-syntactic: "invalid syntax point". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure make-point>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure make-point>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure make-point>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure point?>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure point?>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 0 to #<procedure make-point>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 1 to #<procedure make-point>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 3 to #<procedure make-point>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 0 to #<procedure point?>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 2 to #<procedure point?>". record.mo:Expected error in mat r6rs-records-syntactic: "variable point-x-set! is not bound". record.mo:Expected error in mat r6rs-records-syntactic: "variable point-y-set! is not bound". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure point-x>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure point-y>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 0 to #<procedure point-x>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 2 to #<procedure point-y>". record.mo:Expected error in mat r6rs-records-syntactic: "record-mutator: field 0 of #<record type point> is immutable". record.mo:Expected error in mat r6rs-records-syntactic: "record-mutator: field 1 of #<record type point> is immutable". record.mo:Expected error in mat r6rs-records-syntactic: "invalid syntax point". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure make-point>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure make-point>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure make-point>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure point?>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure point?>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 0 to #<procedure make-point>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 1 to #<procedure make-point>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 3 to #<procedure make-point>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 0 to #<procedure point?>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 2 to #<procedure point?>". record.mo:Expected error in mat r6rs-records-syntactic: "variable point-x-set! is not bound". record.mo:Expected error in mat r6rs-records-syntactic: "variable point-y-set! is not bound". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure point-x>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure point-y>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure frob-widget-set!>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure frob-widget-set!>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure frob-widget-set!>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure frob-widget-set!>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure frob-widget-set!>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure frob-widget-set!>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure setwid!>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure setwid!>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure setwid!>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 0 to #<procedure point-x>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 2 to #<procedure point-y>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 0 to #<procedure frob-widget-set!>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 1 to #<procedure frob-widget-set!>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 3 to #<procedure frob-widget-set!>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 0 to #<procedure frob-widget-set!>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 1 to #<procedure frob-widget-set!>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 3 to #<procedure frob-widget-set!>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 0 to #<procedure setwid!>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 1 to #<procedure setwid!>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 3 to #<procedure setwid!>". record.mo:Expected error in mat r6rs-records-syntactic: "record-rtd: #<ex3> is not a record". record.mo:Expected error in mat r6rs-records-syntactic: "record-rtd: #<ex3> is not a record". record.mo:Expected error in mat r6rs-records-syntactic: "parent record type is sealed ex3". ---- 7407,7442 ---- +--- 7959,7994 ---- 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>". + record.mo:Expected error in mat r6rs-records-procedural: "make-record-type-descriptor: cannot extend sealed record type #<record type bar> as foo". record.mo:Expected error in mat r6rs-records-syntactic: "invalid syntax point". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure constructor>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure constructor>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure constructor>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure predicate>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure predicate>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 0 to #<procedure constructor>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 1 to #<procedure constructor>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 3 to #<procedure constructor>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 0 to #<procedure predicate>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 2 to #<procedure predicate>". record.mo:Expected error in mat r6rs-records-syntactic: "variable point-x-set! is not bound". record.mo:Expected error in mat r6rs-records-syntactic: "variable point-y-set! is not bound". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure accessor>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure accessor>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 0 to #<procedure accessor>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 2 to #<procedure accessor>". record.mo:Expected error in mat r6rs-records-syntactic: "record-mutator: field 0 of #<record type point> is immutable". record.mo:Expected error in mat r6rs-records-syntactic: "record-mutator: field 1 of #<record type point> is immutable". record.mo:Expected error in mat r6rs-records-syntactic: "invalid syntax point". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure constructor>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure constructor>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure constructor>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure predicate>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure predicate>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 0 to #<procedure constructor>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 1 to #<procedure constructor>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 3 to #<procedure constructor>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 0 to #<procedure predicate>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 2 to #<procedure predicate>". record.mo:Expected error in mat r6rs-records-syntactic: "variable point-x-set! is not bound". record.mo:Expected error in mat r6rs-records-syntactic: "variable point-y-set! is not bound". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure accessor>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure accessor>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure mutator>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure mutator>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure mutator>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure mutator>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure mutator>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure mutator>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure mutator>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure mutator>". -! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments to #<procedure mutator>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 0 to #<procedure accessor>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 2 to #<procedure accessor>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 0 to #<procedure mutator>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 1 to #<procedure mutator>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 3 to #<procedure mutator>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 0 to #<procedure mutator>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 1 to #<procedure mutator>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 3 to #<procedure mutator>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 0 to #<procedure mutator>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 1 to #<procedure mutator>". +! record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 3 to #<procedure mutator>". record.mo:Expected error in mat r6rs-records-syntactic: "record-rtd: #<ex3> is not a record". record.mo:Expected error in mat r6rs-records-syntactic: "record-rtd: #<ex3> is not a record". record.mo:Expected error in mat r6rs-records-syntactic: "parent record type is sealed ex3". *************** -*** 10091,10100 **** +*** 10738,10747 **** 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 ...)))". -! oop.mo:Expected error in mat oop: "incorrect number of arguments to #<procedure make-<a>>". -! oop.mo:Expected error in mat oop: "incorrect number of arguments to #<procedure make-<a>>". -! oop.mo:Expected error in mat oop: "incorrect number of arguments to #<procedure m1>". -! oop.mo:Expected error in mat oop: "incorrect number of arguments to #<procedure m1>". +! oop.mo:Expected error in mat oop: "incorrect number of arguments 0 to #<procedure make-<a>>". +! oop.mo:Expected error in mat oop: "incorrect number of arguments 2 to #<procedure make-<a>>". +! oop.mo:Expected error in mat oop: "incorrect number of arguments 1 to #<procedure m1>". +! oop.mo:Expected error in mat oop: "incorrect number of arguments 3 to #<procedure m1>". 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". ---- 10091,10100 ---- +--- 10738,10747 ---- 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 ...)))". -! oop.mo:Expected error in mat oop: "incorrect number of arguments to #<procedure>". -! oop.mo:Expected error in mat oop: "incorrect number of arguments to #<procedure>". -! oop.mo:Expected error in mat oop: "incorrect number of arguments to #<procedure>". -! oop.mo:Expected error in mat oop: "incorrect number of arguments to #<procedure>". +! oop.mo:Expected error in mat oop: "incorrect number of arguments 0 to #<procedure>". +! oop.mo:Expected error in mat oop: "incorrect number of arguments 2 to #<procedure>". +! oop.mo:Expected error in mat oop: "incorrect number of arguments 1 to #<procedure>". +! oop.mo:Expected error in mat oop: "incorrect number of arguments 3 to #<procedure>". 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". diff --git a/src/ChezScheme/mats/patch-interpret-3-t-f-f b/src/ChezScheme/mats/patch-interpret-3-t-f-f index 4006907cb5..e69de29bb2 100644 --- a/src/ChezScheme/mats/patch-interpret-3-t-f-f +++ b/src/ChezScheme/mats/patch-interpret-3-t-f-f @@ -1,32 +0,0 @@ -*** errors-compile-3-t-f-f 2017-10-27 02:41:58.000000000 -0400 ---- errors-interpret-3-t-f-f 2017-10-27 03:47:08.000000000 -0400 -*************** -*** 1,3 **** ---- 1,9 ---- -+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 1 at line 1005, char 4 of 6.ms -+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 2 at line 1007, char 4 of 6.ms -+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 5 at line 1014, char 4 of 6.ms -+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 6 at line 1016, char 4 of 6.ms -+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 9 at line 1023, char 4 of 6.ms -+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 10 at line 1025, char 4 of 6.ms - 3.mo:Expected warning in mat cpvalid: "possible attempt to reference undefined variable x". - 3.mo:Expected warning in mat cpvalid: "possible attempt to reference undefined variable x at line 1, char 19 of testfile.ss". - misc.mo:Expected warning in mat compile-profile: "profile-dump-list: unmodified source file "testfile.ss" not found in source directories". -*************** -*** 12,26 **** - misc.mo:Expected warning in mat (argcnt compile-warning): "compile: possible incorrect argument count in call (car (quote (a b)) (quote (c d))) at line 3, char 38 of testfile.ss". - misc.mo:Expected warning in mat (argcnt compile-warning): "compile: possible incorrect argument count in call (g 7) at line 3, char 47 of testfile.ss". - misc.mo:Expected warning in mat (argcnt compile-warning): "compile: possible incorrect argument count in call (g) at line 3, char 48 of testfile.ss". -- 6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too few arguments for control string "~a~~~s" in call to format". -- 6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too many arguments for control string "~a~a~a~s" in call to format". - 6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too few arguments for control string "~a~~~s" in call to format at line 1, char 28 of testfile.ss". - 6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too many arguments for control string "~a~a~a~s" in call to format at line 1, char 28 of testfile.ss". -- 6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too few arguments for control string "abc~s" in call to printf". -- 6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too many arguments for control string "~%~abc~adef~ag~s~~~%" in call to printf". - 6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too few arguments for control string "abc~s" in call to printf at line 1, char 28 of testfile.ss". - 6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too many arguments for control string "~%~abc~adef~ag~s~~~%" in call to printf at line 1, char 28 of testfile.ss". -- 6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too few arguments for control string "abc~s" in call to fprintf". -- 6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too many arguments for control string "~%~abc~adef~ag~s~~~%" in call to fprintf". - 6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too few arguments for control string "abc~s" in call to fprintf at line 1, char 29 of testfile.ss". - 6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too many arguments for control string "~%~abc~adef~ag~s~~~%" in call to fprintf at line 1, char 29 of testfile.ss". ---- 18,26 ---- diff --git a/src/ChezScheme/mats/patch-interpret-3-t-t-f b/src/ChezScheme/mats/patch-interpret-3-t-t-f index 9d40a7819a..e69de29bb2 100644 --- a/src/ChezScheme/mats/patch-interpret-3-t-t-f +++ b/src/ChezScheme/mats/patch-interpret-3-t-t-f @@ -1,32 +0,0 @@ -*** errors-compile-3-t-t-f 2017-10-27 02:36:19.000000000 -0400 ---- errors-interpret-3-t-t-f 2017-10-27 03:52:31.000000000 -0400 -*************** -*** 1,3 **** ---- 1,9 ---- -+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 1 at line 1005, char 4 of 6.ms -+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 2 at line 1007, char 4 of 6.ms -+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 5 at line 1014, char 4 of 6.ms -+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 6 at line 1016, char 4 of 6.ms -+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 9 at line 1023, char 4 of 6.ms -+ 6.mo:Bug in mat cp1in-verify-format-warnings clause 10 at line 1025, char 4 of 6.ms - 3.mo:Expected warning in mat cpvalid: "possible attempt to reference undefined variable x". - 3.mo:Expected warning in mat cpvalid: "possible attempt to reference undefined variable x at line 1, char 19 of testfile.ss". - misc.mo:Expected warning in mat compile-profile: "profile-dump-list: unmodified source file "testfile.ss" not found in source directories". -*************** -*** 12,26 **** - misc.mo:Expected warning in mat (argcnt compile-warning): "compile: possible incorrect argument count in call (car (quote (a b)) (quote (c d))) at line 3, char 38 of testfile.ss". - misc.mo:Expected warning in mat (argcnt compile-warning): "compile: possible incorrect argument count in call (g 7) at line 3, char 47 of testfile.ss". - misc.mo:Expected warning in mat (argcnt compile-warning): "compile: possible incorrect argument count in call (g) at line 3, char 48 of testfile.ss". -- 6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too few arguments for control string "~a~~~s" in call to format". -- 6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too many arguments for control string "~a~a~a~s" in call to format". - 6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too few arguments for control string "~a~~~s" in call to format at line 1, char 28 of testfile.ss". - 6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too many arguments for control string "~a~a~a~s" in call to format at line 1, char 28 of testfile.ss". -- 6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too few arguments for control string "abc~s" in call to printf". -- 6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too many arguments for control string "~%~abc~adef~ag~s~~~%" in call to printf". - 6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too few arguments for control string "abc~s" in call to printf at line 1, char 28 of testfile.ss". - 6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too many arguments for control string "~%~abc~adef~ag~s~~~%" in call to printf at line 1, char 28 of testfile.ss". -- 6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too few arguments for control string "abc~s" in call to fprintf". -- 6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too many arguments for control string "~%~abc~adef~ag~s~~~%" in call to fprintf". - 6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too few arguments for control string "abc~s" in call to fprintf at line 1, char 29 of testfile.ss". - 6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too many arguments for control string "~%~abc~adef~ag~s~~~%" in call to fprintf at line 1, char 29 of testfile.ss". ---- 18,26 ---- diff --git a/src/ChezScheme/mats/primvars.ms b/src/ChezScheme/mats/primvars.ms index f51d6ef35d..d8e55f8506 100644 --- a/src/ChezScheme/mats/primvars.ms +++ b/src/ChezScheme/mats/primvars.ms @@ -19,7 +19,7 @@ (memq x '(equivalent-expansion? mat-run mat mat/cf mat-file mat-output enable-cp0 windows? embedded? - *examples-directory* *scheme* + *examples-directory* *scheme* *mats-dir* *fuzz* ~= fl~= cfl~= == nan pi +pi +pi/2 +pi/4 -pi -pi/2 -pi/4 +e -e separate-eval-tools separate-compile separate-eval run-script patch-exec-path $record->vector $cat_flush @@ -162,7 +162,15 @@ 0 a*)) (define prim-arity (lambda (x) - (module (primref-arity) (include "../s/primref.ss")) + (module (primref-arity) + (define-syntax include-from-s + (lambda (x) + (syntax-case x () + [(k ?path) + (string? (datum ?path)) + (let ([s-path (format "~a/../s/~a" *mats-dir* (datum ?path))]) + (datum->syntax #'k `(include ,s-path)))]))) + (include-from-s "primref.ss")) (let ([primref2 (#%$sgetprop x '*prim2* #f)] [primref3 (#%$sgetprop x '*prim3* #f)]) (if primref2 (if primref3 @@ -380,6 +388,7 @@ [(boolean) #f '()] [(box) &a '((a)) #f] [(bytevector) '#vu8(0) "a" #f] + [(sub-bytevector) no-good] [(cflonum) 0.0+1.0i 0 'a #f] [(char) #\a 0 #f] [(codec) (latin-1-codec) 0 #f] @@ -426,6 +435,7 @@ [(list-of-symbols) '(a b c) '("a") #f] [(maybe-binary-output-port) *binary-output-port *binary-input-port (current-output-port)] [(maybe-char) #\a 0] + [(maybe-force-host-out?) #t 0] [(maybe-pathname) "a" 'a] [(maybe-procedure) values 0] [(maybe-rtd) *rtd *record ""] diff --git a/src/ChezScheme/mats/profile.ms b/src/ChezScheme/mats/profile.ms index ba1ab2317f..74998234cb 100644 --- a/src/ChezScheme/mats/profile.ms +++ b/src/ChezScheme/mats/profile.ms @@ -174,8 +174,9 @@ (eqv? ($qw 0 0) 0.0) ; bfp, efp combination not in database (eqv? ; file not in database - (let* ([ip (open-file-input-port "Mf-base")] - [sfd (make-source-file-descriptor "Mf-base" ip)]) + (let* ([fn (format "~a/Mf-base" *mats-dir*)] + [ip (open-file-input-port fn)] + [sfd (make-source-file-descriptor fn ip)]) (close-port ip) (profile-query-weight (make-source-object sfd 0 0))) #f) diff --git a/src/ChezScheme/mats/record.ms b/src/ChezScheme/mats/record.ms index 739af5ccc1..7765725b93 100644 --- a/src/ChezScheme/mats/record.ms +++ b/src/ChezScheme/mats/record.ms @@ -755,11 +755,11 @@ ... [else (syntax-error const (format "unhandled value ~s" (constant const)))])])) - (define-syntax include + (define-syntax include ; defining `include` so that a ".def" can `include` other ".def"s (lambda (stx) (syntax-case stx () [(k path) - #`(#,(datum->syntax #'k 'orig-include) #,(format "../s/~a" (datum path)))]))) + #`(#,(datum->syntax #'k 'orig-include) #,(format "~a/../s/~a" *mats-dir* (datum path)))]))) (include "machine.def") ; all this work for two constants: (define $fd-unaligned-integers (constant unaligned-integers)) @@ -2840,6 +2840,39 @@ ) (mat record-writer + (equal? + (with-output-to-string + (lambda () + (define-record-type sp (fields lat)) + (record-writer (type-descriptor sp) + (lambda (x p w) (w (sp-lat x) p))) + (pretty-print (list (make-sp 'ugh))))) + "(ugh)\n") + (error? ; 'sp is not an rtd + (with-output-to-string + (lambda () + (define-record-type sp (fields lat)) + (record-writer 'sp + (lambda (x p w) (w (sp-lat x) p)))))) + (error? ; "oops" is not a procedure + (with-output-to-string + (lambda () + (define-record-type sp (fields lat)) + (record-writer (type-descriptor sp) "oops")))) + (error? ; ugh is not a textual output port + (with-output-to-string + (lambda () + (define-record-type sp (fields lat)) + (record-writer (type-descriptor sp) + (lambda (x p w) (w p (sp-lat x)))) + (pretty-print (list (make-sp 'ugh)))))) + (error? ; procedure not a textual output port + (with-output-to-string + (lambda () + (define-record-type sp (fields lat)) + (record-writer (type-descriptor sp) + (lambda (x p w) (w (sp-lat x) w))) + (pretty-print (list (make-sp 'ugh)))))) (begin (define-record $froz (a b) ([c (+ a b)])) (define-record $fruz $froz (d)) @@ -6372,10 +6405,10 @@ (begin (if (#3%record? b g6) (#2%void) (#3%$record-oops 'unbox b g6)) (#3%$object-ref 'scheme-object b ,fixnum?)))]) - (if (#3%record? b g4) (#2%void) (#3%$record-oops 'set-box! b g4)) + (if (#3%record-instance? b g4) (#2%void) (#3%$record-oops 'set-box! b g4)) (#3%$object-set! 'scheme-object b ,fixnum? g7)) (#2%list - (#3%record? b g5) + (#3%record-instance? b g5) (#3%$object-ref 'scheme-object b ,fixnum?)))))) (equal? (let () 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 35b7e117cc..c302b2d51c 100644 --- a/src/ChezScheme/mats/root-experr-compile-0-f-f-f +++ b/src/ChezScheme/mats/root-experr-compile-0-f-f-f @@ -64,6 +64,10 @@ primvars.mo:Expected error testing (pseudo-random-generator-seed! *pseudo-random primvars.mo:Expected error testing (pseudo-random-generator-next! (quote #f)): Exception in pseudo-random-generator-next!: not a pseudo-random generator #f primvars.mo:Expected error testing (pseudo-random-generator-next! (quote #!eof) *pseudo-random-generator): Exception: variable *pseudo-random-generator is not bound primvars.mo:Expected error testing (pseudo-random-generator-next! (quote #f) *pseudo-random-generator): Exception: variable *pseudo-random-generator is not bound +primvars.mo:Expected error testing (reference-address->object (quote #!eof)): Exception in reference-address->object: invalid address #!eof +primvars.mo:Expected error testing (reference-address->object (quote #f)): Exception in reference-address->object: invalid address #f +primvars.mo:Expected error testing (reference*-address->object (quote #!eof)): Exception in reference*-address->object: invalid address #!eof +primvars.mo:Expected error testing (reference*-address->object (quote #f)): Exception in reference*-address->object: invalid address #f primvars.mo:Expected error testing (set-wrapper-procedure! 1.0+2.0i (quote 0)): Exception in set-wrapper-procedure!: 1.0+2.0i is not a wrapper procedure primvars.mo:Expected error testing (set-wrapper-procedure! 1.0+2.0i (quote #f)): Exception in set-wrapper-procedure!: 1.0+2.0i is not a wrapper procedure primvars.mo:Expected error testing (vector->pseudo-random-generator (quote "a")): Exception in vector->pseudo-random-generator: not a valid pseudo-random generator state vector "a" @@ -695,46 +699,46 @@ primvars.mo:Expected error in mat trace-output-port: "trace-output-port: #<input 5_2.mo:Expected error in mat c....r-errors: "cddddr: incorrect list structure (a . b)". 5_2.mo:Expected error in mat list*: "incorrect argument count in call (list*)". 5_2.mo:Expected error in mat cons*: "incorrect argument count in call (cons*)". -5_2.mo:Expected error in mat list-ref: "list-ref: a is not a proper list". -5_2.mo:Expected error in mat list-ref: "list-ref: (a b . c) is not a proper list". +5_2.mo:Expected error in mat list-ref: "list-ref: index 0 reaches a non-pair in a". +5_2.mo:Expected error in mat list-ref: "list-ref: index 4 reaches a non-pair in (a b . c)". 5_2.mo:Expected error in mat list-ref: "list-ref: index 4 is out of range for list (a b)". 5_2.mo:Expected error in mat list-ref: "list-ref: index 4 is out of range for list (a b c)". 5_2.mo:Expected error in mat list-ref: "list-ref: index 4 is out of range for list (a b c d)". -5_2.mo:Expected error in mat list-ref: "list-ref: (a b c . e) is not a proper list". -5_2.mo:Expected error in mat list-ref: "list-ref: (a b c d . e) is not a proper list". +5_2.mo:Expected error in mat list-ref: "list-ref: index 4 reaches a non-pair in (a b c . e)". +5_2.mo:Expected error in mat list-ref: "list-ref: index 4 reaches a non-pair in (a b c d . e)". 5_2.mo:Expected error in mat list-ref: "list-ref: index 5 is out of range for list (a b c d)". 5_2.mo:Expected error in mat list-ref: "list-ref: index 5 is out of range for list (a b c d e)". -5_2.mo:Expected error in mat list-ref: "list-ref: (a b c d e . f) is not a proper list". -5_2.mo:Expected error in mat list-ref: "list-ref: (a b . c) is not a proper list". +5_2.mo:Expected error in mat list-ref: "list-ref: index 5 reaches a non-pair in (a b c d e . f)". +5_2.mo:Expected error in mat list-ref: "list-ref: index 10000 reaches a non-pair in (a b . c)". 5_2.mo:Expected error in mat list-ref: "list-ref: index 10000 is out of range for list (a b c)". -5_2.mo:Expected error in mat list-ref: "list-ref: (a b . c) is not a proper list". +5_2.mo:Expected error in mat list-ref: "list-ref: index 444444444444444444444444444444444444444444 reaches a non-pair in (a b . c)". 5_2.mo:Expected error in mat list-ref: "list-ref: index 444444444444444444444444444444444444444444 is out of range for list (a b c)". 5_2.mo:Expected error in mat list-ref: "list-ref: index -1 is not an exact nonnegative integer". 5_2.mo:Expected error in mat list-ref: "list-ref: index -4444444444444444444444 is not an exact nonnegative integer". 5_2.mo:Expected error in mat list-ref: "list-ref: index a is not an exact nonnegative integer". -5_2.mo:Expected error in mat list-tail: "list-tail: (a b . c) is not a proper list". -5_2.mo:Expected error in mat list-tail: "list-tail: (a b c . d) is not a proper list". -5_2.mo:Expected error in mat list-tail: "list-tail: (a b . c) is not a proper list". -5_2.mo:Expected error in mat list-tail: "list-tail: (a b c . d) is not a proper list". -5_2.mo:Expected error in mat list-tail: "list-tail: (a b c d . e) is not a proper list". +5_2.mo:Expected error in mat list-tail: "list-tail: index 4 reaches a non-pair in (a b . c)". +5_2.mo:Expected error in mat list-tail: "list-tail: index 4 reaches a non-pair in (a b c . d)". +5_2.mo:Expected error in mat list-tail: "list-tail: index 5 reaches a non-pair in (a b . c)". +5_2.mo:Expected error in mat list-tail: "list-tail: index 5 reaches a non-pair in (a b c . d)". +5_2.mo:Expected error in mat list-tail: "list-tail: index 5 reaches a non-pair in (a b c d . e)". 5_2.mo:Expected error in mat list-tail: "list-tail: index 4 is out of range for list (a)". 5_2.mo:Expected error in mat list-tail: "list-tail: index 4 is out of range for list (a b)". 5_2.mo:Expected error in mat list-tail: "list-tail: index 4 is out of range for list (a b c)". 5_2.mo:Expected error in mat list-tail: "list-tail: index 5 is out of range for list (a b)". 5_2.mo:Expected error in mat list-tail: "list-tail: index 5 is out of range for list (a b c)". 5_2.mo:Expected error in mat list-tail: "list-tail: index 5 is out of range for list (a b c d)". -5_2.mo:Expected error in mat list-tail: "list-tail: (a b . c) is not a proper list". +5_2.mo:Expected error in mat list-tail: "list-tail: index 10000 reaches a non-pair in (a b . c)". 5_2.mo:Expected error in mat list-tail: "list-tail: index 10000 is out of range for list (a b c)". -5_2.mo:Expected error in mat list-tail: "list-tail: (a b . c) is not a proper list". +5_2.mo:Expected error in mat list-tail: "list-tail: index 444444444444444444444444444444444444444444 reaches a non-pair in (a b . c)". 5_2.mo:Expected error in mat list-tail: "list-tail: index 444444444444444444444444444444444444444444 is out of range for list (a b c)". 5_2.mo:Expected error in mat list-tail: "list-tail: index -1 is not an exact nonnegative integer". 5_2.mo:Expected error in mat list-tail: "list-tail: index -4444444444444444444444 is not an exact nonnegative integer". 5_2.mo:Expected error in mat list-tail: "list-tail: index a is not an exact nonnegative integer". -5_2.mo:Expected error in mat list-head: "list-head: (a . b) is not a proper list". -5_2.mo:Expected error in mat list-head: "list-head: (a b . c) is not a proper list". -5_2.mo:Expected error in mat list-head: "list-head: (a b . c) is not a proper list". -5_2.mo:Expected error in mat list-head: "list-head: (a b c . d) is not a proper list". -5_2.mo:Expected error in mat list-head: "list-head: (a b . c) is not a proper list". +5_2.mo:Expected error in mat list-head: "list-head: index 3 reaches a non-pair in (a . b)". +5_2.mo:Expected error in mat list-head: "list-head: index 3 reaches a non-pair in (a b . c)". +5_2.mo:Expected error in mat list-head: "list-head: index 4 reaches a non-pair in (a b . c)". +5_2.mo:Expected error in mat list-head: "list-head: index 4 reaches a non-pair in (a b c . d)". +5_2.mo:Expected error in mat list-head: "list-head: index 10000 reaches a non-pair in (a b . c)". 5_2.mo:Expected error in mat list-head: "list-head: index 4 is out of range for list (a b c)". 5_2.mo:Expected error in mat list-head: "list-head: index 5 is out of range for list (a b c)". 5_2.mo:Expected error in mat list-head: "list-head: index 5 is out of range for list (a b c d)". @@ -4351,7 +4355,10 @@ cp0.mo:Expected error in mat expand/optimize-output: "expand/optimize-output: #< 5_6.mo:Expected error in mat vector-cas!: "vector-cas!: #(4 5 3) is not a valid index for #(4 5 3)". 5_6.mo:Expected error in mat vector-cas!: "vector-cas!: 1267650600228229401496703205376 is not a valid index for #(4 5 3)". 5_6.mo:Expected error in mat vector-cas!: "vector-cas!: -1 is not a valid index for #(4 5 3)". +5_6.mo:Expected error in mat vector-cas!: "vector-cas!: -2 is not a valid index for #(4 5 3)". 5_6.mo:Expected error in mat vector-cas!: "vector-cas!: 5 is not a valid index for #(4 5 3)". +5_6.mo:Expected error in mat vector-cas!: "vector-cas!: 67108864 is not a valid index for #(4 5 3)". +5_6.mo:Expected error in mat vector-cas!: "vector-cas!: 1099511627776 is not a valid index for #(4 5 3)". 5_6.mo:Expected error in mat stencil-vector: "stencil-vector: invalid mask x". 5_6.mo:Expected error in mat stencil-vector: "stencil-vector: invalid mask -1". 5_6.mo:Expected error in mat stencil-vector: "stencil-vector: mask 0 does not match given number of items 1". @@ -4621,6 +4628,11 @@ cp0.mo:Expected error in mat expand/optimize-output: "expand/optimize-output: #< 6.mo:Expected error in mat read-test: "read: unexpected end-of-file reading character at line 2, char 1 of testfile.ss". 6.mo:Expected error in mat read-test: "read: unexpected end-of-file reading character at line 2, char 1 of testfile.ss". 6.mo:Expected error in mat read-test: "read: unexpected end-of-file reading character at line 2, char 1 of testfile.ss". +6.mo:Expected error in mat read-test: "read: unexpected end-of-file reading boolean at line 3, char 1 of testfile.ss". +6.mo:Expected error in mat read-test: "read: unexpected end-of-file reading boolean at line 3, char 1 of testfile.ss". +6.mo:Expected error in mat read-test: "read: unexpected end-of-file reading boolean at line 3, char 1 of testfile.ss". +6.mo:Expected error in mat read-test: "read: unexpected end-of-file reading boolean at line 3, char 1 of testfile.ss". +6.mo:Expected error in mat read-test: "read: unexpected end-of-file reading boolean at line 3, char 1 of testfile.ss". 6.mo:Expected error in mat read-test: "read: unexpected end-of-file reading s-expression comment at line 3, char 15 of testfile.ss". 6.mo:Expected error in mat read-test: "read: unexpected end-of-file reading gensym at line 2, char 16 of testfile.ss". 6.mo:Expected error in mat read-test: "read: unexpected end-of-file reading gensym at line 2, char 16 of testfile.ss". @@ -4689,6 +4701,12 @@ cp0.mo:Expected error in mat expand/optimize-output: "expand/optimize-output: #< 6.mo:Expected error in mat read-test: "read: octal character syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss". 6.mo:Expected error in mat read-test: "read: invalid delimiter 1 for character at line 3, char 1 of testfile.ss". 6.mo:Expected error in mat read-test: "read: delimiter { is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss". +6.mo:Expected error in mat read-test: "read: invalid delimiter 2 for boolean at line 3, char 1 of testfile.ss". +6.mo:Expected error in mat read-test: "read: invalid delimiter 2 for boolean at line 3, char 1 of testfile.ss". +6.mo:Expected error in mat read-test: "read: invalid delimiter 3 for boolean at line 3, char 1 of testfile.ss". +6.mo:Expected error in mat read-test: "read: invalid delimiter 3 for boolean at line 3, char 1 of testfile.ss". +6.mo:Expected error in mat read-test: "read: invalid boolean #tra at line 3, char 1 of testfile.ss". +6.mo:Expected error in mat read-test: "read: invalid boolean #falsi at line 3, char 1 of testfile.ss". 6.mo:Expected error in mat read-test: "read: #!eof syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss". 6.mo:Expected error in mat read-test: "read: #!bwp syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss". 6.mo:Expected error in mat read-test: "read: #vfx(...) fxvector syntax is not allowed in #!r6rs mode at line 3, char 9 of testfile.ss". @@ -4702,6 +4720,12 @@ cp0.mo:Expected error in mat expand/optimize-output: "expand/optimize-output: #< 6.mo:Expected error in mat read-test: "read: 123# number syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss". 6.mo:Expected error in mat read-test: "read: 1/2e2 number syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss". 6.mo:Expected error in mat read-test: "read: #x.3 number syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss". +6.mo:Expected error in mat read-test: "read: alternative boolean syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss". +6.mo:Expected error in mat read-test: "read: alternative boolean syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss". +6.mo:Expected error in mat read-test: "read: alternative boolean syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss". +6.mo:Expected error in mat read-test: "read: alternative boolean syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss". +6.mo:Expected error in mat read-test: "read: alternative boolean syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss". +6.mo:Expected error in mat read-test: "read: alternative boolean syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss". 6.mo:Expected error in mat read-test: "read: U+488 symbol syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss". 6.mo:Expected error in mat read-test: "read: @ symbol syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss". 6.mo:Expected error in mat read-test: "read: @b symbol syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss". @@ -5404,6 +5428,11 @@ cp0.mo:Expected error in mat expand/optimize-output: "expand/optimize-output: #< 6.mo:Expected error in mat load-test: "read: unexpected end-of-file reading character at line 2, char 1 of testfile.ss". 6.mo:Expected error in mat load-test: "read: unexpected end-of-file reading character at line 2, char 1 of testfile.ss". 6.mo:Expected error in mat load-test: "read: unexpected end-of-file reading character at line 2, char 1 of testfile.ss". +6.mo:Expected error in mat load-test: "read: unexpected end-of-file reading boolean at line 3, char 1 of testfile.ss". +6.mo:Expected error in mat load-test: "read: unexpected end-of-file reading boolean at line 3, char 1 of testfile.ss". +6.mo:Expected error in mat load-test: "read: unexpected end-of-file reading boolean at line 3, char 1 of testfile.ss". +6.mo:Expected error in mat load-test: "read: unexpected end-of-file reading boolean at line 3, char 1 of testfile.ss". +6.mo:Expected error in mat load-test: "read: unexpected end-of-file reading boolean at line 3, char 1 of testfile.ss". 6.mo:Expected error in mat load-test: "read: unexpected end-of-file reading s-expression comment at line 3, char 15 of testfile.ss". 6.mo:Expected error in mat load-test: "read: unexpected end-of-file reading gensym at line 2, char 16 of testfile.ss". 6.mo:Expected error in mat load-test: "read: unexpected end-of-file reading gensym at line 2, char 16 of testfile.ss". @@ -5472,6 +5501,12 @@ cp0.mo:Expected error in mat expand/optimize-output: "expand/optimize-output: #< 6.mo:Expected error in mat load-test: "read: octal character syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss". 6.mo:Expected error in mat load-test: "read: invalid delimiter 1 for character at line 3, char 1 of testfile.ss". 6.mo:Expected error in mat load-test: "read: delimiter { is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss". +6.mo:Expected error in mat load-test: "read: invalid delimiter 2 for boolean at line 3, char 1 of testfile.ss". +6.mo:Expected error in mat load-test: "read: invalid delimiter 2 for boolean at line 3, char 1 of testfile.ss". +6.mo:Expected error in mat load-test: "read: invalid delimiter 3 for boolean at line 3, char 1 of testfile.ss". +6.mo:Expected error in mat load-test: "read: invalid delimiter 3 for boolean at line 3, char 1 of testfile.ss". +6.mo:Expected error in mat load-test: "read: invalid boolean #tra at line 3, char 1 of testfile.ss". +6.mo:Expected error in mat load-test: "read: invalid boolean #falsi at line 3, char 1 of testfile.ss". 6.mo:Expected error in mat load-test: "read: #!eof syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss". 6.mo:Expected error in mat load-test: "read: #!bwp syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss". 6.mo:Expected error in mat load-test: "read: #vfx(...) fxvector syntax is not allowed in #!r6rs mode at line 3, char 9 of testfile.ss". @@ -5485,6 +5520,12 @@ cp0.mo:Expected error in mat expand/optimize-output: "expand/optimize-output: #< 6.mo:Expected error in mat load-test: "read: 123# number syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss". 6.mo:Expected error in mat load-test: "read: 1/2e2 number syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss". 6.mo:Expected error in mat load-test: "read: #x.3 number syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss". +6.mo:Expected error in mat load-test: "read: alternative boolean syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss". +6.mo:Expected error in mat load-test: "read: alternative boolean syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss". +6.mo:Expected error in mat load-test: "read: alternative boolean syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss". +6.mo:Expected error in mat load-test: "read: alternative boolean syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss". +6.mo:Expected error in mat load-test: "read: alternative boolean syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss". +6.mo:Expected error in mat load-test: "read: alternative boolean syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss". 6.mo:Expected error in mat load-test: "read: U+488 symbol syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss". 6.mo:Expected error in mat load-test: "read: @ symbol syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss". 6.mo:Expected error in mat load-test: "read: @b symbol syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss". @@ -6187,6 +6228,11 @@ cp0.mo:Expected error in mat expand/optimize-output: "expand/optimize-output: #< 6.mo:Expected error in mat compile-test: "read: unexpected end-of-file reading character at line 2, char 1 of testfile.ss". 6.mo:Expected error in mat compile-test: "read: unexpected end-of-file reading character at line 2, char 1 of testfile.ss". 6.mo:Expected error in mat compile-test: "read: unexpected end-of-file reading character at line 2, char 1 of testfile.ss". +6.mo:Expected error in mat compile-test: "read: unexpected end-of-file reading boolean at line 3, char 1 of testfile.ss". +6.mo:Expected error in mat compile-test: "read: unexpected end-of-file reading boolean at line 3, char 1 of testfile.ss". +6.mo:Expected error in mat compile-test: "read: unexpected end-of-file reading boolean at line 3, char 1 of testfile.ss". +6.mo:Expected error in mat compile-test: "read: unexpected end-of-file reading boolean at line 3, char 1 of testfile.ss". +6.mo:Expected error in mat compile-test: "read: unexpected end-of-file reading boolean at line 3, char 1 of testfile.ss". 6.mo:Expected error in mat compile-test: "read: unexpected end-of-file reading s-expression comment at line 3, char 15 of testfile.ss". 6.mo:Expected error in mat compile-test: "read: unexpected end-of-file reading gensym at line 2, char 16 of testfile.ss". 6.mo:Expected error in mat compile-test: "read: unexpected end-of-file reading gensym at line 2, char 16 of testfile.ss". @@ -6255,6 +6301,12 @@ cp0.mo:Expected error in mat expand/optimize-output: "expand/optimize-output: #< 6.mo:Expected error in mat compile-test: "read: octal character syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss". 6.mo:Expected error in mat compile-test: "read: invalid delimiter 1 for character at line 3, char 1 of testfile.ss". 6.mo:Expected error in mat compile-test: "read: delimiter { is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss". +6.mo:Expected error in mat compile-test: "read: invalid delimiter 2 for boolean at line 3, char 1 of testfile.ss". +6.mo:Expected error in mat compile-test: "read: invalid delimiter 2 for boolean at line 3, char 1 of testfile.ss". +6.mo:Expected error in mat compile-test: "read: invalid delimiter 3 for boolean at line 3, char 1 of testfile.ss". +6.mo:Expected error in mat compile-test: "read: invalid delimiter 3 for boolean at line 3, char 1 of testfile.ss". +6.mo:Expected error in mat compile-test: "read: invalid boolean #tra at line 3, char 1 of testfile.ss". +6.mo:Expected error in mat compile-test: "read: invalid boolean #falsi at line 3, char 1 of testfile.ss". 6.mo:Expected error in mat compile-test: "read: #!eof syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss". 6.mo:Expected error in mat compile-test: "read: #!bwp syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss". 6.mo:Expected error in mat compile-test: "read: #vfx(...) fxvector syntax is not allowed in #!r6rs mode at line 3, char 9 of testfile.ss". @@ -6268,6 +6320,12 @@ cp0.mo:Expected error in mat expand/optimize-output: "expand/optimize-output: #< 6.mo:Expected error in mat compile-test: "read: 123# number syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss". 6.mo:Expected error in mat compile-test: "read: 1/2e2 number syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss". 6.mo:Expected error in mat compile-test: "read: #x.3 number syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss". +6.mo:Expected error in mat compile-test: "read: alternative boolean syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss". +6.mo:Expected error in mat compile-test: "read: alternative boolean syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss". +6.mo:Expected error in mat compile-test: "read: alternative boolean syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss". +6.mo:Expected error in mat compile-test: "read: alternative boolean syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss". +6.mo:Expected error in mat compile-test: "read: alternative boolean syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss". +6.mo:Expected error in mat compile-test: "read: alternative boolean syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss". 6.mo:Expected error in mat compile-test: "read: U+488 symbol syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss". 6.mo:Expected error in mat compile-test: "read: @ symbol syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss". 6.mo:Expected error in mat compile-test: "read: @b symbol syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss". @@ -7819,6 +7877,10 @@ record.mo:Expected error in mat foreign-data: "foreign-set!: invalid value 17 fo record.mo:Expected error in mat foreign-data: "foreign-set!: invalid value 17 for foreign type single-float". record.mo:Expected error in mat foreign-data: "foreign-set!: invalid value 17 for foreign type double". record.mo:Expected error in mat foreign-data: "foreign-set!: invalid value 17 for foreign type double-float". +record.mo:Expected error in mat record-writer: "record-writer: sp is not a record-type descriptor". +record.mo:Expected error in mat record-writer: "record-writer: "oops" is not a procedure". +record.mo:Expected error in mat record-writer: "write: ugh is not a textual output port". +record.mo:Expected error in mat record-writer: "write: #<procedure> is not a textual output port". record.mo:Expected error in mat record-equal/hash: "record-type-equal-procedure: 7 is not a record-type descriptor". record.mo:Expected error in mat record-equal/hash: "record-type-equal-procedure: 7 is not a record-type descriptor". record.mo:Expected error in mat record-equal/hash: "record-type-equal-procedure: 7 is not a procedure or #f". @@ -7845,7 +7907,7 @@ record.mo:Expected error in mat record22: "record-field-mutable?: unrecognized f record.mo:Expected error in mat record22: "make-record-type: invalid field specifier (mutable creepy q)". 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>". +record.mo:Expected error in mat record23: "make-record-type: cannot extend sealed record type #<record type foo> as bar". record.mo:Expected error in mat record25: "invalid value 1.0 for foreign type int". record.mo:Expected error in mat record25: "invalid value 2.0 for foreign type unsigned". record.mo:Expected error in mat record25: "invalid value three for foreign type unsigned-int". @@ -7902,7 +7964,7 @@ record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of ar record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 3 to #<procedure constructor>". 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>". +record.mo:Expected error in mat r6rs-records-procedural: "make-record-type-descriptor: cannot extend sealed record type #<record type bar> as foo". record.mo:Expected error in mat r6rs-records-syntactic: "invalid syntax point". record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 0 to #<procedure constructor>". record.mo:Expected error in mat r6rs-records-syntactic: "incorrect number of arguments 1 to #<procedure constructor>". @@ -8294,7 +8356,7 @@ enum.mo:Expected error in mat enumeration: "invalid syntax (define-enumeration f enum.mo:Expected error in mat enumeration: "invalid syntax (define-enumeration foo (a 3) bar)". enum.mo:Expected error in mat enumeration: "invalid syntax (foo 3)". enum.mo:Expected error in mat enumeration: "invalid syntax (bar 3)". -enum.mo:Expected error in mat enumeration: "make-record-type: cannot extend sealed record type #<record type enum-type>". +enum.mo:Expected error in mat enumeration: "make-record-type: cannot extend sealed record type #<record type enum-type> as foo". 8.mo:Expected error in mat define-syntax: "invalid syntax (foo)". 8.mo:Expected error in mat define-syntax: "invalid syntax (foo . a)". 8.mo:Expected error in mat define-syntax: "invalid syntax (foo a)". @@ -10138,6 +10200,14 @@ foreign.mo:Expected error in mat collect-safe: "foreign-callable: string result foreign.mo:Expected error in mat collect-safe: "foreign-callable: string result not allowed with __collect_safe callable". foreign.mo:Expected error in mat collect-safe: "foreign-callable: string result not allowed with __collect_safe callable". foreign.mo:Expected error in mat collect-safe: "foreign-callable: string result not allowed with __collect_safe callable". +foreign.mo:Expected error in mat reference-bytevector: "make-reference-bytevector: -1 is not a valid bytevector length". +foreign.mo:Expected error in mat reference-bytevector: "bytevector-reference-ref: #vu8(1 2 3) is not a reference bytevector". +foreign.mo:Expected error in mat reference-bytevector: "bytevector-reference-ref: invalid index -8 for #vu8(0 0 0 0 0 0 ...)". +foreign.mo:Expected error in mat reference-bytevector: "bytevector-reference-ref: invalid index oops for #vu8(0 0 0 0 0 0 ...)". +foreign.mo:Expected error in mat reference-bytevector: "bytevector-reference*-ref: invalid index -8 for #vu8(0 0 0 0 0 0 ...)". +foreign.mo:Expected error in mat reference-bytevector: "bytevector-reference*-ref: invalid index oops for #vu8(0 0 0 0 0 0 ...)". +foreign.mo:Expected error in mat reference-bytevector: "reference-address->object: invalid address #f". +foreign.mo:Expected error in mat reference-bytevector: "reference*-address->object: invalid address #f". ftype.mo:Expected error in mat ftype: "unexpected function ftype outside pointer field (function #f (int) int)". ftype.mo:Expected error in mat ftype: "unexpected function ftype outside pointer field (function #f (int) int)". ftype.mo:Expected error in mat ftype: "unexpected function ftype outside pointer field (function #f (int) int)". 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 17de8fbe49..9e6a75b73b 100644 --- a/src/ChezScheme/mats/root-experr-compile-2-f-f-f +++ b/src/ChezScheme/mats/root-experr-compile-2-f-f-f @@ -7379,6 +7379,10 @@ record.mo:Expected error in mat foreign-data: "foreign-set!: invalid value 17 fo record.mo:Expected error in mat foreign-data: "foreign-set!: invalid value 17 for foreign type single-float". record.mo:Expected error in mat foreign-data: "foreign-set!: invalid value 17 for foreign type double". record.mo:Expected error in mat foreign-data: "foreign-set!: invalid value 17 for foreign type double-float". +record.mo:Expected error in mat record-writer: "record-writer: sp is not a record-type descriptor". +record.mo:Expected error in mat record-writer: "record-writer: "oops" is not a procedure". +record.mo:Expected error in mat record-writer: "write: ugh is not a textual output port". +record.mo:Expected error in mat record-writer: "write: #<procedure> is not a textual output port". record.mo:Expected error in mat record-equal/hash: "record-type-equal-procedure: 7 is not a record-type descriptor". record.mo:Expected error in mat record-equal/hash: "record-type-equal-procedure: 7 is not a record-type descriptor". record.mo:Expected error in mat record-equal/hash: "record-type-equal-procedure: 7 is not a procedure or #f". diff --git a/src/ChezScheme/mats/thread.ms b/src/ChezScheme/mats/thread.ms index 2eb9a52f44..28b6dedac6 100644 --- a/src/ChezScheme/mats/thread.ms +++ b/src/ChezScheme/mats/thread.ms @@ -1356,7 +1356,7 @@ '(3.4 -4)) ($thread-check) (begin - (load-shared-object "./foreign1.so") + (load-shared-object (format "~a/foreign1.so" *mats-dir*)) #t) (equal? (let () @@ -1457,7 +1457,7 @@ (format "~a is defunct" what)))]) (thunk) (error #f "error expected"))) - (let ([g (make-guardian)]) + (let ([g (make-guardian #t)]) (g (make-mutex)) (collect) (let ([m (g)]) diff --git a/src/ChezScheme/mats/unix.ms b/src/ChezScheme/mats/unix.ms index cfba3e727b..db7f6f9378 100644 --- a/src/ChezScheme/mats/unix.ms +++ b/src/ChezScheme/mats/unix.ms @@ -72,8 +72,8 @@ (mat system (eqv? (with-output-to-file "testfile.ss" void '(replace)) (void)) (begin - (system (format "~:[~;/pkg~]/bin/rm testfile.ss" (embedded?))) - (system (format "~:[~;/pkg~]/bin/echo hello > testfile.ss" (embedded?))) + (system "rm -f testfile.ss") + (system "echo hello > testfile.ss") (let ([p (open-input-file "testfile.ss")]) (and (eq? (read p) 'hello) (begin (close-input-port p) #t)))) diff --git a/src/ChezScheme/newrelease b/src/ChezScheme/newrelease index 35f1d00d38..b13b067b59 100755 --- a/src/ChezScheme/newrelease +++ b/src/ChezScheme/newrelease @@ -68,51 +68,51 @@ else endif # clear running list of updated files -set updatedfiles = () +set maybeupdatedfiles = () ./workarea $M $W if ($status != 0) exit 1 cd $W -/bin/rm -f BUILDING +rm -f BUILDING sed -e "s/Chez Scheme Version [^ ]*/Chez Scheme Version $R/" \ -e "s/Copyright 1984-.... /Copyright 1984-`date +%Y` /" \ ../BUILDING > BUILDING -set updatedfiles = ($updatedfiles BUILDING) +set maybeupdatedfiles = ($maybeupdatedfiles BUILDING) -/bin/rm -f NOTICE +rm -f NOTICE sed -e "s/Chez Scheme Version [^ ]*/Chez Scheme Version $R/" \ -e "s/Copyright 1984-.... /Copyright 1984-`date +%Y` /" \ ../NOTICE > NOTICE -set updatedfiles = ($updatedfiles NOTICE) +set maybeupdatedfiles = ($maybeupdatedfiles NOTICE) mkdir makefiles sed -e "s/csv[0-9]\.[0-9]\(\.[0-9]\)*/csv$R/" ../makefiles/Mf-install.in > makefiles/Mf-install.in sed -e "s/csug[0-9]\.[0-9]/csug$MR.$mR/" -e "s/csug[0-9]_[0-9]/csug$MR""_$mR/" ../makefiles/Makefile-csug.in > makefiles/Makefile-csug.in -set updatedfiles = ($updatedfiles makefiles/Mf-install.in makefiles/Makefile-csug.in) +set maybeupdatedfiles = ($maybeupdatedfiles makefiles/Mf-install.in makefiles/Makefile-csug.in) -/bin/rm scheme.1.in +rm -f scheme.1.in sed -e "s/Chez Scheme Version [0-9]\.[0-9]\(\.[0-9]\)* .* [0-9][0-9]*/Chez Scheme Version $R `date +'%B %Y'`/" \ -e "s/Copyright .* Cisco Systems, Inc./Copyright `date +%Y` Cisco Systems, Inc./" \ ../scheme.1.in > scheme.1.in -set updatedfiles = ($updatedfiles scheme.1.in) +set maybeupdatedfiles = ($maybeupdatedfiles scheme.1.in) -/bin/rm -f c/Makefile.{,t}{i3,a6}nt +rm -f c/Makefile.{,t}{i3,a6}nt foreach fn (c/Makefile.{,t}{a6,i3}nt) - set updatedfiles = ($updatedfiles $fn) + set maybeupdatedfiles = ($maybeupdatedfiles $fn) sed -e "s/csv[0-9][0-9][0-9]*/csv$ZR/g" ../$fn > $fn end -/bin/rm -f mats/Mf-{,t}{i3,a6}nt +rm -f mats/Mf-{,t}{i3,a6}nt foreach fn (mats/Mf-{,t}{a6,i3}nt) - set updatedfiles = ($updatedfiles $fn) + set maybeupdatedfiles = ($maybeupdatedfiles $fn) sed -e "s/csv[0-9][0-9][0-9]*/csv$ZR/g" ../$fn > $fn end sed -e "s/csv[0-9][.0-9][0-9]*/csv$ZR/g" ../workarea > workarea chmod +x workarea -set updatedfiles = ($updatedfiles workarea) +set maybeupdatedfiles = ($maybeupdatedfiles workarea) set RCVERSION = "$MR,$mR,$bR,0" sed -e "s/FILEVERSION .*/FILEVERSION $RCVERSION/"\ @@ -121,20 +121,20 @@ sed -e "s/FILEVERSION .*/FILEVERSION $RCVERSION/"\ -e 's/"FileVersion", .*/"FileVersion", "'$R'"/'\ -e 's/"ProductVersion", .*/"ProductVersion", "'$R'"/'\ -e "s/Copyright 1984-..../Copyright 1984-`date +%Y`/g" ../c/scheme.rc > c/scheme.rc -set updatedfiles = ($updatedfiles c/scheme.rc) +set maybeupdatedfiles = ($maybeupdatedfiles c/scheme.rc) -/bin/rm -f s/7.ss +rm -f s/7.ss sed -e "s/nCopyright 1984-..../nCopyright 1984-`date +%Y`/g" ../s/7.ss > s/7.ss -set updatedfiles = ($updatedfiles s/7.ss) +set maybeupdatedfiles = ($maybeupdatedfiles s/7.ss) -/bin/rm -f s/cmacros.ss +rm -f s/cmacros.ss set VNUM = `printf "%04x%02x%02x" $MR $mR $bR` sed -e "s/scheme-version #x......../scheme-version #x$VNUM/" ../s/cmacros.ss > s/cmacros.ss -set updatedfiles = ($updatedfiles s/cmacros.ss) +set maybeupdatedfiles = ($maybeupdatedfiles s/cmacros.ss) mkdir release_notes sed -e "s/thisversion{Version [^ ]*}/thisversion{Version $R}/" ../release_notes/release_notes.stex > release_notes/release_notes.stex -set updatedfiles = ($updatedfiles release_notes/release_notes.stex) +set maybeupdatedfiles = ($maybeupdatedfiles release_notes/release_notes.stex) mkdir csug sed -e "s/Revised\(.*\)for Chez Scheme Version [^ ]*\./Revised\1for Chez Scheme Version $R./" \ @@ -143,33 +143,38 @@ sed -e "s/Revised\(.*\)for Chez Scheme Version [^ ]*\./Revised\1for Chez Scheme sed -e "s/Revised\(.*\)for Chez Scheme Version [^ ]*<br>/Revised\1for Chez Scheme Version $R<br>/" \ -e "s/nCopyright © .* Cisco Systems, Inc./nCopyright \© `date +%Y` Cisco Systems, Inc./" \ ../csug/csug.stex > csug/csug.stex -set updatedfiles = ($updatedfiles csug/copyright.stex csug/csug.stex) +set maybeupdatedfiles = ($maybeupdatedfiles csug/copyright.stex csug/csug.stex) -/bin/rm bintar/Makefile +rm -f bintar/Makefile sed -e "s/^version = .*/version = $R/" \ -e "s/csv[0-9][0-9][0-9]*/csv$ZR/g" \ ../bintar/Makefile > bintar/Makefile -set updatedfiles = ($updatedfiles bintar/Makefile) +set maybeupdatedfiles = ($maybeupdatedfiles bintar/Makefile) -/bin/rm rpm/Makefile +rm -f rpm/Makefile sed -e "s/^version = .*/version = $R/" ../rpm/Makefile > rpm/Makefile -set updatedfiles = ($updatedfiles rpm/Makefile) +set maybeupdatedfiles = ($maybeupdatedfiles rpm/Makefile) -/bin/rm pkg/Makefile +rm -f pkg/Makefile sed -e "s/^version = .*/version = $R/" \ -e "s/© .* Cisco Systems/\© `date +%Y` Cisco Systems/" \ ../pkg/Makefile > pkg/Makefile -set updatedfiles = ($updatedfiles pkg/Makefile) +set maybeupdatedfiles = ($maybeupdatedfiles pkg/Makefile) mkdir wininstall sed -e "s/VERSION := .*/VERSION := $R/" ../wininstall/Makefile > wininstall/Makefile -set updatedfiles = ($updatedfiles wininstall/Makefile) +set maybeupdatedfiles = ($maybeupdatedfiles wininstall/Makefile) foreach fn (wininstall/{,t}{a6,i3}nt.wxs) - set updatedfiles = ($updatedfiles $fn) + set maybeupdatedfiles = ($maybeupdatedfiles $fn) sed -e "s/csv[0-9][0-9][0-9]*/csv$ZR/" ../$fn > $fn end -/bin/rm LOG +set updatedfiles = () +foreach x ($maybeupdatedfiles) + cmp -s ../$x $x || set updatedfiles = ($updatedfiles $x) +end + +rm -f LOG cat ../LOG > LOG echo "" >> LOG echo "$R changes:" >> LOG diff --git a/src/ChezScheme/pkg/Makefile b/src/ChezScheme/pkg/Makefile index 4f5f1c54d3..b776d24a48 100644 --- a/src/ChezScheme/pkg/Makefile +++ b/src/ChezScheme/pkg/Makefile @@ -14,7 +14,7 @@ # limitations under the License. m := $(shell find ../bin/* -type d | xargs basename) -version = 9.5.3 +version = 9.5.5 release = 1 DOTUSER = $(shell ls -ld . | sed -e 's/[^ ]* *[^ ]* *\([^ ]*\).*/\1/') @@ -39,7 +39,7 @@ $(PKG): $(BUILDROOT)/$(PKG) --package-path $(BUILDROOT)\ $(PKG) sudo chown $(DOTUSER):$(DOTGROUP) $(PKG) - sudo /bin/rm -rf $(RELEASE) $(BUILDROOT) + sudo rm -rf $(RELEASE) $(BUILDROOT) $(BUILDROOT)/$(PKG): $(PKGCONTENT) sudo /usr/bin/pkgbuild\ @@ -77,7 +77,7 @@ $(BUILDROOT)/Distribution: $(BUILDROOT) $(BUILDROOT)/Resources/en.lproj/Welcome.html: $(BUILDROOT)/Resources/en.lproj echo '<html>' > $(BUILDROOT)/Resources/en.lproj/Welcome.html echo '<h3>Chez Scheme Version $(version)</h3>' >> $(BUILDROOT)/Resources/en.lproj/Welcome.html - echo '<p>Copyright © 2019 Cisco Systems, Inc.</p>' >> $(BUILDROOT)/Resources/en.lproj/Welcome.html + echo '<p>Copyright © 2020 Cisco Systems, Inc.</p>' >> $(BUILDROOT)/Resources/en.lproj/Welcome.html echo '<p>Chez Scheme is a programming language and an implementation of that language, with supporting tools and documentation.</p>' >> $(BUILDROOT)/Resources/en.lproj/Welcome.html echo '</html>' >> $(BUILDROOT)/Resources/en.lproj/Welcome.html chmod 644 $(BUILDROOT)/Resources/en.lproj/Welcome.html diff --git a/src/ChezScheme/release_notes/gifs/Makefile b/src/ChezScheme/release_notes/gifs/Makefile index 95729659bf..701d53a178 100644 --- a/src/ChezScheme/release_notes/gifs/Makefile +++ b/src/ChezScheme/release_notes/gifs/Makefile @@ -15,7 +15,7 @@ density=-r90x90 ${density} - |\ pnmcrop |\ ppmtogif -transparent white > $*.gif - /bin/rm -f $*.dvi $*.log *.aux + rm -f $*.dvi $*.log *.aux test -f $*.gif && chmod 644 $*.gif all: ${gifs} @@ -44,7 +44,7 @@ ghostRightarrow.gif: Rightarrow.tex giftrans -g '#000000=#ffffff' |\ giftopnm |\ ppmtogif -transparent white > $*.gif - /bin/rm -f Rightarrow.dvi Rightarrow.log Rightarrow.aux + rm -f Rightarrow.dvi Rightarrow.log Rightarrow.aux test -f $*.gif && chmod 644 $*.gif -clean: ; /bin/rm -f *.gif Make.out +clean: ; rm -f *.gif Make.out diff --git a/src/ChezScheme/release_notes/math/Makefile b/src/ChezScheme/release_notes/math/Makefile index b3ffae3b54..9eca430132 100644 --- a/src/ChezScheme/release_notes/math/Makefile +++ b/src/ChezScheme/release_notes/math/Makefile @@ -16,11 +16,11 @@ density=-r90x90 ${density} - |\ pnmcrop |\ ppmtogif -transparent white > $*.gif - /bin/rm -f $*.dvi $*.log $*.aux + rm -f $*.dvi $*.log $*.aux test -f $*.gif && chmod 644 $*.gif all: ${gifs} ${gifs}: mathmacros -clean: ; /bin/rm -f *.gif Make.out +clean: ; rm -f *.gif Make.out diff --git a/src/ChezScheme/rktboot/constant.rkt b/src/ChezScheme/rktboot/constant.rkt index 45e7b183ee..50087fc737 100644 --- a/src/ChezScheme/rktboot/constant.rkt +++ b/src/ChezScheme/rktboot/constant.rkt @@ -1,7 +1,8 @@ #lang racket/base (require racket/match "scheme-readtable.rkt" - "config.rkt") + "config.rkt" + "machine-def.rkt") ;; Extract constants that we need to get started by reading ;; "cmacros.ss" and the machine ".def" file (without trying to run or @@ -52,19 +53,23 @@ [(=) (= (constant-eval (cadr e) ht) (constant-eval (caddr e) ht))] + [(fx- -) + (apply - (map (lambda (e) (constant-eval e esc)) (cdr e)))] + [(fx+ +) + (apply + (map (lambda (e) (constant-eval e esc)) (cdr e)))] [(quote) (cadr e)] [else (esc)])] [else e])) (define (read-constants-from-file fn) - (call-with-input-file - (build-path scheme-dir "s" fn) - read-constants)) + (define i (open-file-with-machine.def-redirect fn target-machine (build-path scheme-dir "s"))) + (begin0 + (read-constants i) + (close-input-port i))) (when scheme-dir - (read-constants-from-file - (string-append target-machine ".def")) + (read-constants-from-file "machine.def") (read-constants-from-file "cmacros.ss")) (define-syntax-rule (define-constant id ...) @@ -87,7 +92,5 @@ prelex-sticky-mask prelex-is-mask scheme-version - code-flag-lift-barrier) - -(provide record-ptr-offset) -(define record-ptr-offset 1) + code-flag-lift-barrier + record-ptr-offset) diff --git a/src/ChezScheme/rktboot/machine-def.rkt b/src/ChezScheme/rktboot/machine-def.rkt new file mode 100644 index 0000000000..572a4e7e26 --- /dev/null +++ b/src/ChezScheme/rktboot/machine-def.rkt @@ -0,0 +1,28 @@ +#lang racket/base +(require (only-in racket/file file->string)) + +(provide open-file-with-machine.def-redirect) + +(define (open-file-with-machine.def-redirect filename target-machine dir) + (define (build-path* dir f) (if (eq? dir 'same) f (build-path dir f))) + (cond + [(equal? filename "machine.def") + (define def (string-append target-machine ".def")) + (cond + [(file-exists? (build-path* dir def)) (open-input-file (build-path* dir def))] + [else + ;; synthesize a default ".def" file from "[t]unix.def" + (define def (if (regexp-match? #rx"^t" target-machine) "tunix.def" "unix.def")) + (let* ([s (file->string (build-path* dir def))] + [s (regexp-replace* #rx"[$][(]M[)]" s target-machine)] + [s (regexp-replace* #rx"[$][(]March[)]" s + (cond + [(regexp-match? #rx"^t?a6" target-machine) "a6"] + [(regexp-match? #rx"^t?i3" target-machine) "i3"] + [(regexp-match? #rx"^t?arm32" target-machine) "arm32"] + [(regexp-match? #rx"^t?arm64" target-machine) "arm64"] + [(regexp-match? #rx"^t?ppc32" target-machine) "ppc32"] + [else (error "machine.def: cannto infer architecture")]))]) + (open-input-string s))])] + [else + (open-input-file (build-path* dir filename))])) diff --git a/src/ChezScheme/rktboot/make-boot.rkt b/src/ChezScheme/rktboot/make-boot.rkt index 3c559179c8..31a9f5f1bd 100644 --- a/src/ChezScheme/rktboot/make-boot.rkt +++ b/src/ChezScheme/rktboot/make-boot.rkt @@ -14,6 +14,7 @@ "scheme-readtable.rkt" "parse-makefile.rkt" "config.rkt" + "machine-def.rkt" "strip.rkt") ;; Set `SCHEME_SRC` and `MACH` to specify the ChezScheme source @@ -96,7 +97,8 @@ expand compile error - format)))) + format + make-variable-transformer)))) (reset-toplevels) @@ -242,14 +244,14 @@ (loop #`(begin #,@(with-source-path 'include (syntax->datum #'fn) (lambda (n) - (call-with-input-file* - n - (lambda (i) - (let loop () - (define r (read-syntax n i)) - (if (eof-object? r) - '() - (cons r (loop))))))))))] + (define i (open-file-with-machine.def-redirect n target-machine 'same)) + (begin0 + (let loop () + (define r (read-syntax n i)) + (if (eof-object? r) + '() + (cons r (loop)))) + (close-input-port i))))))] [(constant-case architecture [else e ...]) (loop #`(begin e ...))] [(constant-case architecture [(arch ...) e ...] . _) @@ -425,6 +427,7 @@ "cpletrec.ss" "cpcommonize.ss" "cpnanopass.ss" + "cpprim.ss" "compile.ss" "back.ss"))]) (status (format "Load ~a" s)) diff --git a/src/ChezScheme/rktboot/r6rs-lang.rkt b/src/ChezScheme/rktboot/r6rs-lang.rkt index 55161fb732..ff774d4bcd 100644 --- a/src/ChezScheme/rktboot/r6rs-lang.rkt +++ b/src/ChezScheme/rktboot/r6rs-lang.rkt @@ -59,6 +59,7 @@ [s:quasisyntax quasisyntax] [s:define-syntax define-syntax] [s:syntax->datum syntax->datum] + [make-set!-transformer make-variable-transformer] [s:if if] [lambda trace-lambda] [define-syntax trace-define-syntax] @@ -801,19 +802,29 @@ ;; 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-syntax (define-if-needed stx) + (syntax-case stx () + [(_ most-positive-fixnum most-negative-fixnum) + (cond + [(identifier-binding #'most-positive-fixnum) + ;; already defined + #'(begin)] + [else + #'(begin + (define 64-bit? (= (system-type 'word) 64)) + (define fixnum-bits (if (eq? 'racket (system-type 'vm)) + (if 64-bit? 63 31) + (if 64-bit? 61 30))) + (define low-fixnum (- (expt 2 (sub1 fixnum-bits)))) + (define high-fixnum (sub1 (expt 2 (sub1 fixnum-bits)))) + (define (most-positive-fixnum) high-fixnum) + (define (most-negative-fixnum) low-fixnum))])])) + +(define-if-needed most-positive-fixnum most-negative-fixnum) + +(define (fixnum-width) (add1 (integer-length (most-positive-fixnum)))) (define s:fixnum? fixnum?) -(define (most-positive-fixnum) high-fixnum) -(define (most-negative-fixnum) low-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 d035382d80..b4f69492a0 100644 --- a/src/ChezScheme/rktboot/record.rkt +++ b/src/ChezScheme/rktboot/record.rkt @@ -60,6 +60,9 @@ #(fld uid #f scheme-object 65) #(fld counts #f scheme-object 73)))) +(define base-rtd-ancestry (vector #f base-rtd)) +(define ANCESTRY-PARENT-OFFSET 2) + (define (s:struct-type? v) (or (struct-type? v) (base-rtd? v))) @@ -138,16 +141,17 @@ (define rtd-ancestors (make-weak-hasheq)) (define (register-rtd-ancestors! struct:name parent) + ;; ancestry vector is `(vector #f ... parent self)` (unless (hash-ref rtd-ancestors struct:name #f) (cond [(not parent) - (hash-set! rtd-ancestors struct:name (vector #f))] + (hash-set! rtd-ancestors struct:name (vector #f struct:name))] [(eq? parent struct:base-rtd-subtype) - (hash-set! rtd-ancestors struct:name (vector base-rtd #f))] + (hash-set! rtd-ancestors struct:name (vector #f base-rtd struct:name))] [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) + (define vec (make-vector (+ 1 (vector-length p-vec)) struct:name)) + (vector-copy! vec 0 p-vec) (hash-set! rtd-ancestors struct:name vec)]))) (define rtd-fields (make-weak-hasheq)) @@ -344,7 +348,7 @@ (assert-accessor) (lambda (rtd) (cond - [(base-rtd? rtd) '#(#f)] + [(base-rtd? rtd) base-rtd-ancestry] [else (define vec (hash-ref rtd-ancestors rtd)) (define-values (r-name init-cnt auto-cnt ref set immutables super skipped?) @@ -353,7 +357,7 @@ (if (eq? super struct:base-rtd-subtype) base-rtd super)) - (unless (eq? parent (vector-ref vec 0)) + (unless (eq? parent (vector-ref vec (- (vector-length vec) ANCESTRY-PARENT-OFFSET))) (error "ancestry sanity check failed" rtd vec parent)) vec]))] [(size) diff --git a/src/ChezScheme/rktboot/scheme-lang.rkt b/src/ChezScheme/rktboot/scheme-lang.rkt index 17b34d5106..f4380b25db 100644 --- a/src/ChezScheme/rktboot/scheme-lang.rkt +++ b/src/ChezScheme/rktboot/scheme-lang.rkt @@ -22,6 +22,7 @@ "record.rkt" (for-syntax "record.rkt") "constant.rkt" + "machine-def.rkt" (only-in "r6rs-lang.rkt" make-record-constructor-descriptor set-car! @@ -345,7 +346,6 @@ (define-syntax include (lambda (stx) (syntax-case stx () - [(form "machine.def") #`(form ,(string-append target-machine ".def"))] [(form p) #'(r:include-at/relative-to form form p)]))) ;; If we have to avoid `read-syntax`: @@ -353,7 +353,6 @@ (define-syntax include (lambda (stx) (syntax-case stx () - [(form "machine.def") #`(form #,(string-append target-machine ".def"))] [(form p) (let ([r (call-with-input-file* (syntax->datum #'p) @@ -1167,11 +1166,7 @@ (define who 'some-who) (define (with-source-path who name procedure) - (cond - [(equal? name "machine.def") - (procedure (string-append target-machine ".def"))] - [else - (procedure name)])) + (procedure name)) (define ($make-source-oops . args) #f) @@ -1192,7 +1187,7 @@ (define (interpret e) (eval e)) (define ($open-file-input-port who filename [options #f]) - (open-input-file filename)) + (open-file-with-machine.def-redirect filename target-machine 'same)) (define ($open-file-output-port who filename options) (open-output-file filename #:exists (if (eval `(enum-set-subset? (file-options replace) ',options)) diff --git a/src/ChezScheme/rpm/Makefile b/src/ChezScheme/rpm/Makefile index 901358bcdd..627e2d5820 100644 --- a/src/ChezScheme/rpm/Makefile +++ b/src/ChezScheme/rpm/Makefile @@ -13,7 +13,7 @@ # See the License for the specific language governing permissions and # limitations under the License. -version = 9.5.3 +version = 9.5.5 release = 1 m := $(shell find ../bin/* -type d | xargs basename) arch := $(shell if test "$(m)" == "i3le" ; then echo i686 ; elif test "$(m)" == "a6le" ; then echo x86_64 ; else echo UNKNOWN ; fi) diff --git a/src/ChezScheme/s/5_2.ss b/src/ChezScheme/s/5_2.ss index 35ff456a39..e171180eb8 100644 --- a/src/ChezScheme/s/5_2.ss +++ b/src/ChezScheme/s/5_2.ss @@ -80,6 +80,9 @@ (define index-range-error (lambda (who ls n) ($oops who "index ~s is out of range for list ~s" n ls))) + (define index-pair-error + (lambda (who ls n) + ($oops who "index ~s reaches a non-pair in ~s" n ls))) (define index-type-error (lambda (who n) ($oops who "index ~s is not an exact nonnegative integer" n))) @@ -87,7 +90,7 @@ (lambda (who tail ls n) (if (null? tail) (index-range-error who ls n) - (improper-list-error who ls)))) + (index-pair-error who ls n)))) (define list-length (lambda (ls who) (let loop ([hare ls] [i 0]) @@ -350,7 +353,7 @@ (set! assv (lambda (x alist) - (if (or (symbol? x) (#%$immediate? x)) + (if (or (symbol? x) (fixmediate? x)) (ass-eq? x alist 'assv) (do-assoc x alist 'assv eqv?)))) @@ -360,7 +363,7 @@ [(string? x) (do-assoc x alist 'assoc (lambda (x y) (and (string? x) (string=? x y))))] - [(or (symbol? x) (#%$immediate? x)) + [(or (symbol? x) (fixmediate? x)) (ass-eq? x alist 'assoc)] [else (do-assoc x alist 'assoc equal?)]))) diff --git a/src/ChezScheme/s/5_3.ss b/src/ChezScheme/s/5_3.ss index 35fe2e3462..c1ef389cf0 100644 --- a/src/ChezScheme/s/5_3.ss +++ b/src/ChezScheme/s/5_3.ss @@ -82,10 +82,12 @@ (define integer+ (schemeop2 "(cs)add")) (define integer* (schemeop2 "(cs)mul")) (define integer- (schemeop2 "(cs)sub")) -(define integer/ (schemeop2 "(cs)s_div")) -(define intquotient (schemeop2 "(cs)ss_trunc")) -(define intquotient-remainder (schemeop2 "(cs)ss_trunc_rem")) -(define intremainder (schemeop2 "(cs)rem")) +(define schoolbook-integer/ (schemeop2 "(cs)s_div")) +(define schoolbook-intquotient (schemeop2 "(cs)ss_trunc")) +(define schoolbook-intquotient-remainder (schemeop2 "(cs)ss_trunc_rem")) +(define schoolbook-intremainder (schemeop2 "(cs)rem")) +(define make-ratnum (schemeop2 "(cs)s_rational")) ; does not normalize, except detecting 1 as demoninator +(define exgcd (schemeop2 "(cs)gcd")) (define $flsin (cflop1 "(cs)sin")) @@ -99,6 +101,179 @@ (let () +;; Burnikel-Ziegler division by Peter Bex from a series about CHICKEN's +;; numeric tower: +;; https://www.more-magic.net/posts/numeric-tower-part-3.html +;; Licensed under the Creative Commons Attribution 3.0 License. +;; The Scheme code here appears to be directly based on the C +;; code in CHICKEN's BSD-licensed "runtime.c": +;; Copyright (c) 2008-2020, The CHICKEN Team +;; Copyright (c) 2000-2007, Felix L. Winkelmann +;; All rights reserved. + +(define DIV-LIMIT 100) + +(define (bigits->bits n) (fx* (constant bigit-bits) n)) ; Small helper + +(define (extract-bigits n start end) + (let ([s-bits (bigits->bits start)]) + (bitwise-bit-field n s-bits (if end + (bigits->bits end) + (fxmax s-bits (integer-length n)))))) + +;; Here and in 2n/1n we pass both b and [b1, b2] to avoid splitting +;; up the number more than once. This is a helper function for 2n/n. +(define (burnikel-ziegler-3n/2n a12 a3 b b1 b2 n) + (let-values ([(q^ r1) (if (< (bitwise-arithmetic-shift-right a12 (bigits->bits n)) b1) + (let* ((n/2 (fxsra n 1)) ; (floor (/ n 2)) + (b11 (extract-bigits b1 n/2 #f)) ; b1[n..n/2] + (b12 (extract-bigits b1 0 n/2))) ; b1[n/2..0] + (burnikel-ziegler-2n/1n a12 b1 b11 b12 n #t)) + ;; Don't bother dividing if a1 is a larger number than b1. + ;; We use a maximum guess instead (see paper for proof). + (let ((base*n (bigits->bits n))) + (values (- (bitwise-arithmetic-shift-left 1 base*n) 1) ; B^n-1 + (+ (- a12 (bitwise-arithmetic-shift-left b1 base*n)) b1))))]) + (let ((r1a3 (+ (bitwise-arithmetic-shift-left r1 (bigits->bits n)) a3))) + (let lp ((r^ (- r1a3 (* q^ b2))) + (q^ q^)) + (if (negative? r^) + (lp (+ r^ b) (- q^ 1)) ; Adjust! + (values q^ r^)))))) + +;; The main 2n/n algorithm which calls 3n/2n twice. Here, a is the +;; numerator, b the denominator, n is the length of b (in digits) and +;; b1 and b2 are the two halves of b (these never change). +(define (burnikel-ziegler-2n/1n a b b1 b2 n return-quot?) + (if (or (fxodd? n) (fx< n DIV-LIMIT)) ; Can't recur? + (let ([p (schoolbook-intquotient-remainder a b)]) ; Use school division + (values (car p) (cdr p))) + (let* ((n/2 (fxsra n 1)) + ;; Split a and b into n-sized parts [a1, ..., a4] and [b1, b2] + (a12 (extract-bigits a n #f)) ; a[m..n] + (a3 (extract-bigits a n/2 n)) ; a[n..n/2] + (a4 (extract-bigits a 0 n/2))) ; a[n..0] + ;; Calculate high quotient and intermediate remainder (first half) + (let-values ([(q1 r1) (burnikel-ziegler-3n/2n a12 a3 b b1 b2 n/2)]) + ;; Calculate low quotient and final remainder (second half) + (let-values ([(q2 r) (burnikel-ziegler-3n/2n r1 a4 b b1 b2 n/2)]) + ;; Recombine quotient parts as q = [q1,q2] + (values (and return-quot? + (+ (bitwise-arithmetic-shift-left q1 (bigits->bits n/2)) q2)) + r)))))) + +(define (quotient&remainder/burnikel-ziegler x y return-quot? return-rem?) + ;; Caller will have made sure that x and y are bignums + (let* ((q-neg? (if (negative? y) (not (negative? x)) (negative? x))) + (r-neg? (negative? x)) + (abs-x (abs x)) + (abs-y (abs y))) + (cond + [(> abs-x abs-y) + (let* ((x abs-x) + (y abs-y) + (s ($bignum-length y)) + ;; Define m as min{2^k|(2^k)*DIV_LIMIT > s}. + ;; This ensures we shift as little as possible (less pressure + ;; on the GC) while maintaining a power of two until we drop + ;; below the threshold, so we can always split N in half. + (m (fxsll 1 (integer-length (fx/ s DIV-LIMIT)))) + (j (fx/ (fx+ s (fx- m 1)) m)) ; j = s/m, rounded up + (n (fx* j m)) + ;; Normalisation, just like with normal school division + (norm-shift (fx- (bigits->bits n) (integer-length y))) + (x (bitwise-arithmetic-shift-left x norm-shift)) + (y (bitwise-arithmetic-shift-left y norm-shift)) + ;; l needs to be the smallest value so that a < base^{l*n}/2 + (l (fx/ (fx+ ($bignum-length x) n) n)) + (l (if (fx= (bigits->bits l) (integer-length x)) (fx+ l 1) l)) + (t (fxmax l 2)) + (y-hi (extract-bigits y (fxsra n 1) #f)) ; y[n..n/2] + (y-lo (extract-bigits y 0 (fxsra n 1)))) ; y[n/2..0] + (let lp ((zi (bitwise-arithmetic-shift-right x (bigits->bits (fx* (fx- t 2) n)))) + (i (fx- t 2)) + (quot 0)) + (let-values ([(qi ri) (burnikel-ziegler-2n/1n zi y y-hi y-lo n return-quot?)]) + (let ((quot (and return-quot? + (+ (bitwise-arithmetic-shift-left quot (bigits->bits n)) qi)))) + (if (fx> i 0) + (let ((zi-1 (let* ((base*n*i-1 (fx* n (fx- i 1))) + (base*n*i (fx* n i)) + ;; x_{i-1} = x[n*i..n*(i-1)] + (xi-1 (extract-bigits x base*n*i-1 base*n*i))) + (+ (bitwise-arithmetic-shift-left ri (bigits->bits n)) xi-1)))) + (lp zi-1 (fx- i 1) quot)) + ;; De-normalise remainder, but only if necessary + (let ((rem (if (or (not return-rem?) (eq? 0 norm-shift)) + ri + (bitwise-arithmetic-shift-right ri norm-shift)))) + ;; Return values (quot, rem or both) with correct sign: + (cond ((and return-quot? return-rem?) + (values (if q-neg? (- quot) quot) + (if r-neg? (- rem) rem))) + (return-quot? (if q-neg? (- quot) quot)) + (else (if r-neg? (- rem) rem)))))))))] + [(< abs-x abs-y) + (cond + [(and return-quot? return-rem?) (values 0 x)] + [return-quot? 0] + [else x])] + [else + (cond + [(and return-quot? return-rem?) (values (if q-neg? -1 1) 0)] + [return-quot? (if q-neg? -1 1)] + [else 0])]))) + +;; Only try to use Burnikel-Ziegler when we have large enough bignums: +(define (big-divide-bignums? n d) + (and (bignum? n) + (bignum? d) + (fx>= ($bignum-length n) DIV-LIMIT) + (fx>= ($bignum-length d) DIV-LIMIT))) + +(define integer/ + (lambda (n d) + (cond + [(big-divide-bignums? n d) + (let* ([g (exgcd n d)] + [g (if ($bigpositive? d) + g + (- g))]) + (if (or (fixnum? g) + (fx< ($bignum-length g) DIV-LIMIT)) + (make-ratnum (schoolbook-intquotient n g) + (schoolbook-intquotient d g)) + (make-ratnum (quotient&remainder/burnikel-ziegler n g #t #f) + (quotient&remainder/burnikel-ziegler d g #t #f))))] + [else (schoolbook-integer/ n d)]))) + +(define intquotient + (lambda (n d) + (cond + [(big-divide-bignums? n d) + (quotient&remainder/burnikel-ziegler n d #t #f)] + [else + (schoolbook-intquotient n d)]))) + +(define intquotient-remainder + (lambda (n d) + (cond + [(big-divide-bignums? n d) + (let-values ([(q r) (quotient&remainder/burnikel-ziegler n d #t #t)]) + (cons q r))] + [else + (schoolbook-intquotient-remainder n d)]))) + +(define intremainder + (lambda (n d) + (cond + [(big-divide-bignums? n d) + (quotient&remainder/burnikel-ziegler n d #f #t)] + [else + (schoolbook-intremainder n d)]))) + +(let () + (define omega (float-type-case [(ieee) (float #e1.7976931348623157e308)])) @@ -914,7 +1089,7 @@ (fx- x))] [(bignum?) (big-negate x)] [(flonum?) (fl- x)] - [(ratnum?) (integer/ (- ($ratio-numerator x)) ($ratio-denominator x))] + [(ratnum?) (make-ratnum (- ($ratio-numerator x)) ($ratio-denominator x))] [($exactnum? $inexactnum?) (make-rectangular (- (real-part x)) (- (imag-part x)))] [else (nonnumber-error who x)]))) @@ -1154,11 +1329,6 @@ (loop (max x (car z)) (cdr z))))]))) (let () - (define exgcd - (foreign-procedure "(cs)gcd" - (scheme-object scheme-object) - scheme-object)) - (define (exlcm x1 x2) (if (or (eqv? x1 0) (eqv? x2 0)) 0 @@ -2151,7 +2321,7 @@ [(fixnum? bignum?) (integer+ x y)] [(ratnum?) (let ([d ($ratio-denominator y)]) - (integer/ (+ (* x d) ($ratio-numerator y)) d))] + (make-ratnum (+ (* x d) ($ratio-numerator y)) d))] [(flonum?) (exact-inexact+ x y)] [($exactnum? $inexactnum?) (make-rectangular (+ x (real-part y)) (imag-part y))] @@ -2169,12 +2339,28 @@ (type-case y [(fixnum? bignum?) (let ([d ($ratio-denominator x)]) - (integer/ (+ (* y d) ($ratio-numerator x)) d))] + (make-ratnum (+ (* y d) ($ratio-numerator x)) d))] [(ratnum?) - (let ([xd ($ratio-denominator x)] [yd ($ratio-denominator y)]) - (integer/ - (+ (* ($ratio-numerator x) yd) (* ($ratio-numerator y) xd)) - (* xd yd)))] + ;; adapted from Gambit, see gambit/lib/_num.scm + (let ((p ($ratio-numerator x)) + (q ($ratio-denominator x)) + (r ($ratio-numerator y)) + (s ($ratio-denominator y))) + (let ((d1 (exgcd q s))) + (if (eqv? d1 1) + (make-ratnum (+ (* p s) + (* r q)) + (* q s)) + (let* ((s-prime (intquotient s d1)) + (t (+ (* p s-prime) + (* r (intquotient q d1)))) + (d2 (exgcd d1 t)) + (num (intquotient t d2)) + (den (* (intquotient q d2) + s-prime))) + (if (eqv? den 1) + num + (make-ratnum num den))))))] [($exactnum? $inexactnum?) (make-rectangular (+ x (real-part y)) (imag-part y))] [(flonum?) (exact-inexact+ x y)] @@ -2197,6 +2383,7 @@ [else (nonnumber-error who x)])]))) (set! $* + (let ([$bignum-trailing-zero-bits (foreign-procedure "(cs)s_big_trailing_zero_bits" (ptr) ptr)]) (lambda (who x y) (cond [(and (fixnum? y) ($fxu< (#3%fx+ y 1) 3)) @@ -2217,20 +2404,116 @@ [(fx= x 1) (unless (number? y) (nonnumber-error who y)) y] [else ($negate who y)])] [else (integer* x y)]) - (let () + (let ([slim 32] + [klim 100] + [t3lim 512]) + ; both of the following functions were adapted from + ; https://github.com/casevh/DecInt/blob/master/DecInt.py#L451 + ; under the BSD license + (define (toom3 x y) + (define xl (if (bignum? x) ($bignum-length x) 0)) + (define yl (if (bignum? y) ($bignum-length y) 0)) + (cond + [(and (fx< xl slim) (fx< yl slim)) + (integer* x y)] + [(and (fx< xl klim) (fx< yl klim)) + (karatsuba x y)] + [else + (let* ([k (fx* (fxquotient (fxmax xl yl) 3) (constant bigit-bits))] + [x-hi (ash x (fx* -2 k))] + [y-hi (ash y (fx* -2 k))] + [x-mid (bitwise-bit-field x k (fx* 2 k))] + [y-mid (bitwise-bit-field y k (fx* 2 k))] + [x-lo (bitwise-bit-field x 0 k)] + [y-lo (bitwise-bit-field y 0 k)] + [z0 (toom3 x-hi y-hi)] + [z4 (toom3 x-lo y-lo)] + [t1 (toom3 (+ x-hi x-mid x-lo) (+ y-hi y-mid y-lo))] + [t2 (toom3 (+ (- x-hi x-mid) x-lo) (+ (- y-hi y-mid) y-lo))] + [t3 (* (+ x-hi (ash x-mid 1) (ash x-lo 2)) + (+ y-hi (ash y-mid 1) (ash y-lo 2)))] + [z2 (- (ash (+ t1 t2) -1) z0 z4)] + [t4 (- t3 z0 (ash z2 2) (ash z4 4))] + [z3 (quotient (+ (- t4 t1) t2) 6)] + [z1 (- (ash (- t1 t2) -1) z3)]) + (+ (ash z0 (* k 4)) + (ash z1 (* k 3)) + (ash z2 (* k 2)) + (ash z3 (* k 1)) + (ash z4 (* k 0))))])) + + (define (toom4 x y) + (define xl (if (bignum? x) ($bignum-length x) 0)) + (define yl (if (bignum? y) ($bignum-length y) 0)) + (cond + [(and (fx< xl slim) (fx< yl slim)) + (integer* x y)] + [(and (fx< xl klim) (fx< yl klim)) + (karatsuba x y)] + [(and (fx< xl t3lim) (fx< yl t3lim)) + (toom3 x y)] + [else + (let* ((k (fx* (fxquotient (fxmax xl yl) 4) (constant bigit-bits))) + (x0 (ash x (fx* -3 k))) + (y0 (ash y (fx* -3 k))) + (x1 (bitwise-bit-field x (fx* 2 k) (fx* 3 k))) + (y1 (bitwise-bit-field y (fx* 2 k) (fx* 3 k))) + (x2 (bitwise-bit-field x (fx* 1 k) (fx* 2 k))) + (y2 (bitwise-bit-field y (fx* 1 k) (fx* 2 k))) + (x3 (bitwise-bit-field x 0 k)) + (y3 (bitwise-bit-field y 0 k)) + (z0 (toom4 x0 y0)) + (z6 (toom4 x3 y3)) + (t0 (+ z0 z6)) + (xeven (+ x0 x2)) + (xodd (+ x1 x3)) + (yeven (+ y0 y2)) + (yodd (+ y1 y3)) + (t1 (- (toom4 (+ xeven xodd) (+ yeven yodd)) t0)) + (t2 (- (toom4 (- xeven xodd) (- yeven yodd)) t0)) + (xeven (+ x0 (ash x2 2))) + (xodd (+ (ash x1 1) (ash x3 3))) + (yeven (+ y0 (ash y2 2))) + (yodd (+ (ash y1 1) (ash y3 3))) + (t0 (+ z0 (ash z6 6))) + (t3 (- (toom4 (+ xeven xodd) (+ yeven yodd)) t0)) + (t4 (- (toom4 (- xeven xodd) (- yeven yodd)) t0)) + (t5 (- (* (+ x0 (* 3 x1) (* 9 x2) (* 27 x3)) + (+ y0 (* 3 y1) (* 9 y2) (* 27 y3))) + (+ z0 (* 729 z6)))) + (t6 (+ t1 t2)) + (t7 (+ t3 t4)) + (z4 (quotient (- t7 (ash t6 2)) 24)) + (z2 (- (ash t6 -1) z4)) + (t8 (- t1 z2 z4)) + (t9 (- t3 (ash z2 2) (ash z4 4))) + (t10 (- t5 (* 9 z2) (* 81 z4))) + (t11 (- t10 (* 3 t8))) + (t12 (- t9 (ash t8 1))) + (z5 (quotient (- t11 (ash t12 2)) 120)) + (z3 (quotient (- (ash t12 3) t11) 24)) + (z1 (- t8 z3 z5))) + (+ (ash z0 (* k 6)) + (ash z1 (* k 5)) + (ash z2 (* k 4)) + (ash z3 (* k 3)) + (ash z4 (* k 2)) + (ash z5 (* k 1)) + (ash z6 (* k 0))))])) + ;; _Modern Computer Arithmetic_, Brent and Zimmermann (define (karatsuba x y) (define xl (if (bignum? x) ($bignum-length x) 0)) (define yl (if (bignum? y) ($bignum-length y) 0)) (cond - [(and (fx< xl 10) (fx< yl 10)) + [(and (fx< xl 30) (fx< yl 30)) (integer* x y)] [else (let* ([k (fx* (fxquotient (fxmax xl yl) 2) (constant bigit-bits))] [x-hi (ash x (fx- k))] [y-hi (ash y (fx- k))] - [x-lo (- x (ash x-hi k))] - [y-lo (- y (ash y-hi k))] + [x-lo (bitwise-bit-field x 0 k)] + [y-lo (bitwise-bit-field y 0 k)] [c0 (karatsuba x-lo y-lo)] [c1 (karatsuba x-hi y-hi)] [c1-c2 (cond @@ -2247,7 +2530,17 @@ [else (- c1 (karatsuba (- x-lo x-hi) (- y-lo y-hi)))])])]) (+ c0 (integer-ash (+ c0 c1-c2) k) (integer-ash c1 (fx* 2 k))))])) - (karatsuba x y)))] + ;; Multiplying numbers with trailing 0s is common, so + ;; check for that case: + (let ([xz ($bignum-trailing-zero-bits x)] + [yz (if (bignum? y) ($bignum-trailing-zero-bits y) 0)]) + (let ([z (fx+ xz yz)]) + (if (fx= z 0) + (toom4 x y) + (bitwise-arithmetic-shift-left + (toom4 (bitwise-arithmetic-shift-right x xz) + (bitwise-arithmetic-shift-right y yz)) + z))))))] [(ratnum?) (/ (* x ($ratio-numerator y)) ($ratio-denominator y))] [($exactnum? $inexactnum?) (make-rectangular (* x (real-part y)) (* x (imag-part y)))] @@ -2258,9 +2551,20 @@ [(fixnum? bignum?) (integer/ (* y ($ratio-numerator x)) ($ratio-denominator x))] [(ratnum?) - (integer/ - (* ($ratio-numerator x) ($ratio-numerator y)) - (* ($ratio-denominator x) ($ratio-denominator y)))] + ;; adapted from Gambit, see gambit/lib/_num.scm + (let ((p ($ratio-numerator x)) + (q ($ratio-denominator x)) + (r ($ratio-numerator y)) + (s ($ratio-denominator y))) + (if (eq? x y) + (make-ratnum (magnitude-squared p) (magnitude-squared q)) ;; already in lowest form + (let* ((gcd-ps (exgcd p s)) + (gcd-rq (exgcd r q)) + (num (* (intquotient p gcd-ps) (intquotient r gcd-rq))) + (den (* (intquotient q gcd-rq) (intquotient s gcd-ps)))) + (if (eqv? den 1) + num + (make-ratnum num den)))))] [($exactnum? $inexactnum?) (make-rectangular (* x (real-part y)) (* x (imag-part y)))] [(flonum?) (exact-inexact* x y)] @@ -2281,7 +2585,7 @@ [c (real-part y)] [d (imag-part y)]) (make-rectangular (- (* a c) (* b d)) (+ (* a d) (* b c))))] [else (nonnumber-error who y)])] - [else (nonnumber-error who x)])]))) + [else (nonnumber-error who x)])])))) (set! $- (lambda (who x y) @@ -2290,7 +2594,7 @@ [(fixnum? bignum?) (integer- x y)] [(ratnum?) (let ([d ($ratio-denominator y)]) - (integer/ (- (* x d) ($ratio-numerator y)) d))] + (make-ratnum (- (* x d) ($ratio-numerator y)) d))] [($exactnum? $inexactnum?) (make-rectangular (- x (real-part y)) (- (imag-part y)))] [(flonum?) (exact-inexact- x y)] @@ -2308,12 +2612,28 @@ (type-case y [(fixnum? bignum?) (let ([d ($ratio-denominator x)]) - (integer/ (- ($ratio-numerator x) (* y d)) d))] + (make-ratnum (- ($ratio-numerator x) (* y d)) d))] [(ratnum?) - (let ([xd ($ratio-denominator x)] [yd ($ratio-denominator y)]) - (integer/ - (- (* ($ratio-numerator x) yd) (* ($ratio-numerator y) xd)) - (* xd yd)))] + ;; adapted from Gambit, see gambit/lib/_num.scm + (let ((p ($ratio-numerator x)) + (q ($ratio-denominator x)) + (r ($ratio-numerator y)) + (s ($ratio-denominator y))) + (let ((d1 (gcd q s))) + (if (eqv? d1 1) + (make-ratnum (- (* p s) + (* r q)) + (* q s)) + (let* ((s-prime (intquotient s d1)) + (t (- (* p s-prime) + (* r (intquotient q d1)))) + (d2 (exgcd d1 t)) + (num (intquotient t d2)) + (den (* (intquotient q d2) + s-prime))) + (if (eqv? den 1) + num + (make-ratnum num den))))))] [($exactnum? $inexactnum?) (make-rectangular (- x (real-part y)) (- (imag-part y)))] [(flonum?) (exact-inexact- x y)] @@ -2380,11 +2700,35 @@ [else (nonnumber-error who x)])] [(ratnum?) (type-case x - [(fixnum? bignum?) - (integer/ (* x ($ratio-denominator y)) ($ratio-numerator y))] + [(fixnum? bignum?) + (cond + [(eq? x 1) (if (negative? ($ratio-numerator y)) + (make-ratnum ($negate who ($ratio-denominator y)) ($negate who ($ratio-numerator y))) + (make-ratnum ($ratio-denominator y) ($ratio-numerator y)))] + [(eq? x -1) (if (negative? ($ratio-numerator y)) + (make-ratnum ($ratio-denominator y) ($negate who ($ratio-numerator y))) + (make-ratnum ($negate who ($ratio-denominator y)) ($ratio-numerator y)))] + [else + (integer/ (* x ($ratio-denominator y)) ($ratio-numerator y))])] [(ratnum?) - (integer/ (* ($ratio-numerator x) ($ratio-denominator y)) - (* ($ratio-denominator x) ($ratio-numerator y)))] + ;; adapted from Gambit, see gambit/lib/_num.scm + (let ((p ($ratio-numerator x)) + (q ($ratio-denominator x)) + (r ($ratio-denominator y)) + (s ($ratio-numerator y))) + (if (eq? x y) + 1 + (let* ((gcd-ps (exgcd p s)) + (gcd-rq (exgcd r q)) + (num (* (intquotient p gcd-ps) (intquotient r gcd-rq))) + (den (* (intquotient q gcd-rq) (intquotient s gcd-ps)))) + (if (negative? den) + (if (eqv? den -1) + (- num) + (make-ratnum (- num) (- den))) + (if (eqv? den 1) + num + (make-ratnum num den))))))] [($exactnum? $inexactnum?) (make-rectangular (/ (real-part x) y) (/ (imag-part x) y))] [(flonum?) (inexact-exact/ x y)] @@ -2418,7 +2762,7 @@ (/ (- (* b c) (* a d)) t)))) ;; Let r = c/d or d/c, depending on which is larger (cond - [(and ($exactnum? x) ($exactnum? y)) + [(or (eq? c 0) (and ($exactnum? x) ($exactnum? y))) (simpler-divide a b c d)] [(< (abs c) (abs d)) (let ([r (/ d c)]) @@ -3299,5 +3643,5 @@ [m^ 0 (logor (sll m^ w-1) ($fxreverse (logand m mask) w-1))] [k (- end start) (- k w-1)]) ((<= k w-1) (logor (sll m^ k) ($fxreverse m k)))))))) -))))))) +)))))))) ) diff --git a/src/ChezScheme/s/7.ss b/src/ChezScheme/s/7.ss index 9c19a51230..8b639b9758 100644 --- a/src/ChezScheme/s/7.ss +++ b/src/ChezScheme/s/7.ss @@ -699,6 +699,10 @@ [() ((abort-handler)) (unexpected-return who)] [(x) ((abort-handler) x) (unexpected-return who)]))) +(define-who assert-unreachable + (lambda () + ($oops who "unreachable code reached"))) + (define $interrupt ($make-thread-parameter void)) (define $format-scheme-version @@ -767,11 +771,13 @@ (lambda (t) (unless (and (time? t) (eq? (time-type t) 'time-duration)) ($oops who "~s is not a time record of type time-duration" t)) - (fp (time-second t) (time-nanosecond t))))) + (let ([s (time-second t)]) + (when (>= s 0) + (fp s (time-nanosecond t))))))) (define $scheme-greeting (lambda () - (format "~a\nCopyright 1984-2019 Cisco Systems, Inc.\n" + (format "~a\nCopyright 1984-2020 Cisco Systems, Inc.\n" (scheme-version)))) (define $session-key #f) diff --git a/src/ChezScheme/s/Mf-a6fb b/src/ChezScheme/s/Mf-a6fb deleted file mode 100644 index 3a42a41cd6..0000000000 --- a/src/ChezScheme/s/Mf-a6fb +++ /dev/null @@ -1,19 +0,0 @@ -# Mf-a6fb -# 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 ?= a6fb -archincludes = x86_64.ss - -include Mf-base diff --git a/src/ChezScheme/s/Mf-a6le b/src/ChezScheme/s/Mf-a6le deleted file mode 100644 index 7daf9348d3..0000000000 --- a/src/ChezScheme/s/Mf-a6le +++ /dev/null @@ -1,19 +0,0 @@ -# Mf-a6le -# 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 ?= a6le -archincludes = x86_64.ss - -include Mf-base diff --git a/src/ChezScheme/s/Mf-a6nb b/src/ChezScheme/s/Mf-a6nb deleted file mode 100644 index 1a04d4f2c0..0000000000 --- a/src/ChezScheme/s/Mf-a6nb +++ /dev/null @@ -1,19 +0,0 @@ -# Mf-a6nb -# 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 ?= a6nb -archincludes = x86_64.ss - -include Mf-base diff --git a/src/ChezScheme/s/Mf-a6nt b/src/ChezScheme/s/Mf-a6nt index 29e08a5297..f8ab8f345e 100644 --- a/src/ChezScheme/s/Mf-a6nt +++ b/src/ChezScheme/s/Mf-a6nt @@ -13,7 +13,6 @@ # See the License for the specific language governing permissions and # limitations under the License. -m ?= a6nt archincludes = x86_64.ss include Mf-base diff --git a/src/ChezScheme/s/Mf-a6ob b/src/ChezScheme/s/Mf-a6ob deleted file mode 100644 index 64cc55aac0..0000000000 --- a/src/ChezScheme/s/Mf-a6ob +++ /dev/null @@ -1,19 +0,0 @@ -# Mf-a6ob -# 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 ?= a6ob -archincludes = x86_64.ss - -include Mf-base diff --git a/src/ChezScheme/s/Mf-a6osx b/src/ChezScheme/s/Mf-a6osx deleted file mode 100644 index 9bf0942ab8..0000000000 --- a/src/ChezScheme/s/Mf-a6osx +++ /dev/null @@ -1,19 +0,0 @@ -# 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 ?= a6osx -archincludes = x86_64.ss - -include Mf-base diff --git a/src/ChezScheme/s/Mf-a6s2 b/src/ChezScheme/s/Mf-a6s2 deleted file mode 100644 index 0ac51751e2..0000000000 --- a/src/ChezScheme/s/Mf-a6s2 +++ /dev/null @@ -1,19 +0,0 @@ -# Mf-a6s2 -# 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 ?= a6s2 -archincludes = x86_64.ss - -include Mf-base diff --git a/src/ChezScheme/s/Mf-arm32le b/src/ChezScheme/s/Mf-arm32le deleted file mode 100644 index fd7b8fe43f..0000000000 --- a/src/ChezScheme/s/Mf-arm32le +++ /dev/null @@ -1,21 +0,0 @@ -# Mf-arm32le -# 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 ?= arm32le -archincludes = arm32.ss - -include Mf-base - -machine.def: arm32.def diff --git a/src/ChezScheme/s/Mf-arm64le b/src/ChezScheme/s/Mf-arm64le deleted file mode 100644 index 1c7ce88365..0000000000 --- a/src/ChezScheme/s/Mf-arm64le +++ /dev/null @@ -1,21 +0,0 @@ -# Mf-arm64le -# 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 ?= arm64le -archincludes = arm64.ss - -include Mf-base - -machine.def: arm64.def diff --git a/src/ChezScheme/s/Mf-arm64osx b/src/ChezScheme/s/Mf-arm64osx deleted file mode 100644 index 92a5257213..0000000000 --- a/src/ChezScheme/s/Mf-arm64osx +++ /dev/null @@ -1,21 +0,0 @@ -# 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 c42e9fe2f6..3dfa5d343f 100644 --- a/src/ChezScheme/s/Mf-base +++ b/src/ChezScheme/s/Mf-base @@ -38,7 +38,7 @@ cp0 = 2 # fc determines whether fasl objects are compressed fc = t -# xf determines the compression foramt +# xf determines the compression format xf = (compress-format) # xl determine the compression level @@ -124,7 +124,7 @@ patchfile = patch = patch # putting cpnanopass.patch early for maximum make --jobs=2 benefit -patchobj = patch.patch cpnanopass.patch cprep.patch cpcheck.patch\ +patchobj = patch.patch cpnanopass.patch cpprim.patch cprep.patch cpcheck.patch\ cp0.patch cpvalid.patch cptypes.patch cpcommonize.patch cpletrec.patch\ reloc.patch\ compile.patch fasl.patch vfasl.patch syntax.patch env.patch\ @@ -155,7 +155,7 @@ basesrc =\ baseobj = ${basesrc:%.ss=%.$m} compilersrc =\ - cpnanopass.ss compile.ss cback.ss + cpnanopass.ss cpprim.ss compile.ss cback.ss compilerobj = ${compilersrc:%.ss=%.$m} @@ -169,7 +169,7 @@ 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 strip-types.ss + np-languages.ss fxmap.ss cptypes-lattice.ss strip-types.ss np-register.ss np-info.ss np-help.ss # doit uses a different Scheme process to compile each target doit: ${PetiteBoot} ${SchemeBoot} ${Cheader} ${Cequates} ${Cgcocd} ${Cgcoce} ${Cgcpar} ${Cheapcheck} ${Revision} @@ -214,7 +214,7 @@ profiled: $(MAKE) all loadspd=t bp=t PetiteBoot=../boot/$m/xpetite.boot SchemeBoot=../boot/$m/xscheme.boot $(MAKE) prettyclean $(MAKE) io.$m loadspd=t dumpbpd=t Scheme="../bin/$m/scheme -b ../boot/$m/xpetite.boot -b ../boot/$m/xscheme.boot" - /bin/rm -f ../boot/$m/xpetite.boot ../boot/$m/xscheme.boot + rm -f ../boot/$m/xpetite.boot ../boot/$m/xscheme.boot $(MAKE) prettyclean $(MAKE) all loadspd=t loadbpd=t @@ -252,6 +252,7 @@ clean: profileclean '(collect 1 2)'\ '(delete-file "$*.covin")'\ '(time (${compile} "$*.ss" "$*.$m" (quote $m)))'\ + '(printf " ~a bytes peak memory use~n" (maximum-memory-bytes))' \ '(when #${pdhtml} (profile-dump-html))'\ '(when #${dumpspd} (profile-dump-data "${ProfileDumpSource}"))'\ '(when #${dumpbpd} (profile-dump-data "${ProfileDumpBlock}"))'\ @@ -320,6 +321,7 @@ clean: profileclean '(collect-request-handler (lambda () (collect 0 1)))'\ '(collect 1 2)'\ '(time (${compile} "$*.ss" "$*.patch" (quote $m)))'\ + '(printf " ~a bytes peak memory use~n" (maximum-memory-bytes))' \ | ${Scheme} -q ${macroobj} saveboot: @@ -506,6 +508,7 @@ script.all makescript: ' (quote $m)))'\ ' (quote (${src}))'\ ' (quote (${obj}))))'\ + '(printf " ~a bytes peak memory use~n" (maximum-memory-bytes))' \ '(when #${pps} (#%$$print-pass-stats))'\ '(delete-file (string-append (path-root "${PetiteBoot}") ".covin"))'\ '(apply #%$$make-boot-file "${PetiteBoot}" (quote $m) (quote ())'\ @@ -595,9 +598,9 @@ 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 strip-types.ss env.ss -cpnanopass.$m cpnanopass.patch: nanopass.so np-languages.ss fxmap.ss ${archincludes} -cptypes.$m: fxmap.ss +${patchobj}: ${macroobj} nanopass.so base-lang.ss expand-lang.ss primref.ss types.ss io-types.ss fasl-helpers.ss hashtable-types.ss strip-types.ss env.ss fxmap.ss cptypes-lattice.ss +cpnanopass.$m cpnanopass.patch cpnanopass.so cpprim.$m cpprim.patch: nanopass.so np-languages.ss np-register.ss np-info.ss np-help.ss ${archincludes} +cptypes.$m: fxmap.ss cptypes-lattice.ss 5_4.$m: ../unicode/unicode-char-cases.ss ../unicode/unicode-charinfo.ss strip.$m: strip-types.ss vfasl.$m: strip-types.ss diff --git a/src/ChezScheme/s/Mf-cross b/src/ChezScheme/s/Mf-cross index 24afa23d0e..d796cbb459 100644 --- a/src/ChezScheme/s/Mf-cross +++ b/src/ChezScheme/s/Mf-cross @@ -22,7 +22,7 @@ base = ../.. xdoit: xboot -include Mf-${xm} +include Mf-base Scheme=$(base)/bin/${m}/scheme export SCHEMEHEAPDIRS=$(base)/boot/${m} @@ -34,7 +34,7 @@ xpatch = xpatch xpatchobj = ${patchobj} xboot: ${xpatch} - $(MAKE) -f Mf-${xm} ${what} m=${xm} patchfile=${xpatch} Scheme="${Scheme}" SCHEMEHEAPDIRS=${SCHEMEHEAPDIRS} + $(MAKE) -f Mf-base ${what} m=${xm} patchfile=${xpatch} Scheme="${Scheme}" SCHEMEHEAPDIRS=${SCHEMEHEAPDIRS} ${xpatch}: ${xpatchobj} cat ${xpatchobj} > ${xpatch} diff --git a/src/ChezScheme/s/Mf-i3fb b/src/ChezScheme/s/Mf-i3fb deleted file mode 100644 index f96b9eabd7..0000000000 --- a/src/ChezScheme/s/Mf-i3fb +++ /dev/null @@ -1,19 +0,0 @@ -# Mf-i3fb -# 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 ?= i3fb -archincludes = x86.ss - -include Mf-base diff --git a/src/ChezScheme/s/Mf-i3le b/src/ChezScheme/s/Mf-i3le deleted file mode 100644 index 1caf899063..0000000000 --- a/src/ChezScheme/s/Mf-i3le +++ /dev/null @@ -1,19 +0,0 @@ -# Mf-i3le -# 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 ?= i3le -archincludes = x86.ss - -include Mf-base diff --git a/src/ChezScheme/s/Mf-i3nb b/src/ChezScheme/s/Mf-i3nb deleted file mode 100644 index ed037cdedd..0000000000 --- a/src/ChezScheme/s/Mf-i3nb +++ /dev/null @@ -1,19 +0,0 @@ -# Mf-i3nb -# 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 ?= i3nb -archincludes = x86.ss - -include Mf-base diff --git a/src/ChezScheme/s/Mf-i3nt b/src/ChezScheme/s/Mf-i3nt index e5752ad38e..b6a9a3fb06 100644 --- a/src/ChezScheme/s/Mf-i3nt +++ b/src/ChezScheme/s/Mf-i3nt @@ -13,7 +13,6 @@ # See the License for the specific language governing permissions and # limitations under the License. -m ?= i3nt archincludes = x86.ss include Mf-base diff --git a/src/ChezScheme/s/Mf-i3ob b/src/ChezScheme/s/Mf-i3ob deleted file mode 100644 index a8d5612c6e..0000000000 --- a/src/ChezScheme/s/Mf-i3ob +++ /dev/null @@ -1,19 +0,0 @@ -# Mf-i3ob -# 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 ?= i3ob -archincludes = x86.ss - -include Mf-base diff --git a/src/ChezScheme/s/Mf-i3osx b/src/ChezScheme/s/Mf-i3osx deleted file mode 100644 index d97028f7b6..0000000000 --- a/src/ChezScheme/s/Mf-i3osx +++ /dev/null @@ -1,19 +0,0 @@ -# Mf-i3osx -# 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 ?= i3osx -archincludes = x86.ss - -include Mf-base diff --git a/src/ChezScheme/s/Mf-i3qnx b/src/ChezScheme/s/Mf-i3qnx deleted file mode 100644 index dc4c6b0336..0000000000 --- a/src/ChezScheme/s/Mf-i3qnx +++ /dev/null @@ -1,19 +0,0 @@ -# Mf-i3qnx -# 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 = i3qnx -archincludes = x86.ss - -include Mf-base diff --git a/src/ChezScheme/s/Mf-i3s2 b/src/ChezScheme/s/Mf-i3s2 deleted file mode 100644 index 96c5857831..0000000000 --- a/src/ChezScheme/s/Mf-i3s2 +++ /dev/null @@ -1,19 +0,0 @@ -# Mf-i3s2 -# 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 ?= i3s2 -archincludes = x86.ss - -include Mf-base diff --git a/src/ChezScheme/s/Mf-pb b/src/ChezScheme/s/Mf-pb deleted file mode 100644 index 30286f9635..0000000000 --- a/src/ChezScheme/s/Mf-pb +++ /dev/null @@ -1,6 +0,0 @@ -# Mf-pb - -m = pb -archincludes = pb.ss - -include Mf-base diff --git a/src/ChezScheme/s/Mf-ppc32le b/src/ChezScheme/s/Mf-ppc32le deleted file mode 100644 index 95f0b5551b..0000000000 --- a/src/ChezScheme/s/Mf-ppc32le +++ /dev/null @@ -1,21 +0,0 @@ -# Mf-ppc32le -# 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 ?= ppc32le -archincludes = ppc32.ss - -include Mf-base - -machine.def: ppc32.def diff --git a/src/ChezScheme/s/Mf-ppc32osx b/src/ChezScheme/s/Mf-ppc32osx deleted file mode 100644 index 90e504a865..0000000000 --- a/src/ChezScheme/s/Mf-ppc32osx +++ /dev/null @@ -1,6 +0,0 @@ -# Mf-ppc32osx - -m ?= ppc32osx -archincludes = ppc32.ss - -include Mf-base diff --git a/src/ChezScheme/s/Mf-ta6fb b/src/ChezScheme/s/Mf-ta6fb deleted file mode 100644 index 8987a6a1dd..0000000000 --- a/src/ChezScheme/s/Mf-ta6fb +++ /dev/null @@ -1,18 +0,0 @@ -# Mf-ta6fb -# 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 = ta6fb - -include Mf-a6fb diff --git a/src/ChezScheme/s/Mf-ta6le b/src/ChezScheme/s/Mf-ta6le deleted file mode 100644 index d213041e53..0000000000 --- a/src/ChezScheme/s/Mf-ta6le +++ /dev/null @@ -1,18 +0,0 @@ -# Mf-ta6le -# 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 = ta6le - -include Mf-a6le diff --git a/src/ChezScheme/s/Mf-ta6nb b/src/ChezScheme/s/Mf-ta6nb deleted file mode 100644 index 51bc03527e..0000000000 --- a/src/ChezScheme/s/Mf-ta6nb +++ /dev/null @@ -1,18 +0,0 @@ -# Mf-ta6nb -# 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 = ta6nb - -include Mf-a6nb diff --git a/src/ChezScheme/s/Mf-ta6nt b/src/ChezScheme/s/Mf-ta6nt index 3bc5e1dfb0..72190feed7 100644 --- a/src/ChezScheme/s/Mf-ta6nt +++ b/src/ChezScheme/s/Mf-ta6nt @@ -13,6 +13,5 @@ # See the License for the specific language governing permissions and # limitations under the License. -m = ta6nt include Mf-a6nt diff --git a/src/ChezScheme/s/Mf-ta6ob b/src/ChezScheme/s/Mf-ta6ob deleted file mode 100644 index 9a36fab922..0000000000 --- a/src/ChezScheme/s/Mf-ta6ob +++ /dev/null @@ -1,18 +0,0 @@ -# Mf-ta6ob -# 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 = ta6ob - -include Mf-a6ob diff --git a/src/ChezScheme/s/Mf-ta6osx b/src/ChezScheme/s/Mf-ta6osx deleted file mode 100644 index 5bf0f22875..0000000000 --- a/src/ChezScheme/s/Mf-ta6osx +++ /dev/null @@ -1,18 +0,0 @@ -# Mf-ta6osx -# 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 = ta6osx - -include Mf-a6osx diff --git a/src/ChezScheme/s/Mf-ta6s2 b/src/ChezScheme/s/Mf-ta6s2 deleted file mode 100644 index 9351d8e0a1..0000000000 --- a/src/ChezScheme/s/Mf-ta6s2 +++ /dev/null @@ -1,18 +0,0 @@ -# Mf-ta6s2 -# 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 = ta6s2 - -include Mf-a6s2 diff --git a/src/ChezScheme/s/Mf-tarm32le b/src/ChezScheme/s/Mf-tarm32le deleted file mode 100644 index e3d9797bfd..0000000000 --- a/src/ChezScheme/s/Mf-tarm32le +++ /dev/null @@ -1,18 +0,0 @@ -# Mf-tarm32le -# 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 = tarm32le - -include Mf-arm32le diff --git a/src/ChezScheme/s/Mf-tarm64le b/src/ChezScheme/s/Mf-tarm64le deleted file mode 100644 index c2bf17db01..0000000000 --- a/src/ChezScheme/s/Mf-tarm64le +++ /dev/null @@ -1,18 +0,0 @@ -# Mf-tarm64le -# 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 = tarm64le - -include Mf-arm64le diff --git a/src/ChezScheme/s/Mf-tarm64osx b/src/ChezScheme/s/Mf-tarm64osx deleted file mode 100644 index 09f0a2a416..0000000000 --- a/src/ChezScheme/s/Mf-tarm64osx +++ /dev/null @@ -1,18 +0,0 @@ -# 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-ti3fb b/src/ChezScheme/s/Mf-ti3fb deleted file mode 100644 index 1b12d2b83e..0000000000 --- a/src/ChezScheme/s/Mf-ti3fb +++ /dev/null @@ -1,19 +0,0 @@ -# Mf-ti3fb -# 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 = ti3fb -archincludes = x86.ss - -include Mf-base diff --git a/src/ChezScheme/s/Mf-ti3le b/src/ChezScheme/s/Mf-ti3le deleted file mode 100644 index 679073e261..0000000000 --- a/src/ChezScheme/s/Mf-ti3le +++ /dev/null @@ -1,19 +0,0 @@ -# Mf-ti3le -# 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 = ti3le -archincludes = x86.ss - -include Mf-base diff --git a/src/ChezScheme/s/Mf-ti3nb b/src/ChezScheme/s/Mf-ti3nb deleted file mode 100644 index 2f039aa3c6..0000000000 --- a/src/ChezScheme/s/Mf-ti3nb +++ /dev/null @@ -1,19 +0,0 @@ -# Mf-ti3nb -# 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 = ti3nb -archincludes = x86.ss - -include Mf-base diff --git a/src/ChezScheme/s/Mf-ti3nt b/src/ChezScheme/s/Mf-ti3nt index 83c9fbe8b3..f01a36d526 100644 --- a/src/ChezScheme/s/Mf-ti3nt +++ b/src/ChezScheme/s/Mf-ti3nt @@ -13,6 +13,5 @@ # See the License for the specific language governing permissions and # limitations under the License. -m = ti3nt include Mf-i3nt diff --git a/src/ChezScheme/s/Mf-ti3ob b/src/ChezScheme/s/Mf-ti3ob deleted file mode 100644 index b1cbc111c5..0000000000 --- a/src/ChezScheme/s/Mf-ti3ob +++ /dev/null @@ -1,19 +0,0 @@ -# Mf-ti3ob -# 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 = ti3ob -archincludes = x86.ss - -include Mf-base diff --git a/src/ChezScheme/s/Mf-ti3osx b/src/ChezScheme/s/Mf-ti3osx deleted file mode 100644 index a83bd3feb0..0000000000 --- a/src/ChezScheme/s/Mf-ti3osx +++ /dev/null @@ -1,18 +0,0 @@ -# Mf-ti3osx -# 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 = ti3osx - -include Mf-i3osx diff --git a/src/ChezScheme/s/Mf-ti3s2 b/src/ChezScheme/s/Mf-ti3s2 deleted file mode 100644 index 857ca569bb..0000000000 --- a/src/ChezScheme/s/Mf-ti3s2 +++ /dev/null @@ -1,19 +0,0 @@ -# Mf-ti3s2 -# 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 = ti3s2 -archincludes = x86.ss - -include Mf-base diff --git a/src/ChezScheme/s/Mf-tppc32le b/src/ChezScheme/s/Mf-tppc32le deleted file mode 100644 index b1d4949922..0000000000 --- a/src/ChezScheme/s/Mf-tppc32le +++ /dev/null @@ -1,18 +0,0 @@ -# Mf-tppc32le -# 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 = tppc32le - -include Mf-ppc32le diff --git a/src/ChezScheme/s/Mf-tppc32osx b/src/ChezScheme/s/Mf-tppc32osx deleted file mode 100644 index 56b001c5d7..0000000000 --- a/src/ChezScheme/s/Mf-tppc32osx +++ /dev/null @@ -1,5 +0,0 @@ -# Mf-tppc32osx - -m = tppc32osx - -include Mf-ppc32osx diff --git a/src/ChezScheme/s/Mf-unix b/src/ChezScheme/s/Mf-unix new file mode 100644 index 0000000000..45ab80e6dd --- /dev/null +++ b/src/ChezScheme/s/Mf-unix @@ -0,0 +1 @@ +include Mf-base diff --git a/src/ChezScheme/s/a6fb.def b/src/ChezScheme/s/a6fb.def deleted file mode 100644 index 9ffa57618c..0000000000 --- a/src/ChezScheme/s/a6fb.def +++ /dev/null @@ -1,19 +0,0 @@ -;;; a6fb.def -;;; 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. - -(define-constant machine-type (constant machine-type-a6fb)) -(features iconv expeditor) -(include "a6.def") -(include "default.def") diff --git a/src/ChezScheme/s/a6le.def b/src/ChezScheme/s/a6le.def deleted file mode 100644 index 0582d9a088..0000000000 --- a/src/ChezScheme/s/a6le.def +++ /dev/null @@ -1,19 +0,0 @@ -;;; a6le.def -;;; 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. - -(define-constant machine-type (constant machine-type-a6le)) -(features iconv expeditor) -(include "a6.def") -(include "default.def") diff --git a/src/ChezScheme/s/a6nb.def b/src/ChezScheme/s/a6nb.def deleted file mode 100644 index ed48fcbcf1..0000000000 --- a/src/ChezScheme/s/a6nb.def +++ /dev/null @@ -1,19 +0,0 @@ -;;; a6nb.def -;;; 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. - -(define-constant machine-type (constant machine-type-a6nb)) -(features iconv expeditor) -(include "a6.def") -(include "default.def") diff --git a/src/ChezScheme/s/a6ob.def b/src/ChezScheme/s/a6ob.def deleted file mode 100644 index 98d86057e5..0000000000 --- a/src/ChezScheme/s/a6ob.def +++ /dev/null @@ -1,19 +0,0 @@ -;;; a6ob.def -;;; 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. - -(define-constant machine-type (constant machine-type-a6ob)) -(features iconv expeditor) -(include "a6.def") -(include "default.def") diff --git a/src/ChezScheme/s/a6osx.def b/src/ChezScheme/s/a6osx.def deleted file mode 100644 index c447683c78..0000000000 --- a/src/ChezScheme/s/a6osx.def +++ /dev/null @@ -1,19 +0,0 @@ -;;; a6osx.def -;;; 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. - -(define-constant machine-type (constant machine-type-a6osx)) -(features iconv expeditor) -(include "a6.def") -(include "default.def") diff --git a/src/ChezScheme/s/a6s2.def b/src/ChezScheme/s/a6s2.def deleted file mode 100644 index 2b8ccb6919..0000000000 --- a/src/ChezScheme/s/a6s2.def +++ /dev/null @@ -1,19 +0,0 @@ -;;; a6s2.def -;;; 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. - -(define-constant machine-type (constant machine-type-a6s2)) -(features iconv expeditor) -(include "a6.def") -(include "default.def") diff --git a/src/ChezScheme/s/arm32.ss b/src/ChezScheme/s/arm32.ss index fc719ac739..29758bc9f2 100644 --- a/src/ChezScheme/s/arm32.ss +++ b/src/ChezScheme/s/arm32.ss @@ -748,12 +748,20 @@ (with-output-language (L15d Effect) (define add-offset (lambda (r) - (if (eqv? (nanopass-case (L15d Triv) w [(immediate ,imm) imm]) 0) - (k r) - (let ([u (make-tmp 'u)]) - (seq + (let ([i (nanopass-case (L15d Triv) w [(immediate ,imm) imm])]) + (cond + [(eqv? i 0) (k r)] + [(funky12 i) + (let ([u (make-tmp 'u)]) + (seq `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,r ,w)) - (k u)))))) + (k u)))] + [else + (let ([u (make-tmp 'u)]) + (seq + `(set! ,(make-live-info) ,u ,w) + `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,r ,u)) + (k u)))])))) (if (eq? y %zero) (add-offset x) (let ([u (make-tmp 'u)]) @@ -762,7 +770,7 @@ (add-offset u))))))) ; NB: compiler ipmlements init-lock! and unlock! as 32-bit store of zero (define-instruction pred (lock!) - [(op (x ur) (y ur) (w funky12)) + [(op (x ur) (y ur) (w imm-constant)) (let ([u (make-tmp 'u)] [u2 (make-tmp 'u2)]) (values @@ -775,7 +783,7 @@ `(asm ,null-info ,asm-lock ,r ,u ,u2))))) `(asm ,info-cc-eq ,asm-eq ,u (immediate 0))))]) (define-instruction effect (locked-incr! locked-decr!) - [(op (x ur) (y ur) (w funky12)) + [(op (x ur) (y ur) (w imm-constant)) (lea->reg x y w (lambda (r) (let ([u1 (make-tmp 'u1)] [u2 (make-tmp 'u2)]) @@ -784,7 +792,7 @@ `(set! ,(make-live-info) ,u2 (asm ,null-info ,asm-kill)) `(asm ,null-info ,(asm-lock+/- op) ,r ,u1 ,u2)))))]) (define-instruction effect (cas) - [(op (x ur) (y ur) (w funky12) (old ur) (new ur)) + [(op (x ur) (y ur) (w imm-constant) (old ur) (new ur)) (lea->reg x y w (lambda (r) (let ([u1 (make-tmp 'u1)] [u2 (make-tmp 'u2)]) diff --git a/src/ChezScheme/s/arm32le.def b/src/ChezScheme/s/arm32le.def deleted file mode 100644 index eb4a036c6e..0000000000 --- a/src/ChezScheme/s/arm32le.def +++ /dev/null @@ -1,19 +0,0 @@ -;;; arm32le.def -;;; 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. - -(define-constant machine-type (constant machine-type-arm32le)) -(features iconv expeditor) -(include "arm32.def") -(include "default.def") diff --git a/src/ChezScheme/s/arm64.ss b/src/ChezScheme/s/arm64.ss index 831df49e53..c94c597bbc 100644 --- a/src/ChezScheme/s/arm64.ss +++ b/src/ChezScheme/s/arm64.ss @@ -33,7 +33,7 @@ [ %r1 %Carg2 #f 1 uptr] [ %r2 %Carg3 %reify1 #f 2 uptr] [ %r3 %Carg4 %reify2 #f 3 uptr] - [ %r4 %Carg5 #f 4 uptr] + [ %r4 %Carg5 %save1 #f 4 uptr] [ %r5 %Carg6 #f 5 uptr] [ %r6 %Carg7 #f 6 uptr] [ %r7 %Carg8 #f 7 uptr] @@ -600,12 +600,20 @@ (with-output-language (L15d Effect) (define add-offset (lambda (r) - (if (eqv? (nanopass-case (L15d Triv) w [(immediate ,imm) imm]) 0) - (k r) - (let ([u (make-tmp 'u)]) - (seq + (let ([i (nanopass-case (L15d Triv) w [(immediate ,imm) imm])]) + (cond + [(eqv? i 0) (k r)] + [(unsigned12? i) + (let ([u (make-tmp 'u)]) + (seq `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,r ,w)) - (k u)))))) + (k u)))] + [else + (let ([u (make-tmp 'u)]) + (seq + `(set! ,(make-live-info) ,u ,w) + `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,r ,u)) + (k u)))])))) (if (eq? y %zero) (add-offset x) (let ([u (make-tmp 'u)]) @@ -614,7 +622,7 @@ (add-offset u))))))) ;; NB: compiler implements init-lock! and unlock! as word store of zero (define-instruction pred (lock!) - [(op (x ur) (y ur) (w unsigned12)) + [(op (x ur) (y ur) (w imm-constant)) (let ([u (make-tmp 'u)] [u2 (make-tmp 'u2)]) (values @@ -627,7 +635,7 @@ `(asm ,null-info ,asm-lock ,r ,u ,u2))))) `(asm ,info-cc-eq ,asm-eq ,u (immediate 0))))]) (define-instruction effect (locked-incr! locked-decr!) - [(op (x ur) (y ur) (w unsigned12)) + [(op (x ur) (y ur) (w imm-constant)) (lea->reg x y w (lambda (r) (let ([u1 (make-tmp 'u1)] [u2 (make-tmp 'u2)]) @@ -636,7 +644,7 @@ `(set! ,(make-live-info) ,u2 (asm ,null-info ,asm-kill)) `(asm ,null-info ,(asm-lock+/- op) ,r ,u1 ,u2)))))]) (define-instruction effect (cas) - [(op (x ur) (y ur) (w unsigned12) (old ur) (new ur)) + [(op (x ur) (y ur) (w imm-constant) (old ur) (new ur)) (lea->reg x y w (lambda (r) (let ([u1 (make-tmp 'u1)] [u2 (make-tmp 'u2)]) @@ -2408,10 +2416,10 @@ (or (andmap double-member? members) (andmap float-member? members)))))] [else #f])) - (define int-argument-regs (lambda () (list %Carg1 %Carg2 %Carg3 %Carg4 - %Carg5 %Carg6 %Carg7 %Carg8))) - (define fp-argument-regs (lambda () (list %Cfparg1 %Cfparg2 %Cfparg3 %Cfparg4 - %Cfparg5 %Cfparg6 %Cfparg7 %Cfparg8))) + (define int-argument-regs (list %Carg1 %Carg2 %Carg3 %Carg4 + %Carg5 %Carg6 %Carg7 %Carg8)) + (define fp-argument-regs (list %Cfparg1 %Cfparg2 %Cfparg3 %Cfparg4 + %Cfparg5 %Cfparg6 %Cfparg7 %Cfparg8)) (define save-and-restore (lambda (regs e) (safe-assert (andmap reg? regs)) @@ -2499,7 +2507,7 @@ (define categorize-arguments (lambda (types varargs-after) - (let loop ([types types] [int* (int-argument-regs)] [fp* (fp-argument-regs)] + (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 diff --git a/src/ChezScheme/s/arm64le.def b/src/ChezScheme/s/arm64le.def deleted file mode 100644 index 910081655b..0000000000 --- a/src/ChezScheme/s/arm64le.def +++ /dev/null @@ -1,6 +0,0 @@ -;;; arm64le.def - -(define-constant machine-type (constant machine-type-arm64le)) -(features iconv expeditor) -(include "arm64.def") -(include "default.def") diff --git a/src/ChezScheme/s/cmacros.ss b/src/ChezScheme/s/cmacros.ss index 7337af659f..f7cdeb2d05 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 #x0905033A) +(define-constant scheme-version #x09050505) (define-syntax define-machine-types (lambda (x) @@ -396,6 +396,15 @@ arm64le tarm64le arm64osx tarm64osx ppc32osx tppc32osx + arm32fb tarm32fb + ppc32fb tppc32fb + arm64fb tarm64fb + arm32ob tarm32ob + ppc32ob tppc32ob + arm64ob tarm64ob + arm32nb tarm32nb + ppc32nb tppc32nb + arm64nb tarm64nb ) (include "machine.def") @@ -731,23 +740,25 @@ (impure "impure" #\i 1) ; most mutable objects allocated here (all ptrs) (symbol "symbol" #\x 2) ; (port "port" #\q 3) ; - (weakpair "weakpr" #\w 4) ; - (ephemeron "emph" #\e 5) ; - (pure "pure" #\p 6) ; swept immutable objects allocated here (all ptrs) - (continuation "cont" #\k 7) ; - (code "code" #\c 8) ; - (pure-typed-object "p-tobj" #\r 9) ; - (impure-record "ip-rec" #\s 10) ; - (impure-typed-object "ip-tobj" #\t 11) ; as needed (instead of impure) for backtraces - (closure "closure" #\l 12) ; as needed (instead of pure/impure) for backtraces - (immobile-impure "im-impure" #\I 13) ; like impure, but for immobile objects - (count-pure "cnt-pure" #\y 14) ; like pure, but delayed for counting from roots - (count-impure "cnt-impure" #\z 15)); like impure-typed-object, but delayed for counting from roots + (pure "pure" #\p 4) ; swept immutable objects allocated here (all ptrs) + (continuation "cont" #\k 5) ; + (code "code" #\c 6) ; + (pure-typed-object "p-tobj" #\r 7) ; + (impure-record "ip-rec" #\s 8) ; + (impure-typed-object "ip-tobj" #\t 9) ; as needed (instead of impure) for backtraces + (closure "closure" #\l 10) ; as needed (instead of pure/impure) for backtraces + (immobile-impure "im-impure" #\I 11) ; like impure, but for immobile objects + (count-pure "cnt-pure" #\y 12) ; like pure, but delayed for counting from roots + (count-impure "cnt-impure" #\z 13) ; like impure-typed-object, but delayed for counting from roots + ;; spaces that can hold pairs for sweeping: + (weakpair "weakpr" #\w 14) ; must be ordered as first special space for pairs + (ephemeron "emph" #\e 15) ; + (reference-array "ref-array" #\a 16)) ; reference bytevectors (unswept - (data "data" #\d 16) ; unswept objects allocated here - (immobile-data "im-data" #\D 17))) ; like data, but non-moving + (data "data" #\d 17) ; unswept objects allocated here + (immobile-data "im-data" #\D 18))) ; like data, but non-moving (unreal - (empty "empty" #\e 18))) ; available segments + (empty "empty" #\e 19))) ; available segments ;;; enumeration of types for which gc tracks object counts ;;; also update gc.c @@ -798,6 +809,10 @@ (define-constant type-immediate #b110) (define-constant type-typed-object #b111) +;; Applying this type tag to an address shouldproduce a pointer +;; that's equal to the address: +(define-constant type-untyped (constant typemod)) + ;; --------------------------------------------------------------------- ;; Immediate values; note that these all end with `type-immediate`: @@ -854,7 +869,7 @@ (define-constant type-exactnum #b01010110) (define-constant type-box #b0001110) ; bit 3 set for non-numbers (define-constant type-immutable-box #b10001110) ; low 7 bits match `type-box` -(define-constant type-stencil-vector #b011110) ; remianing bits for stencil; type looks like immediate +(define-constant type-stencil-vector #b011110) ; remaining bits for mask; type looks like immediate ; #b00101110 (forward_marker) must not be used (define-constant type-code #b00111110) (define-constant type-port #b11001110) @@ -1294,6 +1309,9 @@ [else x]))]))) ) +;; This is the same as `record-type-disp`, but helps bootstrap: +(define-constant record-ptr-offset (- (constant typemod) (constant type-record))) + (define-syntax define-primitive-structure-disps (lambda (x) (include "layout.ss") @@ -1439,6 +1457,8 @@ ([iptr type] [octet data 0]))]) +(define-constant reference-disp (constant bytevector-data-disp)) + (define-primitive-structure-disps stencil-vector type-typed-object ([iptr type] [ptr data 0])) @@ -1502,7 +1522,7 @@ [ptr pinfo*] [octet data 0])) -(define-primitive-structure-disps reloc-table typemod +(define-primitive-structure-disps reloc-table type-untyped ([iptr size] [ptr code] [uptr data 0])) @@ -1529,7 +1549,7 @@ (define-constant maximum-parallel-collect-threads 16) ;;; make sure gc sweeps all ptrs -(define-primitive-structure-disps tc typemod +(define-primitive-structure-disps tc type-untyped ([xptr arg-regs (constant asm-arg-reg-max)] [xptr ac0] [xptr ac1] @@ -1545,6 +1565,7 @@ [xptr ts] [xptr td] [xptr real_eap] + [xptr save1] [ptr virtual-registers (constant virtual-register-count)] [ptr guardian-entries] [ptr cchain] @@ -1626,7 +1647,7 @@ (define-primitive-structure-disps record-type type-typed-object ([ptr type] - [ptr ancestry] ; vector: parent at 0, grandparent at 1, etc. + [ptr ancestry] ; (vector #f .... grandparent parent self) [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 @@ -1639,6 +1660,10 @@ (define-constant rtd-generative #b0001) (define-constant rtd-opaque #b0010) (define-constant rtd-sealed #b0100) +(define-constant rtd-act-sealed #b1000) + +(define-constant ancestry-parent-offset 2) +(define-constant minimum-ancestry-vector-length 2) ; we do this as a macro here since we want the freshest version possible ; in syntax.ss when we use it as a patch, whereas we want the old @@ -1664,7 +1689,7 @@ (+ b (constant ptr-bytes)) (cdr e*)))]))))))) -(define-primitive-structure-disps guardian-entry typemod +(define-primitive-structure-disps guardian-entry type-untyped ([ptr obj] [ptr rep] [ptr tconc] @@ -1679,15 +1704,15 @@ ;;; forwarding addresses are recorded with a single forward-marker ;;; bit pattern (a special Scheme object) followed by the forwarding ;;; address, a ptr to the forwarded object. -(define-primitive-structure-disps forward typemod +(define-primitive-structure-disps forward type-untyped ([ptr marker] [ptr address])) -(define-primitive-structure-disps cached-stack typemod +(define-primitive-structure-disps cached-stack type-untyped ([iptr size] [ptr link])) -(define-primitive-structure-disps rp-header typemod +(define-primitive-structure-disps rp-header type-untyped ([uptr toplink] [uptr mv-return-address] [ptr livemask] @@ -1701,7 +1726,7 @@ (define-constant return-address-livemask-disp (- (constant rp-header-livemask-disp) (constant size-rp-header))) -(define-primitive-structure-disps rp-compact-header typemod +(define-primitive-structure-disps rp-compact-header type-untyped ([uptr toplink] [iptr mask+size+mode])) ; low bit is 1 to distinguish from a `rp-header` ;; mask+size+mode: bit 0 is 1 [=> compact-header-mask] @@ -2192,6 +2217,11 @@ (define-constant time-collector-cpu 5) (define-constant time-collector-real 6) +(define-syntax fixmediate? + (lambda (stx) + (syntax-case stx () + [(_ e) #'(let ([v e]) (or (fixnum? v) ($immediate? v)))]))) + ;; --------------------------------------------------------------------- ;; vfasl @@ -2214,7 +2244,7 @@ (define-constant vspaces-offsets-count (- (constant vspaces-count) 1)) -(define-primitive-structure-disps vfasl-header typemod +(define-primitive-structure-disps vfasl-header type-untyped ([uptr data-size] [uptr table-size] @@ -3278,7 +3308,8 @@ [pb-adr] [pb-inc pb-argument-types] [pb-lock] - [pb-cas]) + [pb-cas] + [pb-link]) ; used by linker ;; Only foreign procedures that match specific prototypes are ;; supported, where each prototype must be handled in "pb.c" diff --git a/src/ChezScheme/s/compile.ss b/src/ChezScheme/s/compile.ss index e178ba9f3e..fcb73ed563 100644 --- a/src/ChezScheme/s/compile.ss +++ b/src/ChezScheme/s/compile.ss @@ -487,7 +487,7 @@ (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 x + ($fasl-start p t situation x a? (lambda (x p) (c-faslobj x t p a?))))) (define-record-type visit-chunk @@ -611,7 +611,8 @@ (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) x1 (lambda (x p) ($fasl-out x p t (constant annotation-all))))))))))) + ($fasl-start wpoop t (constant fasl-type-visit-revisit) x1 (constant annotation-all) + (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 @@ -622,7 +623,8 @@ (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) x1 (lambda (x p) ($fasl-out x p t (constant annotation-all))))))))) + ($fasl-start hostop t (constant fasl-type-visit-revisit) x1 (constant annotation-all) + (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? @@ -1248,7 +1250,7 @@ (lambda (node thunk) (build-primcall '$install-library/rt-code `(quote ,(library-node-uid node)) thunk))) - (define-pass patch : Lsrc (ir env) -> Lsrc () + (define-pass patch : Lsrc (ir env exts-table) -> Lsrc () (definitions (define with-initialized-ids (lambda (old-id* proc) @@ -1297,7 +1299,17 @@ [(letrec* ([,x* ,e*] ...) ,body) (with-initialized-ids x* (lambda (x*) - `(letrec* ([,x* ,(map Expr e*)] ...) ,(Expr body))))]) + `(letrec* ([,x* ,(map Expr e*)] ...) ,(Expr body))))] + [(cte-optimization-loc ,box ,e ,exts) + (define new-exts (or (hashtable-ref exts-table exts #f) + (let ([new-exts (map (lambda (p) + (let ([x (car p)]) + (cons (or (prelex-operand x) x) (cdr p)))) + exts)]) + (hashtable-set! exts-table exts new-exts) + new-exts))) + (let ([e (Expr e)]) + `(cte-optimization-loc ,box ,e ,new-exts))]) (CaseLambdaClause : CaseLambdaClause (ir) -> CaseLambdaClause () [(clause (,x* ...) ,interface ,body) (with-initialized-ids x* @@ -1365,7 +1377,8 @@ (nanopass-case (Lexpand Program) (program-node-ir program) [(program ,uid ,body) body]) node*) - (make-patch-env (list node*)))))) + (make-patch-env (list node*)) + (make-eq-hashtable))))) (define build-combined-library-ir (lambda (cluster*) @@ -1440,7 +1453,8 @@ ,body)) body cluster)) (build-void) cluster* cluster-idx*))))) - (make-patch-env cluster*))))) + (make-patch-env cluster*) + (make-eq-hashtable))))) (with-output-language (Lexpand Outer) (define add-recompile-info @@ -1605,7 +1619,8 @@ (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) x (lambda (x p) ($fasl-out x p t (constant annotation-all)))))))))))))) + ($fasl-start wpoop t (constant fasl-type-visit-revisit) x (constant annotation-all) + (lambda (x p) ($fasl-out x p t (constant annotation-all)))))))))))))) (define build-required-library-list (lambda (node* visit-lib*) @@ -2218,26 +2233,31 @@ [(in out) (unless (string? in) ($oops who "~s is not a string" in)) (unless (string? out) ($oops who "~s is not a string" out)) - ($maybe-compile-file who in out (compile-program-handler))] + ($maybe-compile-file who in out (compile-program-handler)) + (void)] [(in) (unless (string? in) ($oops who "~s is not a string" in)) (let-values ([(in out) (in&out in)]) - ($maybe-compile-file who in out (compile-program-handler)))])) + ($maybe-compile-file who in out (compile-program-handler))) + (void)])) (set-who! compile-to-file (rec compile-to-file (case-lambda - [(sexpr* out) (compile-to-file sexpr* out #f)] - [(sexpr* out sfd) + [(sexpr* out) (compile-to-file sexpr* out #f #f)] + [(sexpr* out sfd) (compile-to-file sexpr* out sfd #f)] + [(sexpr* out sfd force-host-out?) (unless (list? sexpr*) ($oops who "~s is not a proper list" sexpr*)) (unless (string? out) ($oops who "~s is not a string" out)) (when sfd (unless (source-file-descriptor? sfd) ($oops who "~s is not a source-file descriptor or #f" sfd))) + (unless (boolean? force-host-out?) ($oops who "~s is not a boolean" force-host-out?)) (let ([library? (and (= (length sexpr*) 1) (pair? (car sexpr*)) (eq? (caar sexpr*) 'library))] [program? (and (= (length sexpr*) 1) (pair? (car sexpr*)) (eq? (caar sexpr*) 'top-level-program))]) (define (go) (do-compile-to-file who out (and library? - (not (eq? (constant machine-type-name) (machine-type))) + (or force-host-out? + (not (eq? (constant machine-type-name) (machine-type)))) (format "~a.~s" (path-root out) (machine-type))) (constant machine-type-name) sfd diff --git a/src/ChezScheme/s/cp0.ss b/src/ChezScheme/s/cp0.ss index ad4548e885..0be771fed6 100644 --- a/src/ChezScheme/s/cp0.ss +++ b/src/ChezScheme/s/cp0.ss @@ -87,6 +87,9 @@ ;;; used to memoize pure?, etc. (define-threaded cp0-info-hashtable) + ;; use to preserve sharing with `exts` renaming + (define-threaded exts-table) + (module () (define-syntax define-cp0-param (syntax-rules () @@ -120,7 +123,8 @@ ; file for cross compilation, because the offsets may be incorrect (define rtd-flds (csv7:record-field-accessor #!base-rtd 'flds)) (define rtd-ancestors (csv7:record-field-accessor #!base-rtd 'ancestors)) - (define rtd-parent (lambda (x) (vector-ref (rtd-ancestors x) 0))) + (define rtd-parent (lambda (x) (let ([a (rtd-ancestors x)]) + (vector-ref a (fx- (vector-length a) (constant ancestry-parent-offset)))))) (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)) @@ -842,7 +846,7 @@ [(and (eq? ctxt 'ignored) (simple1? e2) ;; don't move e1 into a single-value ;; position unless that's ok - (single-valued? e1)) + (single-valued/inspect-ok? e1)) e1] [else (let ([e1 (nanopass-case (Lsrc Expr) e1 @@ -862,7 +866,7 @@ (define (safe-single-value e1) (if (or (fx= (optimize-level) 3) - (single-valued? e1)) + (single-valued/inspect-ok? e1)) e1 (build-primcall 3 '$value (list e1)))) @@ -910,7 +914,7 @@ (lambda (ctxt e) (context-case ctxt [(tail) - (if (single-valued-without-inspecting-continuation? e) + (if (single-valued? e) e (build-primcall 3 '$value (list e)))] ;; An 'effect, 'ignored, 'value, or 'test position will not @@ -990,7 +994,7 @@ (let loop ([exts exts]) (cond [(null? exts) #f] - [(eq? (prelex-name x) (prelex-name (caar exts))) + [(eq? (prelex-uname x) (prelex-uname (caar exts))) (cdar exts)] [else (loop (cdr exts))])))) (define (ids->do-clause ids) @@ -1070,7 +1074,7 @@ (module (pure? ivory? ivory1? simple? simple1? simple/profile? simple/profile1? boolean-valued? single-valued? single-valued single-valued-join single-valued-reduce? - single-valued-without-inspecting-continuation?) + single-valued/inspect-ok?) ;; The memoization table has, for each key, either a flags integer ;; or a pair of a flags integer and a value. The value corresponds to @@ -1098,8 +1102,9 @@ (car val) (let ([r (pred?)]) (let ([p (cdr a)]) - (unless (pair? p) - (set-cdr! a (cons r p)))) + ;; p may have been set meanwhile, but we want to update + ;; the cdr to handle joins around recursive calls + (set-cdr! a (cons r (if (pair? p) (cdr p) p)))) r)))))])) (define-syntax with-memoize @@ -1353,6 +1358,15 @@ (car e*))] [else #f])) + (define (extract-called-procedure/inspect-ok pr e*) + (case (primref-name pr) + [(call-setting-continuation-attachment + call-getting-continuation-attachment + call-consuming-continuation-attachment) + (and (fx= (length e*) 2) + (cadr e*))] + [else #f])) + (define-who boolean-valued? (lambda (e) (with-memoize (boolean-valued-known boolean-valued) e @@ -1397,8 +1411,9 @@ [(pariah) #f] [else ($oops who "unrecognized record ~s" e)])))) - ;; Returns #t, #f, or a prelex for a lambda that needs to be - ;; single-valued to imply #t. The prelex case is useful to + ;; Returns #t, #f, 'value/inspect (single-valued, but may + ;; inspect continuation), or a prelex for a lambda that needs to + ;; be single-valued to imply #t. The prelex case is useful to ;; detect a single-valued loop. (define-who single-valued (lambda (e) @@ -1415,9 +1430,15 @@ (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))))))] + (cond + [(extract-called-procedure pr e*) + => (lambda (proc-e) + (memoize (procedure-single-valued proc-e #f)))] + [(extract-called-procedure/inspect-ok pr e*) + => (lambda (proc-e) + (memoize (single-valued-join 'value/inspect + (procedure-single-valued proc-e #f))))] + [else #f])))] [(case-lambda ,preinfo ,cl* ...) (memoize (or (all-set? (constant code-flag-single-valued) @@ -1497,32 +1518,31 @@ [(eq? a b) a] [(eq? a #t) b] [(eq? b #t) a] + [(eq? a 'value/inspect) b] + [(eq? b 'value/inspect) a] ;; If `a` and `b` are different prelexes, we currently give ;; up, because a prelex is used only to find a ;; single-function fixpoint. [else #f]))) - (define-who single-valued? + (define-who single-valued/inspect-ok? (lambda (e) - (single-valued-reduce? (single-valued e)))) + (let ([r (single-valued e)]) + (or (eq? r 'value/inspect) ; i.e., ok to inspect continuation + (single-valued-reduce? r))))) (define single-valued-reduce? (lambda (r) (cond [(eq? r #t) #t] [(eq? r #f) #f] + [(eq? r 'value/inspect) #f] ;; conservative assumption for a prelex: [else #f]))) - (define-who single-valued-without-inspecting-continuation? + (define-who single-valued? (lambda (e) - ;; Single-valued and does not observe or affect the - ;; immediate continuation frame (so removing (an enclosing - ;; frame would be ok). This currently can be implemented as - ;; `single-valued?`, because `single-valued?` does not look - ;; into continuation-observing calls like `(call/cc (lambda - ;; (k) <body>))` to detect that `<body>` is single valued. - (single-valued? e)))) + (single-valued-reduce? (single-valued e))))) (define find-call-lambda-clause (lambda (exp opnds) @@ -2473,7 +2493,7 @@ [(call ,preinfo ,pr ,e* ...) (guard (eq? (primref-name pr) 'values)) e*] - [else (and (single-valued? e) + [else (and (single-valued/inspect-ok? e) (list e))]))) => (lambda (args) ; (with-values (values arg ...) c-temp) => (c-temp arg ...) @@ -2665,7 +2685,7 @@ [(null? val*) `(quote ,a)] [(eqv? a ident) (if (and (fx= level 3) (null? (cdr val*)) (direct-result? (car val*))) - (car val*) + (make-nontail (app-ctxt ctxt) (car val*)) (if (and (null? (cdr val*)) ;; `op` may require exactly 2 arguments (eqv? (procedure-arity-mask op) 4)) @@ -3936,19 +3956,19 @@ (begin (residualize-seq '() (list ?x) ctxt) false-rec))])))) - (define-inline 2 r6rs:record? - [(?x) (one-arg-case ?x ctxt)]) - (define-inline 2 record? - [(?x) (one-arg-case ?x ctxt)] - [(?x ?rtd) + (define two-arg-case + (lambda (?x ?rtd level ctxt needs-record?) (let ([rtdval (value-visit-operand! ?rtd)]) (define abandon-ship (lambda (xval xres maybe-rtd) (if (definitely-not-a-record? xres) - (begin - (residualize-seq '() (list ?x ?rtd) ctxt) - false-rec) + (cond + [needs-record? #f] + [else + (residualize-seq '() (list ?x ?rtd) ctxt) + false-rec]) (and maybe-rtd + (not needs-record?) (begin (residualize-seq (list ?x ?rtd) '() ctxt) (build-primcall (app-preinfo ctxt) 3 @@ -3993,7 +4013,9 @@ [(quote ,d1) ; could also return #f here and let folding happen (residualize-seq '() (list ?x ?rtd) ctxt) - (if (record? d1 d0) true-rec false-rec)] + (cond + [(and needs-record? (not (record? d1))) #f] + [else (if (record? d1 d0) true-rec false-rec)])] ; could handle record-type forms if ctrtd recorded rtdrtd (a ctrtd's rtd is always base-ctrtd) [(record ,rtd ,rtd-expr ,e* ...) (guard (let f ([rtd rtd]) @@ -4033,7 +4055,14 @@ [else (and (fx= level 3) (let ([xval (value-visit-operand! ?x)]) - (abandon-ship xval (result-exp/indirect-ref xval) #f)))]))])) + (abandon-ship xval (result-exp/indirect-ref xval) #f)))])))) + (define-inline 2 r6rs:record? + [(?x) (one-arg-case ?x ctxt)]) + (define-inline 2 record? + [(?x) (one-arg-case ?x ctxt)] + [(?x ?rtd) (two-arg-case ?x ?rtd level ctxt #f)]) + (define-inline 2 record-instance? + [(?x ?rtd) (two-arg-case ?x ?rtd level ctxt #t)])) (define-inline 2 csv7:record-type-field-names [(?rtd) @@ -5233,6 +5262,15 @@ (make-1seq* 'ignored (list e1 e3))] [else `(call ,preinfo ,pr ,e1 ,e2 ,e3)]))] + [(call ,preinfo ,pr ,e) + (guard (eq? (primref-name pr) '$fixmediate)) + (context-case ctxt + [(ignored) (cp0 e ctxt env sc wd name moi)] + [else + (let ([e (cp0 e 'value env sc wd name moi)]) + (nanopass-case (Lsrc Expr) e + [(quote ,d) e] + [else `(call ,preinfo ,pr ,e)]))])] [(call ,preinfo ,e ,e* ...) (let () (define lift-let @@ -5432,6 +5470,12 @@ [(moi) (if moi `(quote ,moi) ir)] [(pariah) ir] [(cte-optimization-loc ,box ,[cp0 : e ctxt env sc wd name moi -> e] ,exts) + (define new-exts (or (hashtable-ref exts-table exts #f) + (let ([new-exts (map (lambda (p) + (cons (lookup (car p) env) (cdr p))) + exts)]) + (hashtable-set! exts-table exts new-exts) + new-exts))) (when (enable-cross-library-optimization) (let () (define update-box! @@ -5452,7 +5496,7 @@ ;; than supported by the original, since only inlinable clauses ;; are kept (let ([new-cl* (fold-right (lambda (cl cl*) - (let ([cl (externally-inlinable cl exts)]) + (let ([cl (externally-inlinable cl new-exts)]) (if cl (cons cl cl*) cl*))) @@ -5461,7 +5505,7 @@ [sv? (andmap (lambda (cl) (nanopass-case (Lsrc CaseLambdaClause) cl [(clause (,x* ...) ,interface ,body) - (single-valued? body)])) + (single-valued/inspect-ok? body)])) cl*)]) (when (or (pair? new-cl*) sv?) (update-box! box (make-cte-info @@ -5470,7 +5514,7 @@ sv?))))] [else #f])))] [else (void)]))) - `(cte-optimization-loc ,box ,e ,exts)] + `(cte-optimization-loc ,box ,e ,new-exts)] [(cpvalid-defer ,e) (sorry! who "cpvalid leaked a cpvalid-defer form ~s" ir)] [(profile ,src) ir] [else ($oops who "unrecognized record ~s" ir)]) @@ -5484,7 +5528,8 @@ [(x ltbc?) (fluid-let ([likely-to-be-compiled? ltbc?] [opending-list '()] - [cp0-info-hashtable (make-weak-eq-hashtable)]) + [cp0-info-hashtable (make-weak-eq-hashtable)] + [exts-table (make-weak-eq-hashtable)]) (cp0 x 'tail empty-env (new-scorer) (new-watchdog) #f #f))])))) ; check to make sure all required handlers were seen, after expansion of the diff --git a/src/ChezScheme/s/cpletrec.ss b/src/ChezScheme/s/cpletrec.ss index 5b4cfb2055..070d052e1c 100644 --- a/src/ChezScheme/s/cpletrec.ss +++ b/src/ChezScheme/s/cpletrec.ss @@ -57,6 +57,9 @@ Handling letrec and letrec* (define rtd-flds (csv7:record-field-accessor #!base-rtd 'flds)) (define rtd-mpm (csv7:record-field-accessor #!base-rtd 'mpm)) + ;; use to preserve sharing with `exts` renaming + (define-threaded exts-table) + (define-pass lift-profile-forms : Lsrc (ir) -> Lsrc () (definitions (with-output-language (Lsrc Expr) @@ -388,7 +391,14 @@ Handling letrec and letrec* [(moi) (values ir #t)] [(pariah) (values ir #t)] [(cte-optimization-loc ,box ,[e pure?] ,exts) - (values `(cte-optimization-loc ,box ,e ,exts) pure?)] + (let ([new-exts (or (hashtable-ref exts-table exts #f) + (let ([new-exts (map (lambda (p) + (let ([x (car p)]) + (cons (or (prelex-operand x) x) (cdr p)))) + exts)]) + (hashtable-set! exts-table exts new-exts) + new-exts))]) + (values `(cte-optimization-loc ,box ,e ,new-exts) pure?))] [(profile ,src) (values ir #f)] [else (sorry! who "unhandled record ~s" ir)]) (CaseLambdaClause : CaseLambdaClause (ir) -> CaseLambdaClause () @@ -401,5 +411,6 @@ Handling letrec and letrec* (lambda (x) (let ([x (if (eq? ($compile-profile) 'source) (lift-profile-forms x) x)]) - (cpletrec x))) + (fluid-let ([exts-table (make-weak-eq-hashtable)]) + (cpletrec x)))) )) diff --git a/src/ChezScheme/s/cpnanopass.ss b/src/ChezScheme/s/cpnanopass.ss index cd7af1f5d7..ce99c1280a 100644 --- a/src/ChezScheme/s/cpnanopass.ss +++ b/src/ChezScheme/s/cpnanopass.ss @@ -14,6 +14,13 @@ ;;; limitations under the License. (let () + (define-syntax define-once + (syntax-rules () + [(_ id rhs) (define-once id (id) rhs)] + [(_ id (name . _) rhs) (define id (let ([v rhs]) + ($sputprop 'name 'once v) + v))])) + (include "np-languages.ss") (define track-dynamic-closure-counts ($make-thread-parameter #f (lambda (x) (and x #t)))) @@ -64,24 +71,6 @@ (syntax-rules (x) [(_ name) (set! name (let ([t name]) (trace-lambda name args (apply t args))))])) - (define-syntax architecture - (let ([fn (format "~a.ss" (constant architecture))]) - (with-source-path 'architecture fn - (lambda (fn) - (let* ([p ($open-file-input-port 'include fn)] - [sfd ($source-file-descriptor fn p)] - [p (transcoded-port p (current-transcoder))]) - (let ([do-read ($make-read p sfd 0)]) - (let* ([regs (do-read)] [inst (do-read)] [asm (do-read)]) - (when (eof-object? asm) ($oops #f "too few expressions in ~a" fn)) - (unless (eof-object? (do-read)) ($oops #f "too many expressions in ~a" fn)) - (close-input-port p) - (lambda (x) - (syntax-case x (registers instructions assembler) - [(k registers) (datum->syntax #'k regs)] - [(k instructions) (datum->syntax #'k inst)] - [(k assembler) (datum->syntax #'k asm)]))))))))) - ; version in cmacros uses keyword as template and should ; probably be changed to use the id (define-syntax define-who @@ -481,157 +470,9 @@ [(and (eq? l full-tree) (eq? r full-tree)) full-tree] [else (make-tree-node l r)]))))])))) - (define-syntax tc-disp - (lambda (x) - (syntax-case x () - [(_ name) - (case (datum name) - [(%ac0) (constant tc-ac0-disp)] - [(%ac1) (constant tc-ac1-disp)] - [(%sfp) (constant tc-sfp-disp)] - [(%cp) (constant tc-cp-disp)] - [(%esp) (constant tc-esp-disp)] - [(%ap) (constant tc-ap-disp)] - [(%eap) (constant tc-eap-disp)] - [(%trap) (constant tc-trap-disp)] - [(%xp) (constant tc-xp-disp)] - [(%yp) (constant tc-yp-disp)] - [else #f])]))) - - (define-syntax define-reserved-registers - (lambda (x) - (syntax-case x () - [(_ [regid alias ... callee-save? mdinfo type] ...) - (syntax-case #'(regid ...) (%tc %sfp) [(%tc %sfp . others) #t] [_ #f]) - #'(begin - (begin - (define regid (make-reg 'regid 'mdinfo (tc-disp regid) callee-save? 'type)) - (module (alias ...) (define x regid) (define alias x) ...)) - ...)]))) - - (define-syntax define-allocable-registers - (lambda (x) - (assert (fx<= (constant asm-arg-reg-cnt) (constant asm-arg-reg-max))) - (syntax-case x () - [(_ regvec arg-registers extra-registers extra-fpregisters with-initialized-registers - [regid reg-alias ... callee-save? mdinfo type] ...) - (with-syntax ([((tc-disp ...) (arg-regid ...) (extra-regid ...) (extra-fpregid ...)) - (syntax-case #'([regid type] ...) (%ac0 %xp %ts %td uptr) - [([%ac0 _] [%xp _] [%ts _] [%td _] [other other-type] ...) - (let f ([other* #'(other ...)] - [other-type* #'(other-type ...)] - [rtc-disp* '()] - [arg-offset (constant tc-arg-regs-disp)] - [fp-offset (constant tc-fpregs-disp)] - [rextra* '()] - [rfpextra* '()]) - (if (null? other*) - (cond - [(not (fx= (length rextra*) (constant asm-arg-reg-max))) - (syntax-error x (format "asm-arg-reg-max extra registers are not specified ~s" (syntax->datum rextra*)))] - [(not (fx= (length rfpextra*) (constant asm-fpreg-max))) - (syntax-error x (format "asm-fpreg-max extra registers are not specified ~s" (syntax->datum rfpextra*)))] - [else - (let ([extra* (reverse rextra*)] - [fpextra* (reverse rfpextra*)]) - (list - (list* - (constant tc-ac0-disp) - (constant tc-xp-disp) - (constant tc-ts-disp) - (constant tc-td-disp) - (reverse rtc-disp*)) - (list-head extra* (constant asm-arg-reg-cnt)) - (list-tail extra* (constant asm-arg-reg-cnt)) - fpextra*))]) - (let ([other (car other*)]) - (if (memq (syntax->datum other) '(%ac1 %yp %cp %ret)) - (f (cdr other*) (cdr other-type*) (cons #`(tc-disp #,other) rtc-disp*) - 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 (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")])] - [(regid-loc ...) (generate-temporaries #'(regid ...))]) - #'(begin - (define-syntax define-squawking-parameter - (syntax-rules () - [(_ (id (... ...)) loc) - (begin - (define loc ($make-thread-parameter #f)) - (define-syntax id - (lambda (q) - (unless (identifier? q) (syntax-error q)) - #`(let ([x (loc)]) - (unless x (syntax-error #'#,q "uninitialized")) - x))) - (... ...))] - [(_ id loc) (define-squawking-parameter (id) loc)])) - (define-squawking-parameter (regid reg-alias ...) regid-loc) - ... - (define-squawking-parameter regvec regvec-loc) - (define-squawking-parameter arg-registers arg-registers-loc) - (define-squawking-parameter extra-registers extra-registers-loc) - (define-squawking-parameter extra-fpregisters extra-fpregisters-loc) - (define-syntax with-initialized-registers - (syntax-rules () - [(_ b1 b2 (... ...)) - (parameterize ([regid-loc (make-reg 'regid 'mdinfo tc-disp callee-save? 'type)] ...) - (parameterize ([regvec-loc (vector regid ...)] - [arg-registers-loc (list arg-regid ...)] - [extra-registers-loc (list extra-regid ...)] - [extra-fpregisters-loc (list extra-fpregid ...)]) - (let () b1 b2 (... ...))))]))))]))) - - (define-syntax define-machine-dependent-registers - (lambda (x) - (syntax-case x () - [(_ [regid alias ... callee-save? mdinfo type] ...) - #'(begin - (begin - (define regid (make-reg 'regid 'mdinfo #f callee-save? 'type)) - (module (alias ...) (define x regid) (define alias x) ...)) - ...)]))) - - (define-syntax define-registers - (lambda (x) - (syntax-case x (reserved allocable machine-dependent) - [(k (reserved [rreg rreg-alias ... rreg-callee-save? rreg-mdinfo rreg-type] ...) - (allocable [areg areg-alias ... areg-callee-save? areg-mdinfo areg-type] ...) - (machine-depdendent [mdreg mdreg-alias ... mdreg-callee-save? mdreg-mdinfo mdreg-type] ...)) - (with-implicit (k regvec arg-registers extra-registers extra-fpregisters real-register? with-initialized-registers) - #`(begin - (define-reserved-registers [rreg rreg-alias ... rreg-callee-save? rreg-mdinfo rreg-type] ...) - (define-allocable-registers regvec arg-registers extra-registers extra-fpregisters with-initialized-registers - [areg areg-alias ... areg-callee-save? areg-mdinfo areg-type] ...) - (define-machine-dependent-registers [mdreg mdreg-alias ... mdreg-callee-save? mdreg-mdinfo mdreg-type] ...) - (define-syntax real-register? - (with-syntax ([real-reg* #''(rreg ... rreg-alias ... ... areg ... areg-alias ... ... mdreg ... mdreg-alias ... ...)]) - (syntax-rules () - [(_ e) (memq e real-reg*)])))))]))) - - (architecture registers) - - ; pseudo register used for mref's with no actual index - (define %zero (make-reg 'zero #f #f #f #f)) - - ;; define %ref-ret to be sfp[0] on machines w/no ret register - ;; - ;; The ret register, if any, is used to pass a return address to a - ;; function. All functions currently stash the ret register in - ;; sfp[0] and return to sfp[0] instead of the ret register, so the - ;; register doesn't have to be saved and restored for non-tail - ;; calls --- so use sfp[0] instead of the ret registerr to refer - ;; to the current call's return address. (A leaf procedure could - ;; do better, but doesn't currently.) - (define-syntax %ref-ret - (lambda (x) - (meta-cond - [(real-register? '%ret) #'%ret] - [else (with-syntax ([%mref (datum->syntax x '%mref)]) - #'(%mref ,%sfp 0))]))) + ;; Defines the `architecture` macro and registers defined for the + ;; target architecture: + (include "np-register.ss") (define make-Ldoargerr (lambda () @@ -706,34 +547,6 @@ (and (not (eq? (fv-type fv) 'reserved)) (compatible-var-types? (fv-type fv) type)))) - (define-syntax reg-cons* - (lambda (x) - (syntax-case x () - [(_ ?reg ... ?reg*) - (fold-right - (lambda (reg reg*) - (cond - [(real-register? (syntax->datum reg)) - #`(cons #,reg #,reg*)] - [else reg*])) - #'?reg* #'(?reg ...))]))) - - (define-syntax reg-list - (syntax-rules () - [(_ ?reg ...) (reg-cons* ?reg ... '())])) - - (define-syntax with-saved-ret-reg - (lambda (x) - (syntax-case x () - [(k ?e) - (if (real-register? '%ret) - (with-implicit (k %seq %mref) - #'(%seq - (set! ,(%mref ,%sfp 0) ,%ret) - ,?e - (set! ,%ret ,(%mref ,%sfp 0)))) - #'?e)]))) - (module (restore-scheme-state save-scheme-state with-saved-scheme-state) (define-syntax build-reg-list ; TODO: create reg records at compile time, and build these lists at compile time @@ -838,252 +651,15 @@ (loop (fx+ i 1)) (cons reg (loop (fx+ i 1)))))])))) - (define-record-type ctci ; compile-time version of code-info - (nongenerative) - (sealed #t) - (fields (mutable live) (mutable rpi*) (mutable closure-fv-names)) - (protocol - (lambda (new) - (lambda () - (new #f '() #f))))) - - (define-record-type ctrpi ; compile-time version of rp-info - (nongenerative) - (sealed #t) - (fields label src sexpr mask)) - (define-threaded next-lambda-seqno) - - (define-record-type info-lambda (nongenerative) - (parent info) - (sealed #t) - (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) - (define next-seqno + (module () + (set! $np-next-lambda-seqno (lambda () (let ([seqno next-lambda-seqno]) (set! next-lambda-seqno (fx+ seqno 1)) - seqno))) - (rec cons-info-lambda - (case-lambda - [(src sexpr libspec interface*) (cons-info-lambda src sexpr libspec interface* #f 0)] - [(src sexpr libspec interface* name) (cons-info-lambda src sexpr libspec interface* name 0)] - [(src sexpr libspec interface* name flags) - ((pargs->new) src sexpr libspec interface* - (map (lambda (iface) (make-direct-call-label 'dcl)) interface*) - (if (eq? (subset-mode) 'system) (fxlogor flags (constant code-flag-system)) flags) - '() name #f 'closure (and (generate-inspector-information) (make-ctci)) '() (next-seqno))]))))) - - (define-record-type info-call (nongenerative) - (parent info) - (sealed #t) - (fields src sexpr (mutable check?) pariah? error? shift-attachment? shift-consumer-attachment?*) - (protocol - (lambda (pargs->new) - (case-lambda - [(src sexpr check? pariah? error? shift-attachment? shift-consumer-attachment?*) - ((pargs->new) src sexpr check? pariah? error? shift-attachment? shift-consumer-attachment?*)] - [(src sexpr check? pariah? error?) - ((pargs->new) src sexpr check? pariah? error? #f '())])))) - - (define-record-type info-newframe (nongenerative) - (parent info) - (sealed #t) - (fields - src - sexpr - cnfv* - nfv* - nfv** - (mutable weight) - (mutable call-live*) - (mutable frame-words) - (mutable local-save*)) - (protocol - (lambda (pargs->new) - (lambda (src sexpr cnfv* nfv* nfv**) - ((pargs->new) src sexpr cnfv* nfv* nfv** 0 #f #f #f))))) - - (define-record-type info-kill* (nongenerative) - (parent info) - (fields kill*)) - - (define-record-type info-kill*-live* (nongenerative) - (parent info-kill*) - (fields live*) - (protocol - (lambda (new) - (case-lambda - [(kill* live*) - ((new kill*) live*)] - [(kill*) - ((new kill*) (reg-list))])))) - - (define-record-type info-asmlib (nongenerative) - (parent info-kill*-live*) - (sealed #t) - (fields libspec save-ra?) - (protocol - (lambda (new) - (case-lambda - [(kill* libspec save-ra? live*) - ((new kill* live*) libspec save-ra?)] - [(kill* libspec save-ra?) - ((new kill*) libspec save-ra?)])))) - - (module (intrinsic-info-asmlib intrinsic-return-live* intrinsic-entry-live* intrinsic-modify-reg* dorest-intrinsics) - ; standing on our heads here to avoid referencing registers at - ; load time...would be cleaner if registers were immutable, - ; i.e., mutable fields (direct and inherited from var) were kept - ; in separate tables...but that might add more cost to register - ; allocation, which is already expensive. - (define-record-type intrinsic (nongenerative) - (sealed #t) - (fields libspec get-kill* get-live* get-rv*)) - (define intrinsic-info-asmlib - (lambda (intrinsic save-ra?) - (make-info-asmlib ((intrinsic-get-kill* intrinsic)) - (intrinsic-libspec intrinsic) - save-ra? - ((intrinsic-get-live* intrinsic))))) - (define intrinsic-return-live* - ; used a handful of times, just while compiling library.ss...don't bother optimizing - (lambda (intrinsic) - (fold-left (lambda (live* kill) (remq kill live*)) - (vector->list regvec) ((intrinsic-get-kill* intrinsic))))) - (define intrinsic-entry-live* - ; used a handful of times, just while compiling library.ss...don't bother optimizing - (lambda (intrinsic) ; return-live* - rv + live* - (fold-left (lambda (live* live) (if (memq live live*) live* (cons live live*))) - (fold-left (lambda (live* rv) (remq rv live*)) - (intrinsic-return-live* intrinsic) - ((intrinsic-get-rv* intrinsic))) - ((intrinsic-get-live* intrinsic))))) - (define intrinsic-modify-reg* - (lambda (intrinsic) - (append ((intrinsic-get-rv* intrinsic)) - ((intrinsic-get-kill* intrinsic))))) - (define-syntax declare-intrinsic - (syntax-rules (unquote) - [(_ name entry-name (kill ...) (live ...) (rv ...)) - (begin - (define name - (make-intrinsic - (lookup-libspec entry-name) - (lambda () (reg-list kill ...)) - (lambda () (reg-list live ...)) - (lambda () (reg-list rv ...)))) - (export name))])) - ; must include in kill ... any register explicitly assigned by the intrinsic - ; plus additional registers as needed to avoid spilled unspillables. the - ; list could be machine-dependent but at this point it doesn't matter. - (declare-intrinsic dofargint32 dofargint32 (%ts %td %xp) (%ac0) (%ac0)) - (constant-case ptr-bits - [(32) (declare-intrinsic dofargint64 dofargint64 (%ts %td %xp) (%ac0) (%ac0 %ac1))] - [(64) (declare-intrinsic dofargint64 dofargint64 (%ts %td %xp) (%ac0) (%ac0))]) - (declare-intrinsic dofretint32 dofretint32 (%ts %td %xp) (%ac0) (%ac0)) - (constant-case ptr-bits - [(32) (declare-intrinsic dofretint64 dofretint64 (%ts %td %xp) (%ac0 %ac1) (%ac0))] - [(64) (declare-intrinsic dofretint64 dofretint64 (%ts %td %xp) (%ac0) (%ac0))]) - (declare-intrinsic dofretuns32 dofretuns32 (%ts %td %xp) (%ac0) (%ac0)) - (constant-case ptr-bits - [(32) (declare-intrinsic dofretuns64 dofretuns64 (%ts %td %xp) (%ac0 %ac1) (%ac0))] - [(64) (declare-intrinsic dofretuns64 dofretuns64 (%ts %td %xp) (%ac0) (%ac0))]) - (declare-intrinsic dofretu8* dofretu8* (%ac0 %ts %td %cp %ac1) (%ac0) (%xp)) - (declare-intrinsic dofretu16* dofretu16* (%ac0 %ts %td %cp %ac1) (%ac0) (%xp)) - (declare-intrinsic dofretu32* dofretu32* (%ac0 %ts %td %cp %ac1) (%ac0) (%xp)) - (declare-intrinsic get-room get-room () (%xp) (%xp)) - (declare-intrinsic scan-remembered-set scan-remembered-set () () ()) - (declare-intrinsic reify-1cc reify-1cc (%xp %ac0 %ts %reify1 %reify2) () (%td)) ; %reify1 & %reify2 are defined as needed per machine... - (declare-intrinsic maybe-reify-cc maybe-reify-cc (%xp %ac0 %ts %reify1 %reify2) () (%td)) ; ... to have enough registers to allocate - (declare-intrinsic dooverflow dooverflow () () ()) - (declare-intrinsic dooverflood dooverflood () (%xp) ()) - ; a dorest routine takes all of the register and frame arguments from the rest - ; argument forward and also modifies the rest argument. for the rest argument, - ; this is a wash (it's live both before and after). the others should also be - ; listed as live. it's inconvenient and currently unnecessary to do so. - ; (actually currently impossible to list the infinite set of frame arguments) - (define-syntax dorest-intrinsic-max (identifier-syntax 5)) - (export dorest-intrinsic-max) - (define (list-xtail ls n) - (if (or (null? ls) (fx= n 0)) - ls - (list-xtail (cdr ls) (fx1- n)))) - (define dorest-intrinsics - (let () - (define-syntax dorests - (lambda (x) - #`(vector #,@ - (let f ([i 0]) - (if (fx> i dorest-intrinsic-max) - '() - (cons #`(make-intrinsic - (lookup-libspec #,(construct-name #'k "dorest" i)) - (lambda () (reg-list %ac0 %xp %ts %td)) - (lambda () (reg-cons* %ac0 (list-xtail arg-registers #,i))) - (lambda () (let ([ls (list-xtail arg-registers #,i)]) (if (null? ls) '() (list (car ls)))))) - (f (fx+ i 1)))))))) - dorests))) - - (define-record-type info-alloc (nongenerative) - (parent info) - (sealed #t) - (fields tag save-flrv? save-ra?)) - - (define-record-type info-foreign (nongenerative) - (parent info) - (sealed #t) - (fields conv* arg-type* result-type unboxed? (mutable name)) - (protocol - (lambda (pargs->new) - (lambda (conv* arg-type* result-type unboxed?) - ((pargs->new) conv* arg-type* result-type unboxed? #f))))) - - (define-record-type info-literal (nongenerative) - (parent info) - (sealed #t) - (fields indirect? type addr offset)) - - (define-record-type info-lea (nongenerative) - (parent info) - (sealed #t) - (fields offset)) - - (define-record-type info-load (nongenerative) - (parent info) - (sealed #t) - (fields type swapped?)) - - (define-record-type info-condition-code (nongenerative) - (parent info) - (sealed #t) - (fields type reversed? invertible?)) - - (define-record-type info-c-simple-call (nongenerative) - (parent info-kill*-live*) - (sealed #t) - (fields save-ra? entry) - (protocol - (lambda (new) - (case-lambda - [(save-ra? entry) ((new '() '()) save-ra? entry)] - [(live* save-ra? entry) ((new '() live*) save-ra? entry)])))) - - (define-record-type info-c-return (nongenerative) - (parent info) - (sealed #t) - (fields offset)) - - (define-record-type info-inline (nongenerative) - (parent info) - (sealed #t) - (fields)) - - (define-record-type info-unboxed-args (nongenerative) - (parent info) - (fields unboxed?*)) + seqno)))) + + (include "np-info.ss") (module () (record-writer (record-type-descriptor info-load) @@ -1103,12 +679,6 @@ (fprintf p "#<literal ~s>" (info-literal-addr x)))) ) - (define (fp-type? type) - (nanopass-case (Ltype Type) type - [(fp-double-float) #t] - [(fp-single-float) #t] - [else #f])) - (define-pass cpnanopass : Lsrc (ir) -> L1 () (definitions (define-syntax with-uvars @@ -1175,132 +745,7 @@ (kfixed (car x**) (car body*)) (f (cdr x**) (cdr interface*) (cdr body*))))))))) - (define-syntax define-$type-check - (lambda (x) - (syntax-case x () - [(k L) (with-implicit (k $type-check) - #'(define $type-check - (lambda (mask type expr) - (with-output-language L - (cond - [(fx= type 0) (%inline log!test ,expr (immediate ,mask))] - [(= mask (constant byte-constant-mask)) (%inline eq? ,expr (immediate ,type))] - [else (%inline type-check? ,expr (immediate ,mask) (immediate ,type))])))))]))) - - (define-syntax %type-check - (lambda (x) - (syntax-case x () - [(k mask type expr) - (with-implicit (k $type-check quasiquote) - #'($type-check (constant mask) (constant type) `expr))]))) - - (define-syntax %typed-object-check ; NB: caller must bind e - (lambda (x) - (syntax-case x () - [(k mask type expr) - (with-implicit (k quasiquote %type-check %constant %mref) - #'`(if ,(%type-check mask-typed-object type-typed-object expr) - ,(%type-check mask type - ,(%mref expr ,(constant typed-object-type-disp))) - ,(%constant sfalse)))]))) - - (define-syntax %seq - (lambda (x) - (syntax-case x () - [(k e1 ... e2) - (with-implicit (k quasiquote) - #``#,(fold-right (lambda (x body) #`(seq #,x #,body)) - #'e2 #'(e1 ...)))]))) - - (define-syntax %mref - (lambda (x) - (syntax-case x () - [(k e0 e1 imm type) - (with-implicit (k quasiquote) - #'`(mref e0 e1 imm type))] - [(k e0 e1 imm) - (with-implicit (k quasiquote) - #'`(mref e0 e1 imm uptr))] - [(k e0 imm) - (with-implicit (k quasiquote) - #'`(mref e0 ,%zero imm uptr))]))) - - (define-syntax %inline - (lambda (x) - (syntax-case x () - [(k name e ...) - (with-implicit (k quasiquote) - #'`(inline ,null-info ,(%primitive name) e ...))]))) - - (define-syntax %lea - (lambda (x) - (syntax-case x () - [(k base offset) - (with-implicit (k quasiquote) - #'`(inline ,(make-info-lea offset) ,%lea1 base))] - [(k base index offset) - (with-implicit (k quasiquote) - #'`(inline ,(make-info-lea offset) ,%lea2 base index))]))) - - (define-syntax %constant - (lambda (x) - (syntax-case x () - [(k x) - (with-implicit (k quasiquote) - #'`(immediate ,(constant x)))]))) - - (define-syntax %tc-ref - (lambda (x) - (define-who field-type - (lambda (struct field) - (cond - [(assq field (getprop struct '*fields* '())) => - (lambda (a) - (apply - (lambda (field type disp len) type) - a))] - [else ($oops who "undefined field ~s-~s" struct field)]))) - (syntax-case x () - [(k field) #'(k ,%tc field)] - [(k e-tc field) - (if (memq (field-type 'tc (datum field)) '(ptr xptr uptr iptr)) - (with-implicit (k %mref) - #`(%mref e-tc - #,(lookup-constant - (string->symbol - (format "tc-~a-disp" (datum field)))))) - (syntax-error x "non-ptr-size tc field"))]))) - - (define-syntax %constant-alloc - (lambda (x) - (syntax-case x () - [(k tag size) #'(k tag size #f #f)] - [(k tag size save-flrv?) #'(k tag size save-flrv? #f)] - [(k tag size save-flrv? save-asm-ra?) - (with-implicit (k quasiquote) - #'`(alloc - ,(make-info-alloc (constant tag) save-flrv? save-asm-ra?) - (immediate ,(c-alloc-align size))))]))) - - (define-syntax %mv-jump - (lambda (x) - (syntax-case x () - [(k ret-reg (live ...)) - (with-implicit (k quasiquote %mref %inline %constant) - #'`(if ,(%inline logtest ,(%mref ret-reg ,(constant compact-return-address-mask+size+mode-disp)) - ,(%constant compact-header-mask)) - ;; compact: use regular return or error? - (if ,(%inline logtest ,(%mref ret-reg ,(constant compact-return-address-mask+size+mode-disp)) - ,(%constant compact-header-values-error-mask)) - ;; values error: - (jump (literal ,(make-info-literal #f 'library-code - (lookup-libspec values-error) - (constant code-data-disp))) - (live ...)) - ;; regular return point: - (jump ret-reg (live ...))) - ;; non-compact rp-header - (jump ,(%mref ret-reg ,(constant return-address-mv-return-address-disp)) (live ...))))]))) + (include "np-help.ss") (define-pass np-recognize-let : L1 (ir) -> L2 () (definitions @@ -1425,17 +870,6 @@ (lambda (x* body) `(clause (,x* ...) ,interface ,body)))])) - ; for use only after mdcl field has been added to the call syntax - (define-syntax %primcall - (lambda (x) - (syntax-case x () - [(k src sexpr prim arg ...) - (identifier? #'prim) - (with-implicit (k quasiquote) - #``(call ,(make-info-call src sexpr #f #f #f) #f - ,(lookup-primref 3 'prim) - arg ...))]))) - (define-pass np-sanitize-bindings : L4 (ir) -> L4 () ; must come before suppress-procedure-checks and recognize-mrvs ; since it sets up uvar-info-lambda, but after convert-assignments @@ -3477,7882 +2911,6 @@ (CaseLambdaClause : CaseLambdaClause (ir) -> CaseLambdaClause () [(clause (,x* ...) ,mcp ,interface ,body) (Expr body #f) ir])) - (define target-fixnum? - (if (and (= (constant most-negative-fixnum) (most-negative-fixnum)) - (= (constant most-positive-fixnum) (most-positive-fixnum))) - fixnum? - (lambda (x) - (and (or (fixnum? x) (bignum? x)) - (<= (constant most-negative-fixnum) x (constant most-positive-fixnum)))))) - - (define unfix - (lambda (imm) - (ash imm (fx- (constant fixnum-offset))))) - - (define fix - (lambda (imm) - (ash imm (constant fixnum-offset)))) - - (define ptr->imm - (lambda (x) - (cond - [(eq? x #f) (constant sfalse)] - [(eq? x #t) (constant strue)] - [(eq? x (void)) (constant svoid)] - [(null? x) (constant snil)] - [(eof-object? x) (constant seof)] - [($unbound-object? x) (constant sunbound)] - [(bwp-object? x) (constant sbwp)] - [(eq? x '#1=#1#) (constant black-hole)] - [(target-fixnum? x) (fix x)] - [(char? x) (+ (* (constant char-factor) (char->integer x)) (constant type-char))] - [else #f]))) - - (define-syntax ref-reg - (lambda (x) - (syntax-case x () - [(k reg) - (identifier? #'reg) - (if (real-register? (datum reg)) - #'reg - (with-implicit (k %mref) #`(%mref ,%tc ,(tc-disp reg))))]))) - - ;; After the `np-expand-primitives` pass, some expression produce - ;; double (i.e., floating-point) values instead of pointer values. - ;; Those expression results always flow to an `inline` primitive - ;; that expects double values. The main consequence is that a later - ;; pass must only put such returns in a temporary with type 'fp. - - ; TODO: recognize a direct call when it is at the end of a sequence, closures, or let form - ; TODO: push call into if? (would need to pull arguments into temporaries to ensure order of evaluation - ; TODO: how does this interact with mvcall? - (module (np-expand-primitives) - (define-threaded new-l*) - (define-threaded new-le*) - (define ht2 (make-hashtable symbol-hash eq?)) - (define ht3 (make-hashtable symbol-hash eq?)) - (define handle-prim - (lambda (src sexpr level name e*) - (let ([handler (or (and (fx= level 3) (symbol-hashtable-ref ht3 name #f)) - (symbol-hashtable-ref ht2 name #f))]) - (and handler (handler src sexpr e*))))) - (define-syntax Symref - (lambda (x) - (syntax-case x () - [(k ?sym) - (with-implicit (k quasiquote) - #'`(literal ,(make-info-literal #t 'object ?sym (constant symbol-value-disp))))]))) - (define single-valued? - (case-lambda - [(e) (single-valued? e 5)] - [(e fuel) - (and (not (zero? fuel)) - (nanopass-case (L7 Expr) e - [,x #t] - [(immediate ,imm) #t] - [(literal ,info) #t] - [(label-ref ,l ,offset) #t] - [(mref ,e1 ,e2 ,imm ,type) #t] - [(quote ,d) #t] - [,pr #t] - [(call ,info ,mdcl ,pr ,e* ...) - (all-set? (prim-mask single-valued) (primref-flags pr))] - [(foreign-call ,info ,e, e* ...) #t] - [(alloc ,info ,e) #t] - [(set! ,lvalue ,e) #t] - [(profile ,src) #t] - [(pariah) #t] - [(let ([,x* ,e*] ...) ,body) - (single-valued? body (fx- fuel 1))] - [(if ,e0 ,e1 ,e2) - (and (single-valued? e1 (fx- fuel 1)) - (single-valued? e2 (fx- fuel 1)))] - [(seq ,e0 ,e1) - (single-valued? e1 (fx- fuel 1))] - [(unboxed-fp ,e) #t] - [else #f]))])) - (define ensure-single-valued - (case-lambda - [(e unsafe-omit?) - (if (or unsafe-omit? - (single-valued? e)) - e - (with-output-language (L7 Expr) - (let ([t (make-tmp 'v)]) - `(values ,(make-info-call #f #f #f #f #f) ,e))))] - [(e) (ensure-single-valued e (fx= (optimize-level) 3))])) - (define-pass np-expand-primitives : L7 (ir) -> L9 () - (definitions - (define Expr1 - (lambda (e) - (let-values ([(e unboxed-fp?) (Expr e #f)]) - e))) - (define Expr* - (lambda (e*) - (map Expr1 e*))) - (define unboxed-fp->boxed - (lambda (e) - (let ([t (make-tmp 't)]) - (with-output-language (L9 Expr) - `(let ([,t ,(%constant-alloc type-flonum (constant size-flonum))]) - (seq - (set! ,(%mref ,t ,%zero ,(constant flonum-data-disp) fp) ,e) - ,t)))))) - (define (fp-lvalue? lvalue) - (nanopass-case (L9 Lvalue) lvalue - [,x (and (uvar? x) (eq? (uvar-type x) 'fp))] - [(mref ,e1 ,e2 ,imm ,type) (eq? type 'fp)]))) - (Program : Program (ir) -> Program () - [(labels ([,l* ,le*] ...) ,l) - (fluid-let ([new-l* '()] [new-le* '()]) - (let ([le* (map CaseLambdaExpr le*)]) - `(labels ([,l* ,le*] ... [,new-l* ,new-le*] ...) ,l)))]) - (CaseLambdaExpr : CaseLambdaExpr (ir) -> CaseLambdaExpr ()) - (CaseLambdaClause : CaseLambdaClause (ir) -> CaseLambdaClause () - [(clause (,x* ...) ,mcp ,interface ,[body #f -> body unboxed-fp?]) - `(clause (,x* ...) ,mcp ,interface ,body)]) - ;; The result of `Expr` can be unboxed (second result is #t) only - ;; if the `can-unbox-fp?` argument is #t, but the result can always - ;; be a boxed expression (even if `can-unbox-fp?` is #t) - (Expr : Expr (ir [can-unbox-fp? #f]) -> Expr (#f) - [(quote ,d) - (values (cond - [(ptr->imm d) => (lambda (i) `(immediate ,i))] - [else `(literal ,(make-info-literal #f 'object d 0))]) - #f)] - [,pr (values (Symref (primref-name pr)) #f)] - [(unboxed-fp ,[e #t -> e unboxed-fp?]) - (if can-unbox-fp? - (values e #t) - (values (unboxed-fp->boxed e) #f))] - [(call ,info0 ,mdcl0 - (call ,info1 ,mdcl1 ,pr (quote ,d)) - ,[e* #f -> e* unboxed-fp?*] ...) - (guard (and (eq? (primref-name pr) '$top-level-value) (symbol? d))) - (values `(call ,info0 ,mdcl0 ,(Symref d) ,e* ...) #f)] - [(call ,info ,mdcl ,pr ,e* ...) - (cond - [(and - (or (not (info-call-shift-attachment? info)) - ;; Note: single-valued also implies that the primitive doesn't - ;; tail-call an arbitary function (which might inspect attachments): - (all-set? (prim-mask single-valued) (primref-flags pr))) - (handle-prim (info-call-src info) (info-call-sexpr info) (primref-level pr) (primref-name pr) e*)) - => (lambda (e) - (let-values ([(e unboxed-fp?) (Expr e can-unbox-fp?)]) - (values - (cond - [(info-call-shift-attachment? info) - (let ([t (make-tmp 't (if unboxed-fp? 'fp 'ptr))]) - `(let ([,t ,e]) - (seq - (attachment-set pop #f) - ,t)))] - [else e]) - unboxed-fp?)))] - [else - (let ([e* (Expr* e*)]) - ; NB: expand calls through symbol top-level values similarly - (let ([info (if (any-set? (prim-mask abort-op) (primref-flags pr)) - (make-info-call (info-call-src info) (info-call-sexpr info) - (info-call-check? info) #t #t - (info-call-shift-attachment? info) - (info-call-shift-consumer-attachment?* info)) - info)]) - (values `(call ,info ,mdcl ,(Symref (primref-name pr)) ,e* ...) - ;; an error can be treated as unboxed if the context wants that: - (and can-unbox-fp? (info-call-error? info)))))])] - [(call ,info ,mdcl ,x ,e* ...) - (guard (uvar-loop? x)) - (let ([e* (map (lambda (x1 e) - (let ([unbox? (eq? (uvar-type x1) 'fp)]) - (let-values ([(e unboxed-fp?) (Expr e unbox?)]) - (cond - [(and unbox? (not unboxed-fp?)) - (%mref ,e ,%zero ,(constant flonum-data-disp) fp)] - [else e])))) - (uvar-location x) e*)]) - (values `(call ,info ,mdcl ,x ,e* ...) #f))] - [(call ,info ,mdcl ,e ,e* ...) - (let ([e (and e (Expr1 e))] - [e* (Expr* e*)]) - (values `(call ,info ,mdcl ,e ,e* ...) #f))] - [(inline ,info ,prim ,e* ...) - (cond - [(info-unboxed-args? info) - (let ([e* (map (lambda (e unbox-arg?) - (let-values ([(e unboxed-arg?) (Expr e unbox-arg?)]) - (if (and unbox-arg? (not unboxed-arg?)) - (%mref ,e ,%zero ,(constant flonum-data-disp) fp) - e))) - e* - (info-unboxed-args-unboxed?* info))]) - (values `(inline ,info ,prim ,e* ...) - ;; Especially likely to be replaced by enclosing `unboxed-fp` wrapper: - #f))] - [else - (let ([e* (Expr* e*)]) - (values `(inline ,info ,prim ,e* ...) #f))])] - [(set! ,[lvalue #t -> lvalue fp-unboxed?l] ,e) - (let ([fp? (fp-lvalue? lvalue)]) - (let-values ([(e unboxed?) (Expr e fp?)]) - (let ([e (if (and fp? (not unboxed?)) - (%mref ,e ,%zero ,(constant flonum-data-disp) fp) - e)]) - (values `(set! ,lvalue ,e) #f))))] - [(values ,info ,[e* #f -> e* unboxed-fp?*] ...) (values `(values ,info ,e* ...) #f)] - [(alloc ,info ,e) (values `(alloc ,info ,(Expr1 e)) #f)] - [(if ,[e0 #f -> e0 unboxed-fp?0] ,[e1 can-unbox-fp? -> e1 unboxed-fp?1] ,[e2 can-unbox-fp? -> e2 unboxed-fp?2]) - (let* ([unboxed-fp? (or unboxed-fp?1 unboxed-fp?2)] - [e1 (if (and unboxed-fp? (not unboxed-fp?1)) - (%mref ,e1 ,%zero ,(constant flonum-data-disp) fp) - e1)] - [e2 (if (and unboxed-fp? (not unboxed-fp?2)) - (%mref ,e2 ,%zero ,(constant flonum-data-disp) fp) - e2)]) - (values `(if ,e0 ,e1 ,e2) unboxed-fp?))] - [(seq ,[e0 #f -> e0 unboxed-fp?0] ,[e1 can-unbox-fp? -> e1 unboxed-fp?]) - (values `(seq ,e0 ,e1) unboxed-fp?)] - [(let ([,x* ,e*] ...) ,body) - (let ([e* (map (lambda (x e) - (if (eq? (uvar-type x) 'fp) - (let-values ([(e unboxed?) (Expr e #t)]) - (if (not unboxed?) - (%mref ,e ,%zero ,(constant flonum-data-disp) fp) - e)) - (Expr1 e))) - x* e*)]) - (let-values ([(body unboxed-fp?) (Expr body can-unbox-fp?)]) - (values `(let ([,x* ,e*] ...) ,body) unboxed-fp?)))] - [(loop ,x (,x* ...) ,body) - (uvar-location-set! x x*) - (let-values ([(body unboxed-fp?) (Expr body can-unbox-fp?)]) - (uvar-location-set! x #f) - (values `(loop ,x (,x* ...) ,body) unboxed-fp?))] - [(attachment-set ,aop ,e) (values `(attachment-set ,aop ,(and e (Expr1 e))) #f)] - [(attachment-get ,reified ,e) (values `(attachment-get ,reified ,(and e (Expr1 e))) #f)] - [(attachment-consume ,reified ,e) (values `(attachment-consume ,reified ,(and e (Expr1 e))) #f)] - [(continuation-set ,cop ,e1 ,e2) (values `(continuation-set ,cop ,(Expr1 e1) ,(Expr1 e2)) #f)] - [(label ,l ,[body can-unbox-fp? -> body unboxed-fp?]) (values `(label ,l ,body) unboxed-fp?)] - [(foreign-call ,info ,e ,e* ...) - (let ([e (Expr1 e)] - [e* (if (info-foreign-unboxed? info) - (map (lambda (e type) - (let ([unbox-arg? (fp-type? type)]) - (let-values ([(e unboxed-fp?) (Expr e unbox-arg?)]) - (if (and unbox-arg? (not unboxed-fp?)) - (%mref ,e ,%zero ,(constant flonum-data-disp) fp) - e)))) - e* - (info-foreign-arg-type* info)) - (map Expr1 e*))]) - (let ([new-e `(foreign-call ,info ,e ,e* ...)] - [unboxed? (and (info-foreign-unboxed? info) - (fp-type? (info-foreign-result-type info)))]) - (if (and unboxed? (not can-unbox-fp?)) - (values (unboxed-fp->boxed new-e) #f) - (values new-e unboxed?))))] - [(mvcall ,info ,e1 ,e2) (values `(mvcall ,info ,(Expr1 e1) ,(Expr1 e2)) #f)] - [(mvlet ,e ((,x** ...) ,interface* ,body*) ...) - (values `(mvlet ,(Expr1 e) ((,x** ...) ,interface* ,(map Expr1 body*)) ...) #f)] - [,lvalue (Lvalue lvalue can-unbox-fp?)]) - (Lvalue : Lvalue (ir [unboxed-fp? #f]) -> Lvalue (#f) - [(mref ,e1 ,e2 ,imm ,type) - (let ([e `(mref ,(Expr1 e1) ,(Expr1 e2) ,imm ,type)]) - (if (and (eq? type 'fp) (not unboxed-fp?)) - (values (unboxed-fp->boxed e) #f) - (values e (eq? type 'fp))))] - [,x - (let ([fp? (and (uvar? x) (eq? (uvar-type x) 'fp))]) - (if (and fp? (not unboxed-fp?)) - (values (unboxed-fp->boxed x) #f) - (values x fp?)))])) - (define-who unhandled-arity - (lambda (name args) - (sorry! who "unhandled argument count ~s for ~s" (length args) 'name))) - (with-output-language (L7 Expr) - (define-$type-check (L7 Expr)) - (define-syntax define-inline - (let () - (define ctht2 (make-hashtable symbol-hash eq?)) - (define ctht3 (make-hashtable symbol-hash eq?)) - (define check-and-record - (lambda (level name) - (let ([a (symbol-hashtable-cell (if (fx= level 2) ctht2 ctht3) (syntax->datum name) #f)]) - (when (cdr a) (syntax-error name "duplicate inline")) - (set-cdr! a #t)))) - (lambda (x) - (define compute-interface - (lambda (clause) - (syntax-case clause () - [(x e1 e2 ...) (identifier? #'x) -1] - [((x ...) e1 e2 ...) (length #'(x ...))] - [((x ... . r) e1 e2 ...) (fxlognot (length #'(x ...)))]))) - (define bitmaskify - (lambda (i*) - (fold-left (lambda (mask i) - (logor mask (if (fx< i 0) (ash -1 (fxlognot i)) (ash 1 i)))) - 0 i*))) - (syntax-case x () - [(k level id clause ...) - (identifier? #'id) - (let ([level (datum level)] [name (datum id)]) - (unless (memv level '(2 3)) - (syntax-error x (format "invalid level ~s in inline definition" level))) - (let ([pr ($sgetprop name (if (eqv? level 2) '*prim2* '*prim3*) #f)]) - (include "primref.ss") - (unless pr - (syntax-error x (format "unrecognized primitive name ~s in inline definition" name))) - (let ([arity (primref-arity pr)]) - (when arity - (unless (= (bitmaskify arity) (bitmaskify (map compute-interface #'(clause ...)))) - (syntax-error x (format "arity mismatch for ~s" name)))))) - (check-and-record level #'id) - (with-implicit (k src sexpr moi) - #`(symbol-hashtable-set! #,(if (eqv? level 2) #'ht2 #'ht3) 'id - (rec moi - (lambda (src sexpr args) - (apply (case-lambda clause ... [rest #f]) args))))))])))) - (define no-need-to-bind? - (lambda (multiple-ref? e) - (nanopass-case (L7 Expr) e - [,x (if (uvar? x) (not (uvar-assigned? x)) (eq? x %zero))] - [(immediate ,imm) #t] ; might should produce binding if imm is large - [(quote ,d) (or (not multiple-ref?) (ptr->imm d))] - [,pr (not multiple-ref?)] - [(literal ,info) (and (not multiple-ref?) (not (info-literal-indirect? info)))] - [(profile ,src) #t] - [(pariah) #t] - [else #f]))) - (define binder - (lambda (multiple-ref? type e) - (if (no-need-to-bind? multiple-ref? e) - (values e values) - (let ([t (make-tmp 't type)]) - (values t (lift-fp-unboxed - (lambda (body) - `(let ([,t ,e]) ,body)))))))) - (define list-binder - (lambda (multiple-ref? type e*) - (if (null? e*) - (values '() values) - (let-values ([(e dobind) (binder multiple-ref? type (car e*))] - [(e* dobind*) (list-binder multiple-ref? type (cdr e*))]) - (values (cons e e*) - (lambda (body) - (dobind (dobind* body)))))))) - (define-syntax $bind - (lambda (x) - (syntax-case x () - [(_ binder multiple-ref? type (b ...) e) - (let ([t0* (generate-temporaries #'(b ...))]) - (let f ([b* #'(b ...)] [t* t0*] [x* '()]) - (if (null? b*) - (with-syntax ([(x ...) (reverse x*)] [(t ...) t0*]) - #`(let ([x t] ...) e)) - (syntax-case (car b*) () - [x (identifier? #'x) - #`(let-values ([(#,(car t*) dobind) (binder multiple-ref? 'type x)]) - (dobind #,(f (cdr b*) (cdr t*) (cons #'x x*))))] - [(x e) (identifier? #'x) - #`(let-values ([(#,(car t*) dobind) (binder multiple-ref? 'type e)]) - (dobind #,(f (cdr b*) (cdr t*) (cons #'x x*))))]))))]))) - (define-syntax bind - (syntax-rules () - [(_ multiple-ref? type (b ...) e) - (identifier? #'type) - ($bind binder multiple-ref? type (b ...) e)] - [(_ multiple-ref? (b ...) e) - ($bind binder multiple-ref? ptr (b ...) e)])) - (define-syntax list-bind - (syntax-rules () - [(_ multiple-ref? type (b ...) e) - (identifier? #'type) - ($bind list-binder multiple-ref? type (b ...) e)] - [(_ multiple-ref? (b ...) e) - ($bind list-binder multiple-ref? ptr (b ...) e)])) - (define lift-fp-unboxed - (lambda (k) - (lambda (e) - ;; Propagate unboxing information: - (nanopass-case (L7 Expr) e - [(unboxed-fp ,e) `(unboxed-fp ,(k e))] - [else - (let ([new-e (k e)]) - (nanopass-case (L7 Expr) e - [(mref ,e0 ,e1 ,imm ,type) - (if (eq? type 'fp) - `(unboxed-fp ,new-e) - new-e)] - [,x (if (and (uvar? x) (eq? (uvar-type x) 'fp)) - `(unboxed-fp ,new-e) - new-e)] - [else new-e]))])))) - (define-syntax build-libcall - (lambda (x) - (syntax-case x () - [(k pariah? src sexpr name e ...) - (let ([libspec ($sgetprop (datum name) '*libspec* #f)]) - (define interface-okay? - (lambda (interface* cnt) - (ormap - (lambda (interface) - (if (fx< interface 0) - (fx>= cnt (lognot interface)) - (fx= cnt interface))) - interface*))) - (unless libspec (syntax-error x "unrecognized library routine")) - (unless (eqv? (length #'(e ...)) (libspec-interface libspec)) - (syntax-error x "invalid number of arguments")) - (let ([is-pariah? (datum pariah?)]) - (unless (boolean? is-pariah?) - (syntax-error x "pariah indicator must be a boolean literal")) - (when (and (libspec-error? libspec) (not is-pariah?)) - (syntax-error x "pariah indicator is inconsistent with libspec-error indicator")) - (with-implicit (k quasiquote) - (with-syntax ([body #`(call ,(make-info-call src sexpr #f pariah? #,(libspec-error? libspec)) #f - (literal ,(make-info-literal #f 'library '#,(datum->syntax #'* libspec) 0)) - ,e ...)]) - (if is-pariah? - #'`(seq (pariah) body) - #'`body)))))]))) - (define-syntax when-known-endianness - (lambda (stx) - (syntax-case stx () - [(_ e ...) - #'(constant-case native-endianness - [(unknown) (void)] - [else e ...])]))) - (define constant? - (case-lambda - [(x) - (nanopass-case (L7 Expr) x - [(quote ,d) #t] - ; TODO: handle immediate? - [else #f])] - [(pred? x) - (nanopass-case (L7 Expr) x - [(quote ,d) (pred? d)] - ; TODO: handle immediate? - [else #f])])) - (define constant-value - (lambda (x) - (nanopass-case (L7 Expr) x - [(quote ,d) d] - ; TODO: handle immediate if constant? does - [else #f]))) - (define maybe-add-label - (lambda (Llib body) - (if Llib - `(label ,Llib ,body) - body))) - (define build-and - (lambda (e1 e2) - `(if ,e1 ,e2 ,(%constant sfalse)))) - (define build-simple-or - (lambda (e1 e2) - `(if ,e1 ,(%constant strue) ,e2))) - (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 - [(quote ,d) (guard (target-fixnum? d)) `(immediate ,d)] - [else (%inline sra ,e ,(%constant fixnum-offset))]))) - (define build-not - (lambda (e) - `(if ,e ,(%constant sfalse) ,(%constant strue)))) - (define build-null? - (lambda (e) - (%type-check mask-nil snil ,e))) - (define build-eq? - (lambda (e1 e2) - (%inline eq? ,e1 ,e2))) - (define build-eqv? - (lambda (src sexpr e1 e2) - (bind #t (e1 e2) - (build-simple-or - (build-eq? e1 e2) - (build-and - ;; checking just one argument is good enough for typical - ;; uses, where `eqv?` almost always receives two fixnums - ;; or two characters; checking both arguments appears to - ;; by counter-productive by introducing too many branches - (build-simple-or - (%type-check mask-flonum type-flonum ,e1) - (build-and - (%type-check mask-typed-object type-typed-object ,e1) - (%type-check mask-other-number type-other-number - ,(%mref ,e1 ,(constant bignum-type-disp))))) - (build-libcall #f src sexpr eqv? e1 e2)))))) - (define make-build-eqv? - (lambda (src sexpr) - (lambda (e1 e2) - (build-eqv? src sexpr e1 e2)))) - (define fixnum-constant? - (lambda (e) - (constant? target-fixnum? e))) - (define expr->index - (lambda (e alignment limit) - (nanopass-case (L7 Expr) e - [(quote ,d) - (and (target-fixnum? d) - (>= d 0) - (< d limit) - (fxzero? (logand d (fx- alignment 1))) - d)] - [else #f]))) - (define build-fixnums? - (lambda (e*) - (let ([e* (remp fixnum-constant? e*)]) - (if (null? e*) - `(quote #t) - (%type-check mask-fixnum type-fixnum - ,(fold-left (lambda (e1 e2) (%inline logor ,e1 ,e2)) - (car e*) (cdr e*))))))) - (define build-flonums? - (lambda (e*) - (let ([e* (remp (lambda (e) (constant? flonum? e)) e*)]) - (if (null? e*) - `(quote #t) - (let f ([e* e*]) - (let ([e (car e*)] [e* (cdr e*)]) - (let ([check (%type-check mask-flonum type-flonum ,e)]) - (if (null? e*) - check - (build-and check (f e*)))))))))) - (define build-fl= - (lambda (e1 e2) ; must be bound - `(inline ,(make-info-unboxed-args '(#t #t)) ,%fp= ,e1 ,e2))) - (define build-chars? - (lambda (e1 e2) - (define char-constant? - (lambda (e) - (constant? char? e))) - (if (char-constant? e1) - (if (char-constant? e2) - (%constant strue) - (%type-check mask-char type-char ,e2)) - (if (char-constant? e2) - (%type-check mask-char type-char ,e1) - (build-and - (%type-check mask-char type-char ,e1) - (%type-check mask-char type-char ,e2)))))) - (define build-list - (lambda (e*) - (if (null? e*) - (%constant snil) - (list-bind #f (e*) - (bind #t ([t (%constant-alloc type-pair (fx* (constant size-pair) (length e*)))]) - (let loop ([e* e*] [i 0]) - (let ([e (car e*)] [e* (cdr e*)]) - `(seq - (set! ,(%mref ,t ,(fx+ i (constant pair-car-disp))) ,e) - ,(if (null? e*) - `(seq - (set! ,(%mref ,t ,(fx+ i (constant pair-cdr-disp))) ,(%constant snil)) - ,t) - (let ([next-i (fx+ i (constant size-pair))]) - `(seq - (set! ,(%mref ,t ,(fx+ i (constant pair-cdr-disp))) - ,(%inline + ,t (immediate ,next-i))) - ,(loop e* next-i)))))))))))) - (define build-pair? - (lambda (e) - (%type-check mask-pair type-pair ,e))) - (define build-car - (lambda (e) - (%mref ,e ,(constant pair-car-disp)))) - (define build-cdr - (lambda (e) - (%mref ,e ,(constant pair-cdr-disp)))) - (define build-char->integer - (lambda (e) - (%inline srl ,e - (immediate ,(fx- (constant char-data-offset) (constant fixnum-offset)))))) - (define build-integer->char - (lambda (e) - (%inline + - ,(%inline sll ,e - (immediate ,(fx- (constant char-data-offset) (constant fixnum-offset)))) - ,(%constant type-char)))) - (define add-store-fence - ;; A store--store fence should be good enough for safety on a platform that - ;; orders load dependencies (which is anything except Alpha) - (lambda (e) - (if-feature pthreads - (constant-case architecture - [(arm32 arm64) `(seq ,(%inline store-store-fence) ,e)] - [else e]) - e))) - (define build-dirty-store - (case-lambda - [(base offset e) (build-dirty-store base %zero offset e)] - [(base index offset e) (build-dirty-store base index offset e - (lambda (base index offset e) `(set! ,(%mref ,base ,index ,offset) ,e)) - (lambda (s r) (add-store-fence `(seq ,s ,r))))] - [(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) - (%lea ,base offset) - (%lea ,base ,index offset))]) - ; NB: should work harder to determine cases where x can't be a fixnum - (if (nanopass-case (L7 Expr) e - [(quote ,d) #t] - [(literal ,info) #t] - [else #f]) - (bind #f ([e e]) - ; eval a second so the address is not live across any calls - (bind #t ([a a]) - (build-barrier-seq - (build-assign a %zero 0 e) - (%inline remember ,a)))) - (bind #t ([e e]) - ; eval a second so the address is not live across any calls - (bind #t ([a a]) - (build-barrier-seq - (build-assign a %zero 0 e) - `(if ,(%type-check mask-fixnum type-fixnum ,e) - ,(%constant svoid) - ,(%inline remember ,a))))))))])) - (define make-build-cas - (lambda (old-v) - (lambda (base index offset v) - `(seq - ,(%inline cas ,base ,index (immediate ,offset) ,old-v ,v) - (inline ,(make-info-condition-code 'eq? #f #t) ,%condition-code))))) - (define build-cas-seq - (lambda (cas remember) - (add-store-fence - `(if ,cas - (seq ,remember ,(%constant strue)) - ,(%constant sfalse))))) - (define build-$record - (lambda (tag args) - (bind #f (tag) - (list-bind #f (args) - (let ([n (fx+ (length args) 1)]) - (bind #t ([t (%constant-alloc type-typed-object (fx* n (constant ptr-bytes)))]) - `(seq - (set! ,(%mref ,t ,(constant record-type-disp)) ,tag) - ,(let f ([args args] [offset (constant record-data-disp)]) - (if (null? args) - t - `(seq - (set! ,(%mref ,t ,offset) ,(car args)) - ,(f (cdr args) (fx+ offset (constant ptr-bytes))))))))))))) - (define build-$real->flonum - (lambda (src sexpr x who) - (if (known-flonum-result? x) - x - (bind #t (x) - (bind #f (who) - `(if ,(%type-check mask-flonum type-flonum ,x) - ,x - ,(build-libcall #t src sexpr real->flonum x who))))))) - (define build-$inexactnum-real-part - (lambda (e) - (%lea ,e (fx+ (constant inexactnum-real-disp) - (fx- (constant type-flonum) (constant typemod)))))) - (define build-$inexactnum-imag-part - (lambda (e) - (%lea ,e (fx+ (constant inexactnum-imag-disp) - (fx- (constant type-flonum) (constant typemod)))))) - (define make-build-fill - (lambda (elt-bytes data-disp) - (define ptr-bytes (constant ptr-bytes)) - (define super-size - (lambda (e-fill) - (define-who super-size-imm - (lambda (imm) - `(immediate - ,(constant-case ptr-bytes - [(4) - (case elt-bytes - [(1) (let ([imm (logand imm #xff)])< - (let ([imm (logor (ash imm 8) imm)]) - (logor (ash imm 16) imm)))] - [(2) (let ([imm (logand imm #xffff)]) - (logor (ash imm 16) imm))] - [else (sorry! who "unexpected elt-bytes ~s" elt-bytes)])] - [(8) - (case elt-bytes - [(1) (let ([imm (logand imm #xff)]) - (let ([imm (logor (ash imm 8) imm)]) - (let ([imm (logor (ash imm 16) imm)]) - (logor (ash imm 32) imm))))] - [(2) (let ([imm (logand imm #xffff)]) - (let ([imm (logor (ash imm 16) imm)]) - (logor (ash imm 32) imm)))] - [(4) (let ([imm (logand imm #xffffffff)]) - (logor (ash imm 32) imm))] - [else (sorry! who "unexpected elt-bytes ~s" elt-bytes)])])))) - (define-who super-size-expr - (lambda (e-fill) - (define (double e-fill k) - (%inline logor - ,(%inline sll ,e-fill (immediate ,k)) - ,e-fill)) - (define (mask e-fill k) - (%inline logand ,e-fill (immediate ,k))) - (constant-case ptr-bytes - [(4) - (case elt-bytes - [(1) (bind #t ([e-fill (mask e-fill #xff)]) - (bind #t ([e-fill (double e-fill 8)]) - (double e-fill 16)))] - [(2) (bind #t ([e-fill (mask e-fill #xffff)]) - (double e-fill 16))] - [else (sorry! who "unexpected elt-bytes ~s" elt-bytes)])] - [(8) - (case elt-bytes - [(1) (bind #t ([e-fill (mask e-fill #xff)]) - (bind #t ([e-fill (double e-fill 8)]) - (bind #t ([e-fill (double e-fill 16)]) - (double e-fill 32))))] - [(2) (bind #t ([e-fill (mask e-fill #xffff)]) - (bind #t ([e-fill (double e-fill 16)]) - (double e-fill 32)))] - [(4) (bind #t ([e-fill (mask e-fill #xffffffff)]) - (double e-fill 32))] - [else (sorry! who "unexpected elt-bytes ~s" elt-bytes)])]))) - (if (fx= elt-bytes ptr-bytes) - e-fill - (nanopass-case (L7 Expr) e-fill - [(quote ,d) - (cond - [(ptr->imm d) => super-size-imm] - [else (super-size-expr e-fill)])] - [(immediate ,imm) (super-size-imm imm)] - [else (super-size-expr e-fill)])))) - (lambda (e-vec e-bytes e-fill) - ; NB: caller must bind e-vec and e-fill - (safe-assert (no-need-to-bind? #t e-vec)) - (safe-assert (no-need-to-bind? #f e-fill)) - (nanopass-case (L7 Expr) e-bytes - [(immediate ,imm) - (guard (fixnum? imm) (fx<= 0 imm (fx* 4 ptr-bytes))) - (if (fx= imm 0) - e-vec - (bind #t ([e-fill (super-size e-fill)]) - (let f ([n (if (fx>= elt-bytes ptr-bytes) - imm - (fxlogand (fx+ imm (fx- ptr-bytes 1)) (fx- ptr-bytes)))]) - (let ([n (fx- n ptr-bytes)]) - `(seq - (set! ,(%mref ,e-vec ,(fx+ data-disp n)) ,e-fill) - ,(if (fx= n 0) e-vec (f n)))))))] - [else - (let ([Ltop (make-local-label 'Ltop)] [t (make-assigned-tmp 't 'uptr)]) - (bind #t ([e-fill (super-size e-fill)]) - `(let ([,t ,(if (fx>= elt-bytes ptr-bytes) - e-bytes - (nanopass-case (L7 Expr) e-bytes - [(immediate ,imm) - `(immediate ,(logand (+ imm (fx- ptr-bytes 1)) (fx- ptr-bytes)))] - [else - (%inline logand - ,(%inline + - ,e-bytes - (immediate ,(fx- ptr-bytes 1))) - (immediate ,(fx- ptr-bytes)))]))]) - (label ,Ltop - (if ,(%inline eq? ,t (immediate 0)) - ,e-vec - ,(%seq - (set! ,t ,(%inline - ,t (immediate ,ptr-bytes))) - (set! ,(%mref ,e-vec ,t ,data-disp) ,e-fill) - (goto ,Ltop)))))))])))) - - ;; NOTE: integer->ptr and unsigned->ptr DO NOT handle 64-bit integers on a 32-bit machine. - ;; this is okay for $object-ref and $object-set!, which do not support moving 64-bit values - ;; as single entities on a 32-bit machine, but care should be taken if these are used with - ;; other primitives. - (define-who integer->ptr - (lambda (x width) - (if (fx>= (constant fixnum-bits) width) - (build-fix x) - (%seq - (set! ,%ac0 ,x) - (set! ,%xp ,(build-fix %ac0)) - (set! ,%xp ,(build-unfix %xp)) - (if ,(%inline eq? ,%ac0 ,%xp) - ,(build-fix %ac0) - (seq - (set! ,%ac0 - (inline - ,(case width - [(32) (intrinsic-info-asmlib dofretint32 #f)] - [(64) (intrinsic-info-asmlib dofretint64 #f)] - [else ($oops who "can't handle width ~s" width)]) - ,%asmlibcall)) - ,%ac0)))))) - (define-who unsigned->ptr - (lambda (x width) - (if (fx>= (constant fixnum-bits) width) - (build-fix x) - `(seq - (set! ,%ac0 ,x) - (if ,(%inline u< ,(%constant most-positive-fixnum) ,%ac0) - (seq - (set! ,%ac0 - (inline - ,(case width - [(32) (intrinsic-info-asmlib dofretuns32 #f)] - [(64) (intrinsic-info-asmlib dofretuns64 #f)] - [else ($oops who "can't handle width ~s" width)]) - ,%asmlibcall)) - ,%ac0) - ,(build-fix %ac0)))))) - (define-who i32xu32->ptr - (lambda (hi lo) - (safe-assert (eqv? (constant ptr-bits) 32)) - (let ([Lbig (make-local-label 'Lbig)]) - (bind #t (lo hi) - `(if ,(%inline eq? ,hi ,(%inline sra ,lo (immediate 31))) - ,(bind #t ([fxlo (build-fix lo)]) - `(if ,(%inline eq? ,(build-unfix fxlo) ,lo) - ,fxlo - (goto ,Lbig))) - (label ,Lbig - ,(%seq - (set! ,%ac0 ,lo) - (set! ,(ref-reg %ac1) ,hi) - (set! ,%ac0 (inline ,(intrinsic-info-asmlib dofretint64 #f) ,%asmlibcall)) - ,%ac0))))))) - (define-who u32xu32->ptr - (lambda (hi lo) - (safe-assert (eqv? (constant ptr-bits) 32)) - (let ([Lbig (make-local-label 'Lbig)]) - (bind #t (lo hi) - `(if ,(%inline eq? ,hi (immediate 0)) - (if ,(%inline u< ,(%constant most-positive-fixnum) ,lo) - (goto ,Lbig) - ,(build-fix lo)) - (label ,Lbig - ,(%seq - (set! ,%ac0 ,lo) - (set! ,(ref-reg %ac1) ,hi) - (set! ,%ac0 (inline ,(intrinsic-info-asmlib dofretuns64 #f) ,%asmlibcall)) - ,%ac0))))))) - - (define-who ptr->integer - (lambda (value width) - (if (fx> (constant fixnum-bits) width) - (build-unfix value) - `(seq - (set! ,%ac0 ,value) - (if ,(%type-check mask-fixnum type-fixnum ,%ac0) - ,(build-unfix %ac0) - (seq - (set! ,%ac0 - (inline - ,(cond - [(fx<= width 32) (intrinsic-info-asmlib dofargint32 #f)] - [(fx<= width 64) (intrinsic-info-asmlib dofargint64 #f)] - [else ($oops who "can't handle width ~s" width)]) - ,%asmlibcall)) - ,%ac0)))))) - (define ptr-type (constant-case ptr-bits - [(32) 'unsigned-32] - [(64) 'unsigned-64] - [else ($oops 'ptr-type "unknown ptr-bit size ~s" (constant ptr-bits))])) - (define-who type->width - (lambda (x) - (case x - [(integer-8 unsigned-8 char) 8] - [(integer-16 unsigned-16) 16] - [(integer-24 unsigned-24) 24] - [(integer-32 unsigned-32 single-float) 32] - [(integer-40 unsigned-40) 40] - [(integer-48 unsigned-48) 48] - [(integer-56 unsigned-56) 56] - [(integer-64 unsigned-64 double-float) 64] - [(scheme-object fixnum) (constant ptr-bits)] - [(wchar) (constant wchar-bits)] - [else ($oops who "unknown type ~s" x)]))) - (define offset-expr->index+offset - (lambda (offset) - (if (fixnum-constant? offset) - (values %zero (constant-value offset)) - (values (build-unfix offset) 0)))) - (define-who build-int-load - ;; assumes aligned (if required) offset - (lambda (swapped? type base index offset build-int) - (case type - [(integer-8 unsigned-8) - (build-int `(inline ,(make-info-load type #f) ,%load ,base ,index (immediate ,offset)))] - [(integer-16 integer-32 unsigned-16 unsigned-32) - (build-int `(inline ,(make-info-load type swapped?) ,%load ,base ,index (immediate ,offset)))] - [(integer-64 unsigned-64) - ;; NB: doesn't handle unknown endiannesss for 32-bit machines - (constant-case ptr-bits - [(32) - (let-values ([(lo hi) (if (constant-case native-endianness [(little) swapped?] [(big) (not swapped?)]) - (values (+ offset 4) offset) - (values offset (+ offset 4)))]) - (bind #t (base index) - (build-int - `(inline ,(make-info-load 'integer-32 swapped?) ,%load ,base ,index (immediate ,hi)) - `(inline ,(make-info-load 'unsigned-32 swapped?) ,%load ,base ,index (immediate ,lo)))))] - [(64) - (build-int `(inline ,(make-info-load type swapped?) ,%load ,base ,index (immediate ,offset)))])] - [(integer-24 unsigned-24) - (constant-case native-endianness - [(unknown) #f] - [else - (let-values ([(lo hi) (if (constant-case native-endianness [(little) swapped?] [(big) (not swapped?)]) - (values (+ offset 1) offset) - (values offset (+ offset 2)))]) - (define hi-type (if (eq? type 'integer-24) 'integer-8 'unsigned-8)) - (bind #t (base index) - (build-int - (%inline logor - ,(%inline sll - (inline ,(make-info-load hi-type #f) ,%load ,base ,index (immediate ,hi)) - (immediate 16)) - (inline ,(make-info-load 'unsigned-16 swapped?) ,%load ,base ,index (immediate ,lo))))))])] - [(integer-40 unsigned-40) - (constant-case native-endianness - [(unknown) #f] - [else - (let-values ([(lo hi) (if (constant-case native-endianness [(little) swapped?] [(big) (not swapped?)]) - (values (+ offset 1) offset) - (values offset (+ offset 4)))]) - (define hi-type (if (eq? type 'integer-40) 'integer-8 'unsigned-8)) - (bind #t (base index) - (constant-case ptr-bits - [(32) - (build-int - `(inline ,(make-info-load hi-type #f) ,%load ,base ,index (immediate ,hi)) - `(inline ,(make-info-load 'unsigned-32 swapped?) ,%load ,base ,index (immediate ,lo)))] - [(64) - (build-int - (%inline logor - ,(%inline sll - (inline ,(make-info-load hi-type #f) ,%load ,base ,index (immediate ,hi)) - (immediate 32)) - (inline ,(make-info-load 'unsigned-32 swapped?) ,%load ,base ,index (immediate ,lo))))])))])] - [(integer-48 unsigned-48) - (constant-case native-endianness - [(unknown) #f] - [else - (let-values ([(lo hi) (if (constant-case native-endianness [(little) swapped?] [(big) (not swapped?)]) - (values (+ offset 2) offset) - (values offset (+ offset 4)))]) - (define hi-type (if (eq? type 'integer-48) 'integer-16 'unsigned-16)) - (bind #t (base index) - (constant-case ptr-bits - [(32) - (build-int - `(inline ,(make-info-load hi-type swapped?) ,%load ,base ,index (immediate ,hi)) - `(inline ,(make-info-load 'unsigned-32 swapped?) ,%load ,base ,index (immediate ,lo)))] - [(64) - (build-int - (%inline logor - ,(%inline sll - (inline ,(make-info-load hi-type swapped?) ,%load ,base ,index (immediate ,hi)) - (immediate 32)) - (inline ,(make-info-load 'unsigned-32 swapped?) ,%load ,base ,index (immediate ,lo))))])))])] - [(integer-56 unsigned-56) - (constant-case native-endianness - [(unknown) #f] - [else - (safe-assert (not (eq? (constant native-endianness) 'unknown))) - (let-values ([(lo mi hi) (if (constant-case native-endianness [(little) swapped?] [(big) (not swapped?)]) - (values (+ offset 3) (+ offset 1) offset) - (values offset (+ offset 4) (+ offset 6)))]) - (define hi-type (if (eq? type 'integer-56) 'integer-8 'unsigned-8)) - (bind #t (base index) - (constant-case ptr-bits - [(32) - (build-int - (%inline logor - ,(%inline sll - (inline ,(make-info-load hi-type #f) ,%load ,base ,index (immediate ,hi)) - (immediate 16)) - (inline ,(make-info-load 'unsigned-16 swapped?) ,%load ,base ,index (immediate ,mi))) - `(inline ,(make-info-load 'unsigned-32 swapped?) ,%load ,base ,index (immediate ,lo)))] - [(64) - (build-int - (%inline logor - ,(%inline sll - ,(%inline logor - ,(%inline sll - (inline ,(make-info-load hi-type #f) ,%load ,base ,index (immediate ,hi)) - (immediate 16)) - (inline ,(make-info-load 'unsigned-16 swapped?) ,%load ,base ,index (immediate ,mi))) - (immediate 32)) - (inline ,(make-info-load 'unsigned-32 swapped?) ,%load ,base ,index (immediate ,lo))))])))])] - [else (sorry! who "unsupported type ~s" type)]))) - (define-who build-object-ref - ;; assumes aligned (if required) offset - (case-lambda - [(swapped? type base offset-expr) - (let-values ([(index offset) (offset-expr->index+offset offset-expr)]) - (build-object-ref swapped? type base index offset))] - [(swapped? type base index offset) - (case type - [(scheme-object) `(inline ,(make-info-load ptr-type swapped?) ,%load ,base ,index (immediate ,offset))] - [(double-float) - (if swapped? - (constant-case ptr-bits - [(32) - (bind #t (base index) - (bind #t ([t (%constant-alloc type-flonum (constant size-flonum))]) - (%seq - (set! ,(%mref ,t ,(constant flonum-data-disp)) - (inline ,(make-info-load 'unsigned-32 #t) ,%load ,base ,index - (immediate ,(+ offset 4)))) - (set! ,(%mref ,t ,(+ (constant flonum-data-disp) 4)) - (inline ,(make-info-load 'unsigned-32 #t) ,%load ,base ,index - (immediate ,offset))) - ,t)))] - [(64) - (bind #f (base index) - (bind #t ([t (%constant-alloc type-flonum (constant size-flonum))]) - `(seq - (set! ,(%mref ,t ,(constant flonum-data-disp)) - (inline ,(make-info-load 'unsigned-64 #t) ,%load ,base ,index - (immediate ,offset))) - ,t)))]) - (bind #f (base index) - (%mref ,base ,index ,offset fp)))] - [(single-float) - (if swapped? - (bind #f (base index) - (bind #t ([t (%constant-alloc type-flonum (constant size-flonum))]) - (%seq - (inline ,(make-info-load 'unsigned-32 #f) ,%store ,t ,%zero ,(%constant flonum-data-disp) - (inline ,(make-info-load 'unsigned-32 #t) ,%load ,base ,index - (immediate ,offset))) - (set! ,(%mref ,t ,%zero ,(constant flonum-data-disp) fp) - (unboxed-fp (inline ,(make-info-unboxed-args '(#t)) - ,%load-single->double - ;; slight abuse to call this "unboxed", but `load-single->double` - ;; wants an FP-flavored address - ,(%mref ,t ,%zero ,(constant flonum-data-disp) fp)))) - ,t))) - (bind #f (base index) - (bind #t ([t (%constant-alloc type-flonum (constant size-flonum))]) - (%seq - (set! ,(%mref ,t ,%zero ,(constant flonum-data-disp) fp) - (unboxed-fp (inline ,(make-info-unboxed-args '(#t)) - ,%load-single->double - ;; slight abuse to call this "unboxed", but `load-single->double` - ;; wants an FP-flavored address - ,(%mref ,base ,index ,offset fp)))) - ,t))))] - [(integer-8 integer-16 integer-24 integer-32 integer-40 integer-48 integer-56 integer-64) - (build-int-load swapped? type base index offset - (if (and (eqv? (constant ptr-bits) 32) (memq type '(integer-40 integer-48 integer-56 integer-64))) - i32xu32->ptr - (lambda (x) (integer->ptr x (type->width type)))))] - [(unsigned-8 unsigned-16 unsigned-24 unsigned-32 unsigned-40 unsigned-48 unsigned-56 unsigned-64) - (build-int-load swapped? type base index offset - (if (and (eqv? (constant ptr-bits) 32) (memq type '(unsigned-40 unsigned-48 unsigned-56 unsigned-64))) - u32xu32->ptr - (lambda (x) (unsigned->ptr x (type->width type)))))] - [(fixnum) (build-fix `(inline ,(make-info-load ptr-type swapped?) ,%load ,base ,index (immediate ,offset)))] - [else (sorry! who "unsupported type ~s" type)])])) - (define-who build-int-store - ;; assumes aligned (if required) offset - (lambda (swapped? type base index offset value) - (case type - [(integer-8 unsigned-8) - `(inline ,(make-info-load type #f) ,%store ,base ,index (immediate ,offset) ,value)] - [(integer-16 integer-32 integer-64 unsigned-16 unsigned-32 unsigned-64) - `(inline ,(make-info-load type swapped?) ,%store ,base ,index (immediate ,offset) ,value)] - [(integer-24 unsigned-24) - (constant-case native-endianness - [(unknown) #f] - [else - (let-values ([(lo hi) (if (constant-case native-endianness [(little) swapped?] [(big) (not swapped?)]) - (values (+ offset 1) offset) - (values offset (+ offset 2)))]) - (bind #t (base index value) - (%seq - (inline ,(make-info-load 'unsigned-16 swapped?) ,%store ,base ,index (immediate ,lo) ,value) - (inline ,(make-info-load 'unsigned-8 #f) ,%store ,base ,index (immediate ,hi) - ,(%inline srl ,value (immediate 16))))))])] - [(integer-40 unsigned-40) - (constant-case native-endianness - [(unknown) #f] - [else - (let-values ([(lo hi) (if (constant-case native-endianness [(little) swapped?] [(big) (not swapped?)]) - (values (+ offset 1) offset) - (values offset (+ offset 4)))]) - (bind #t (base index value) - (%seq - (inline ,(make-info-load 'unsigned-32 swapped?) ,%store ,base ,index (immediate ,lo) ,value) - (inline ,(make-info-load 'unsigned-8 #f) ,%store ,base ,index (immediate ,hi) - ,(%inline srl ,value (immediate 32))))))])] - [(integer-48 unsigned-48) - (constant-case native-endianness - [(unknown) #f] - [else - (let-values ([(lo hi) (if (constant-case native-endianness [(little) swapped?] [(big) (not swapped?)]) - (values (+ offset 2) offset) - (values offset (+ offset 4)))]) - (bind #t (base index value) - (%seq - (inline ,(make-info-load 'unsigned-32 swapped?) ,%store ,base ,index (immediate ,lo) ,value) - (inline ,(make-info-load 'unsigned-16 swapped?) ,%store ,base ,index (immediate ,hi) - ,(%inline srl ,value (immediate 32))))))])] - [(integer-56 unsigned-56) - (constant-case native-endianness - [(unknown) #f] - [else - (let-values ([(lo mi hi) (if (constant-case native-endianness [(little) swapped?] [(big) (not swapped?)]) - (values (+ offset 3) (+ offset 1) offset) - (values offset (+ offset 4) (+ offset 6)))]) - (bind #t (base index value) - (%seq - (inline ,(make-info-load 'unsigned-32 swapped?) ,%store ,base ,index (immediate ,lo) ,value) - (inline ,(make-info-load 'unsigned-16 swapped?) ,%store ,base ,index (immediate ,mi) - ,(%inline srl ,value (immediate 32))) - (inline ,(make-info-load 'unsigned-8 #f) ,%store ,base ,index (immediate ,hi) - ,(%inline srl ,value (immediate 48))))))])] - [else (sorry! who "unsupported type ~s" type)]))) - (define-who build-object-set! - ;; assumes aligned (if required) offset - (case-lambda - [(type base offset-expr value) - (let-values ([(index offset) (offset-expr->index+offset offset-expr)]) - (build-object-set! type base index offset value))] - [(type base index offset value) - (case type - [(scheme-object) (build-dirty-store base index offset value)] - [(double-float) - (bind #f (base index) - `(set! ,(%mref ,base ,index ,offset fp) ,value))] - [(single-float) - (bind #f (base index) - `(inline ,(make-info-unboxed-args '(#t #t)) ,%store-double->single - ;; slight abuse to call this "unboxed", but `store-double->single` - ;; wants an FP-flavored address - ,(%mref ,base ,index ,offset fp) - ,(%mref ,value ,%zero ,(constant flonum-data-disp) fp)))] - ; 40-bit+ only on 64-bit machines - [(integer-8 integer-16 integer-24 integer-32 integer-40 integer-48 integer-56 integer-64 - unsigned-8 unsigned-16 unsigned-24 unsigned-32 unsigned-40 unsigned-48 unsigned-56 unsigned-64) - (build-int-store #f type base index offset (ptr->integer value (type->width type)))] - [(fixnum) - `(inline ,(make-info-load ptr-type #f) ,%store - ,base ,index (immediate ,offset) ,(build-unfix value))] - [else (sorry! who "unrecognized type ~s" type)])])) - (define-who build-swap-object-set! - (case-lambda - [(type base offset-expr value) - (let-values ([(index offset) (offset-expr->index+offset offset-expr)]) - (build-swap-object-set! type base index offset value))] - [(type base index offset value) - (case type - ; only on 64-bit machines - [(double-float) - `(inline ,(make-info-load 'unsigned-64 #t) ,%store - ,base ,index (immediate ,offset) - ,(%mref ,value ,(constant flonum-data-disp)))] - ; 40-bit+ only on 64-bit machines - [(integer-8 integer-16 integer-24 integer-32 integer-40 integer-48 integer-56 integer-64 - unsigned-8 unsigned-16 unsigned-24 unsigned-32 unsigned-40 unsigned-48 unsigned-56 unsigned-64) - (build-int-store #t type base index offset (ptr->integer value (type->width type)))] - [(fixnum) - `(inline ,(make-info-load ptr-type #t) ,%store ,base ,index (immediate ,offset) - ,(build-unfix value))] - [else (sorry! who "unrecognized type ~s" type)])])) - (define extract-unsigned-bitfield - (lambda (raw? start end arg) - (let* ([left (fx- (if raw? (constant ptr-bits) (constant fixnum-bits)) end)] - [right (if raw? (fx- (fx+ left start) (constant fixnum-offset)) (fx+ left start))] - [body (%inline srl - ,(if (fx= left 0) - arg - (%inline sll ,arg (immediate ,left))) - (immediate ,right))]) - (if (fx= start 0) - body - (%inline logand ,body (immediate ,(- (constant fixnum-factor)))))))) - (define extract-signed-bitfield - (lambda (raw? start end arg) - (let* ([left (fx- (if raw? (constant ptr-bits) (constant fixnum-bits)) end)] - [right (if raw? (fx- (fx+ left start) (constant fixnum-offset)) (fx+ left start))]) - (let ([body (if (fx= left 0) arg (%inline sll ,arg (immediate ,left)))]) - (let ([body (if (fx= right 0) body (%inline sra ,body (immediate ,right)))]) - (if (fx= start 0) - body - (%inline logand ,body (immediate ,(- (constant fixnum-factor)))))))))) - (define insert-bitfield - (lambda (raw? start end bf-width arg val) - (if raw? - (cond - [(fx= start 0) - (%inline logor - ,(%inline sll - ,(%inline srl ,arg (immediate ,end)) - (immediate ,end)) - ,(%inline srl - ,(%inline sll ,val (immediate ,(fx- (constant fixnum-bits) end))) - (immediate ,(fx- (constant ptr-bits) end))))] - [(fx= end bf-width) - (%inline logor - ,(%inline srl - ,(%inline sll ,arg - (immediate ,(fx- (constant ptr-bits) start))) - (immediate ,(fx- (constant ptr-bits) start))) - ,(cond - [(fx< start (constant fixnum-offset)) - (%inline srl ,val - (immediate ,(fx- (constant fixnum-offset) start)))] - [(fx> start (constant fixnum-offset)) - (%inline sll ,val - (immediate ,(fx- start (constant fixnum-offset))))] - [else val]))] - [else - (%inline logor - ,(%inline logand ,arg - (immediate ,(lognot (ash (- (expt 2 (fx- end start)) 1) start)))) - ,(%inline srl - ,(if (fx= (fx- end start) (constant fixnum-bits)) - val - (%inline sll ,val - (immediate ,(fx- (constant fixnum-bits) (fx- end start))))) - (immediate ,(fx- (constant ptr-bits) end))))]) - (cond - [(fx= start 0) - (%inline logor - ,(%inline sll - ,(%inline srl ,arg (immediate ,(fx+ end (constant fixnum-offset)))) - (immediate ,(fx+ end (constant fixnum-offset)))) - ,(%inline srl - ,(%inline sll ,val (immediate ,(fx- (constant fixnum-bits) end))) - (immediate ,(fx- (constant fixnum-bits) end))))] - #;[(fx= end (constant fixnum-bits)) ---] ; end < fixnum-bits - [else - (%inline logor - ,(%inline logand ,arg - (immediate ,(lognot (ash (- (expt 2 (fx- end start)) 1) - (fx+ start (constant fixnum-offset)))))) - ,(%inline srl - ,(%inline sll ,val - (immediate ,(fx- (constant fixnum-bits) (fx- end start)))) - (immediate ,(fx- (constant fixnum-bits) end))))])))) - (define translate - (lambda (e current-shift target-shift) - (let ([delta (fx- current-shift target-shift)]) - (if (fx= delta 0) - e - (if (fx< delta 0) - (%inline sll ,e (immediate ,(fx- delta))) - (%inline srl ,e (immediate ,delta))))))) - (define extract-length - (lambda (t/l length-offset) - (%inline logand - ,(translate t/l length-offset (constant fixnum-offset)) - (immediate ,(- (constant fixnum-factor)))))) - (define build-type/length - (lambda (e type current-shift target-shift) - (let ([e (translate e current-shift target-shift)]) - (if (eqv? type 0) - e - (%inline logor ,e (immediate ,type)))))) - (define-syntax build-ref-check - (syntax-rules () - [(_ type-disp maximum-length length-offset type mask immutable-flag) - (lambda (e-v e-i maybe-e-new) - ; NB: caller must bind e-v, e-i, and maybe-e-new - (safe-assert (no-need-to-bind? #t e-v)) - (safe-assert (no-need-to-bind? #t e-i)) - (safe-assert (or (not maybe-e-new) (no-need-to-bind? #t maybe-e-new))) - (build-and - (%type-check mask-typed-object type-typed-object ,e-v) - (bind #t ([t (%mref ,e-v ,(constant type-disp))]) - (cond - [(expr->index e-i 1 (constant maximum-length)) => - (lambda (index) - (let ([e (%inline u< - (immediate ,(logor (ash index (constant length-offset)) (constant type) (constant immutable-flag))) - ,t)]) - (if (and (eqv? (constant type) (constant type-fixnum)) - (eqv? (constant mask) (constant mask-fixnum))) - (build-and e (build-fixnums? (if maybe-e-new (list t maybe-e-new) (list t)))) - (build-and - (%type-check mask type ,t) - (if maybe-e-new (build-and e (build-fixnums? (list maybe-e-new))) e)))))] - [else - (let ([e (%inline u< ,e-i ,(extract-length t (constant length-offset)))]) - (if (and (eqv? (constant type) (constant type-fixnum)) - (eqv? (constant mask) (constant mask-fixnum))) - (build-and e (build-fixnums? (if maybe-e-new (list e-i t maybe-e-new) (list e-i t)))) - (build-and - (%type-check mask type ,t) - (build-and - (build-fixnums? (if maybe-e-new (list e-i maybe-e-new) (list e-i))) - e))))]))))])) - (define-syntax build-set-immutable! - (syntax-rules () - [(_ type-disp immutable-flag) - (lambda (e-v) - (bind #t (e-v) - `(set! ,(%mref ,e-v ,(constant type-disp)) - ,(%inline logor - ,(%mref ,e-v ,(constant type-disp)) - (immediate ,(constant immutable-flag))))))])) - (define inline-args-limit (constant inline-args-limit)) - (define reduce-equality - (lambda (src sexpr moi e1 e2 e*) - (and (fx<= (length e*) (fx- inline-args-limit 2)) - (bind #t (e1) - (bind #f (e2) - (list-bind #f (e*) - (let compare ([src src] [e2 e2] [e* e*]) - (if (null? e*) - (moi src sexpr (list e1 e2)) - `(if ,(moi src sexpr (list e1 e2)) - ,(compare #f (car e*) (cdr e*)) - (quote #f)))))))))) - (define reduce-inequality - (lambda (src sexpr moi e1 e2 e*) - (and (fx<= (length e*) (fx- inline-args-limit 2)) - (let f ([e2 e2] [e* e*] [re* '()]) - (if (null? e*) - (bind #f ([e2 e2]) - (let compare ([src src] [e* (cons e1 (reverse (cons e2 re*)))]) - (let ([more-args (cddr e*)]) - (if (null? more-args) - (moi src sexpr e*) - `(if ,(moi src sexpr (list (car e*) (cadr e*))) - ,(compare #f (cdr e*)) - (quote #f)))))) - (bind #t ([e2 e2]) (f (car e*) (cdr e*) (cons e2 re*)))))))) - (define reduce ; left associative as required for, e.g., fx- - (lambda (src sexpr moi e e*) - (and (fx<= (length e*) (fx- inline-args-limit 1)) - (bind #f (e) - (list-bind #f ([e* e*]) - (let reduce ([src src] [e e] [e* e*]) - (if (null? e*) - e - (reduce #f (moi src sexpr (list e (car e*))) (cdr e*))))))))) - (define reduce-fp-compare ; suitable for arguments known or assumed to produce flonums - (lambda (reduce) - (lambda (src sexpr moi e1 e2 e*) - (and (fx<= (length e*) (fx- inline-args-limit 2)) - (bind #t fp (e1) - (bind #f fp (e2) - (list-bind #f fp (e*) - (reduce src sexpr moi e1 e2 e*)))))))) - (define reduce-fp ; specialized reducer supports unboxing for nesting - (lambda (src sexpr level name e e*) - (and (fx<= (length e*) (fx- inline-args-limit 1)) - (let ([pr (lookup-primref level name)]) - (let reduce ([e e] [src src] [sexpr sexpr] [e* e*]) - (if (null? e*) - e - (reduce `(call ,(make-info-call src sexpr #f #f #f) #f ,pr ,e ,(car e*)) - #f #f (cdr e*)))))))) - (module (relop-length RELOP< RELOP<= RELOP= RELOP>= RELOP>) - (define RELOP< -2) - (define RELOP<= -1) - (define RELOP= 0) - (define RELOP>= 1) - (define RELOP> 2) - (define (mirror op) (fx- op)) - (define go - (lambda (op e n) - (let f ([n n] [e e]) - (if (fx= n 0) - (cond - [(or (eqv? op RELOP=) (eqv? op RELOP<=)) (build-null? e)] - [(eqv? op RELOP<) `(seq ,e (quote #f))] - [(eqv? op RELOP>) (build-not (build-null? e))] - [(eqv? op RELOP>=) `(seq ,e (quote #t))] - [else (sorry! 'relop-length "unexpected op ~s" op)]) - (cond - [(or (eqv? op RELOP=) (eqv? op RELOP>)) - (bind #t (e) - (build-and - (build-not (build-null? e)) - (f (fx- n 1) (build-cdr e))))] - [(eqv? op RELOP<) - (if (fx= n 1) - (build-null? e) - (bind #t (e) - (build-simple-or - (build-null? e) - (f (fx- n 1) (build-cdr e)))))] - [(eqv? op RELOP<=) - (bind #t (e) - (build-simple-or - (build-null? e) - (f (fx- n 1) (build-cdr e))))] - [(eqv? op RELOP>=) - (if (fx= n 1) - (build-not (build-null? e)) - (bind #t (e) - (build-and - (build-not (build-null? e)) - (f (fx- n 1) (build-cdr e)))))] - [else (sorry! 'relop-length "unexpected op ~s" op)]))))) - (define relop-length1 - (lambda (op e n) - (nanopass-case (L7 Expr) e - [(call ,info ,mdcl ,pr ,e) - (guard (and (eq? (primref-name pr) 'length) (all-set? (prim-mask unsafe) (primref-flags pr)))) - (go op e n)] - [else #f]))) - (define relop-length2 - (lambda (op e1 e2) - (nanopass-case (L7 Expr) e2 - [(quote ,d) (and (fixnum? d) (fx<= 0 d 4) (relop-length1 op e1 d))] - [else #f]))) - (define relop-length - (case-lambda - [(op e) (relop-length1 op e 0)] - [(op e1 e2) (or (relop-length2 op e1 e2) (relop-length2 (mirror op) e2 e1))]))) - (define make-ftype-pointer-equal? - (lambda (e1 e2) - (bind #f (e1 e2) - (%inline eq? - ,(%mref ,e1 ,(constant record-data-disp)) - ,(%mref ,e2 ,(constant record-data-disp)))))) - (define make-ftype-pointer-null? - (lambda (e) - (%inline eq? - ,(%mref ,e ,(constant record-data-disp)) - (immediate 0)))) - (define eqvop-null-fptr - (lambda (e1 e2) - (nanopass-case (L7 Expr) e1 - [(call ,info ,mdcl ,pr ,e1) - (and - (eq? (primref-name pr) 'ftype-pointer-address) - (all-set? (prim-mask unsafe) (primref-flags pr)) - (nanopass-case (L7 Expr) e2 - [(quote ,d) - (and (eqv? d 0) (make-ftype-pointer-null? e1))] - [(call ,info ,mdcl ,pr ,e2) - (and (eq? (primref-name pr) 'ftype-pointer-address) - (all-set? (prim-mask unsafe) (primref-flags pr)) - (make-ftype-pointer-equal? e1 e2))] - [else #f]))] - [(quote ,d) - (and (eqv? d 0) - (nanopass-case (L7 Expr) e2 - [(call ,info ,mdcl ,pr ,e2) - (and (eq? (primref-name pr) 'ftype-pointer-address) - (all-set? (prim-mask unsafe) (primref-flags pr)) - (make-ftype-pointer-null? e2))] - [else #f]))] - [else #f]))) - (define-inline 2 values - [(e) (ensure-single-valued e)] - [e* `(values ,(make-info-call src sexpr #f #f #f) ,e* ...)]) - (define-inline 2 $value - [(e) (ensure-single-valued e #f)]) - (define-inline 2 eq? - [(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))]) - (let () - (define (zgo src sexpr e e1 e2 r6rs?) - (build-simple-or - (%inline eq? ,e (immediate 0)) - `(if ,(build-fixnums? (list e)) - ,(%constant sfalse) - ,(if r6rs? - (build-libcall #t src sexpr fx=? e1 e2) - (build-libcall #t src sexpr fx= e1 e2))))) - (define (go src sexpr e1 e2 r6rs?) - (or (relop-length RELOP= e1 e2) - (cond - [(constant? (lambda (x) (eqv? x 0)) e1) - (bind #t (e2) (zgo src sexpr e2 e1 e2 r6rs?))] - [(constant? (lambda (x) (eqv? x 0)) e2) - (bind #t (e1) (zgo src sexpr e1 e1 e2 r6rs?))] - [else (bind #t (e1 e2) - `(if ,(build-fixnums? (list e1 e2)) - ,(%inline eq? ,e1 ,e2) - ,(if r6rs? - (build-libcall #t src sexpr fx=? e1 e2) - (build-libcall #t src sexpr fx= e1 e2))))]))) - (define-inline 2 fx= - [(e1 e2) (go src sexpr e1 e2 #f)] - [(e1 . e*) #f]) - (define-inline 2 fx=? - [(e1 e2) (go src sexpr e1 e2 #t)] - [(e1 e2 . e*) #f])) - (let () ; level 2 fx<, fx<?, etc. - (define-syntax fx-pred - (syntax-rules () - [(_ op r6rs:op length-op inline-op) - (let () - (define (go src sexpr e1 e2 r6rs?) - (or (relop-length length-op e1 e2) - (bind #t (e1 e2) - `(if ,(build-fixnums? (list e1 e2)) - ,(%inline inline-op ,e1 ,e2) - ,(if r6rs? - (build-libcall #t src sexpr r6rs:op e1 e2) - (build-libcall #t src sexpr op e1 e2)))))) - (define-inline 2 op - [(e1 e2) (go src sexpr e1 e2 #f)] - ; TODO: 3-operand case requires 3-operand library routine - #;[(e1 e2 e3) (go3 src sexpr e1 e2 e3 #f)] - [(e1 . e*) #f]) - (define-inline 2 r6rs:op - [(e1 e2) (go src sexpr e1 e2 #t)] - ; TODO: 3-operand case requires 3-operand library routine - #; [(e1 e2 e3) (go3 src sexpr e1 e2 e3 #t)] - [(e1 e2 . e*) #f]))])) - (fx-pred fx< fx<? RELOP< <) - (fx-pred fx<= fx<=? RELOP<= <=) - (fx-pred fx>= fx>=? RELOP>= >=) - (fx-pred fx> fx>? RELOP> >)) - (let () ; level 3 fx=, fx=?, etc. - (define-syntax fx-pred - (syntax-rules () - [(_ op r6rs:op length-op inline-op) - (let () - (define (go e1 e2) - (or (relop-length length-op e1 e2) - (%inline inline-op ,e1 ,e2))) - (define reducer - (if (eq? 'inline-op 'eq?) - reduce-equality - reduce-inequality)) - (define-inline 3 op - [(e) `(seq ,(ensure-single-valued e) ,(%constant strue))] - [(e1 e2) (go e1 e2)] - [(e1 e2 . e*) (reducer src sexpr moi e1 e2 e*)]) - (define-inline 3 r6rs:op - [(e1 e2) (go e1 e2)] - [(e1 e2 . e*) (reducer src sexpr moi e1 e2 e*)]))])) - (fx-pred fx< fx<? RELOP< <) - (fx-pred fx<= fx<=? RELOP<= <=) - (fx-pred fx= fx=? RELOP= eq?) - (fx-pred fx>= fx>=? RELOP>= >=) - (fx-pred fx> fx>? RELOP> >)) - (let () ; level 3 fxlogand, ... - (define-syntax fxlogop - (syntax-rules () - [(_ op inline-op base) - (define-inline 3 op - [() `(immediate ,(fix base))] - [(e) (ensure-single-valued e)] - [(e1 e2) (%inline inline-op ,e1 ,e2)] - [(e1 . e*) (reduce src sexpr moi e1 e*)])])) - (fxlogop fxlogand logand -1) - (fxlogop fxand logand -1) - (fxlogop fxlogor logor 0) - (fxlogop fxlogior logor 0) - (fxlogop fxior logor 0) - (fxlogop fxlogxor logxor 0) - (fxlogop fxxor logxor 0)) - (let () - (define log-partition - (lambda (p base e*) - (let loop ([e* e*] [n base] [nc* '()]) - (if (null? e*) - (if (and (fixnum? n) (fx= n base) (not (null? nc*))) - (values (car nc*) (cdr nc*) nc*) - (values `(immediate ,(fix n)) nc* nc*)) - (let ([e (car e*)]) - (if (fixnum-constant? e) - (let ([m (constant-value e)]) - (loop (cdr e*) (if n (p n m) m) nc*)) - (loop (cdr e*) n (cons e nc*)))))))) - (let () ; level 2 fxlogor, fxlogior, fxor - (define-syntax fxlogorop - (syntax-rules () - [(_ op) - (let () - (define (go src sexpr e*) - (and (fx<= (length e*) inline-args-limit) - (list-bind #t (e*) - (let-values ([(e e* nc*) (log-partition logor 0 e*)]) - (bind #t ([t (fold-left (lambda (e1 e2) (%inline logor ,e1 ,e2)) e e*)]) - `(if ,(%type-check mask-fixnum type-fixnum ,t) - ,t - ,(case (length nc*) - [(1) (build-libcall #t src sexpr op (car nc*) `(immediate ,(fix 0)))] - [(2) (build-libcall #t src sexpr op (car nc*) (cadr nc*))] - ; TODO: need fxargerr library routine w/who arg & rest interface - [else `(call ,(make-info-call src sexpr #f #t #t) #f ,(Symref 'op) ,nc* (... ...))]))))))) ; NB: should be error call---but is it? - (define-inline 2 op - [() `(immediate ,(fix 0))] - [e* (go src sexpr e*)]))])) - (fxlogorop fxlogor) - (fxlogorop fxlogior) - (fxlogorop fxior)) - (let () ; level 2 fxlogand, ... - (define-syntax fxlogop - (syntax-rules () - [(_ op inline-op base) - (define-inline 2 op - [() `(immediate ,(fix base))] - [e* (and (fx<= (length e*) (fx- inline-args-limit 1)) - (list-bind #t (e*) - ;; NB: using inline-op here because it works when target's - ;; NB: fixnum range is larger than the host's fixnum range - ;; NB: during cross compile - (let-values ([(e e* nc*) (log-partition inline-op base e*)]) - `(if ,(build-fixnums? nc*) - ,(fold-left (lambda (e1 e2) (%inline inline-op ,e1 ,e2)) e e*) - ; TODO: need fxargerr library routine w/who arg & rest interface - ,(case (length nc*) - [(1) (build-libcall #t src sexpr op (car nc*) `(immediate ,(fix 0)))] - [(2) (build-libcall #t src sexpr op (car nc*) (cadr nc*))] - ; TODO: need fxargerr library routine w/who arg & rest interface - [else `(call ,(make-info-call src sexpr #f #t #t) #f ,(Symref 'op) ,nc* (... ...))])))))])])) ; NB: should be error call---but is it? - (fxlogop fxlogand logand -1) - (fxlogop fxand logand -1) - (fxlogop fxlogxor logxor 0) - (fxlogop fxxor logxor 0))) - (define-inline 3 fxlogtest - [(e1 e2) (%inline logtest ,e1 ,e2)]) - (define-inline 2 fxlogtest - [(e1 e2) - (bind #t (e1 e2) - `(if ,(build-fixnums? (list e1 e2)) - ,(%inline logtest ,e1 ,e2) - ,(build-libcall #t src sexpr fxlogtest e1 e2)))]) - (let () - (define xorbits (lognot (constant mask-fixnum))) - (define-syntax fxlognotop - (syntax-rules () - [(_ name) - (begin - (define-inline 3 name - [(e) (%inline logxor ,e (immediate ,xorbits))]) - (define-inline 2 name - [(e) (bind #t (e) - `(if ,(%type-check mask-fixnum type-fixnum ,e) - ,(%inline logxor ,e (immediate ,xorbits)) - ,(build-libcall #t src sexpr name e)))]))])) - (fxlognotop fxlognot) - (fxlognotop fxnot)) - (define-inline 3 $fxu< - [(e1 e2) (or (relop-length RELOP< e1 e2) - (%inline u< ,e1 ,e2))]) - (define-inline 3 fx+ - [() `(immediate 0)] - [(e) (ensure-single-valued e)] - [(e1 e2) (%inline + ,e1 ,e2)] - [(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+? - [(e1 e2) - (let ([Lfalse (make-local-label 'Lfalse)]) - (bind #t (e1 e2) - `(if ,(build-fixnums? (list e1 e2)) - ,(bind #f ([t (%inline +/ovfl ,e1 ,e2)]) - `(if (inline ,(make-info-condition-code 'overflow #f #t) ,%condition-code) - (label ,Lfalse ,(%constant sfalse)) - ,t)) - (goto ,Lfalse))))]) - (let () - (define (go src sexpr e1 e2) - (let ([Llib (make-local-label 'Llib)]) - (bind #t (e1 e2) - `(if ,(build-fixnums? (list e1 e2)) - ,(bind #f ([t (%inline +/ovfl ,e1 ,e2)]) - `(if (inline ,(make-info-condition-code 'overflow #f #t) ,%condition-code) - (label ,Llib ,(build-libcall #t src sexpr fx+ e1 e2)) - ,t)) - (goto ,Llib))))) - (define-inline 2 fx+ - [() `(immediate 0)] - [(e) - (bind #t (e) - `(if ,(%type-check mask-fixnum type-fixnum ,e) - ,e - ,(build-libcall #t #f sexpr fx+ e `(immediate ,(fix 0)))))] - [(e1 e2) (go src sexpr e1 e2)] - ; TODO: 3-operand case requires 3-operand library routine - #;[(e1 e2 e3) - (let ([Llib (make-local-label 'Llib)]) - (bind #t (e1 e2 e3) - `(if ,(build-fixnums? (list e1 e2 e3)) - ,(bind #t ([t (%inline +/ovfl ,e1 ,e2)]) - `(if (inline ,(make-info-condition-code 'overflow #f #t) ,%condition-code) - (label ,Llib ,(build-libcall #t src sexpr fx+ e1 e2 e3)) - ,(bind #t ([t (%inline +/ovfl ,t ,e3)]) - `(if (inline ,(make-info-condition-code 'overflow #f #t) ,%condition-code) - (goto ,Llib) - ,t)))) - (goto ,Llib))))] - [(e1 . e*) #f]) - (define-inline 2 r6rs:fx+ ; limited to two arguments - [(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)] - [(e1 e2) (%inline - ,e1 ,e2)] - [(e1 . e*) (reduce src sexpr moi e1 e*)]) - (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-? - [(e1 e2) - (let ([Lfalse (make-local-label 'Lfalse)]) - (bind #t (e1 e2) - `(if ,(build-fixnums? (list e1 e2)) - ,(bind #f ([t (%inline -/ovfl ,e1 ,e2)]) - `(if (inline ,(make-info-condition-code 'overflow #f #t) ,%condition-code) - (label ,Lfalse ,(%constant sfalse)) - ,t)) - (goto ,Lfalse))))]) - (let () - (define (go src sexpr e1 e2) - (let ([Llib (make-local-label 'Llib)]) - (bind #t (e1 e2) - `(if ,(build-fixnums? (list e1 e2)) - ,(bind #t ([t (%inline -/ovfl ,e1 ,e2)]) - `(if (inline ,(make-info-condition-code 'overflow #f #t) ,%condition-code) - (label ,Llib ,(build-libcall #t src sexpr fx- e1 e2)) - ,t)) - (goto ,Llib))))) - (define-inline 2 fx- - [(e) (go src sexpr `(immediate ,(fix 0)) e)] - [(e1 e2) (go src sexpr e1 e2)] - ; TODO: 3-operand case requires 3-operand library routine - #;[(e1 e2 e3) - (let ([Llib (make-local-label 'Llib)]) - (bind #t (e1 e2 e3) - `(if ,(build-fixnums? (list e1 e2 e3)) - ,(bind #t ([t (%inline -/ovfl ,e1 ,e2)]) - `(if (inline ,(make-info-condition-code 'overflow #f #t) ,%condition-code) - (label ,Llib ,(build-libcall #t src sexpr fx- e1 e2 e3)) - ,(bind #t ([t (%inline -/ovfl ,t ,e3)]) - `(if (inline ,(make-info-condition-code 'overflow #f #t) ,%condition-code) - (goto ,Llib) - ,t)))) - (goto ,Llib))))] - [(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)]) - (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) - `(if ,(build-fixnums? (list e)) - ,(bind #t ([t (%inline -/ovfl ,e (immediate ,(fix 1)))]) - `(if (inline ,(make-info-condition-code 'overflow #f #t) ,%condition-code) - (label ,Llib ,(build-libcall #t src sexpr fx1- e)) - ,t)) - (goto ,Llib))))]) - (define-inline 2 fx1+ - [(e) (let ([Llib (make-local-label 'Llib)]) - (bind #t (e) - `(if ,(build-fixnums? (list e)) - ,(bind #f ([t (%inline +/ovfl ,e (immediate ,(fix 1)))]) - `(if (inline ,(make-info-condition-code 'overflow #f #t) ,%condition-code) - (label ,Llib ,(build-libcall #t src sexpr fx1+ e)) - ,t)) - (goto ,Llib))))]) - - (let () - (define fixnum-powers-of-two - (let f ([m 2] [e 1]) - (if (<= m (constant most-positive-fixnum)) - (cons (cons m e) (f (* m 2) (fx+ e 1))) - '()))) - (define-inline 3 fxdiv - [(e1 e2) - (nanopass-case (L7 Expr) e2 - [(quote ,d) - (let ([a (assv d fixnum-powers-of-two)]) - (and a - (%inline logand - ,(%inline sra ,e1 (immediate ,(cdr a))) - (immediate ,(- (constant fixnum-factor))))))] - [else #f])]) - (define-inline 3 fxmod - [(e1 e2) - (nanopass-case (L7 Expr) e2 - [(quote ,d) - (let ([a (assv d fixnum-powers-of-two)]) - (and a (%inline logand ,e1 (immediate ,(fix (- d 1))))))] - [else #f])]) - (let () - (define (build-fx* e1 e2 ovfl?) - (define (fx*-constant e n) - (if ovfl? - (%inline */ovfl ,e (immediate ,n)) - (cond - [(eqv? n 1) e] - [(eqv? n -1) (%inline - (immediate 0) ,e)] - [(eqv? n 2) (%inline sll ,e (immediate 1))] - [(eqv? n 3) - (bind #t (e) - (%inline + - ,(%inline + ,e ,e) - ,e))] - [(eqv? n 10) - (bind #t (e) - (%inline + - ,(%inline + - ,(%inline sll ,e (immediate 3)) - ,e) - ,e))] - [(assv n fixnum-powers-of-two) => - (lambda (a) (%inline sll ,e (immediate ,(cdr a))))] - [else (%inline * ,e (immediate ,n))]))) - (nanopass-case (L7 Expr) e2 - [(quote ,d) (guard (target-fixnum? d)) (fx*-constant e1 d)] - [else - (nanopass-case (L7 Expr) e1 - [(quote ,d) (guard (target-fixnum? d)) (fx*-constant e2 d)] - [else - (let ([t (make-tmp 't 'uptr)]) - `(let ([,t ,(build-unfix e2)]) - ,(if ovfl? - (%inline */ovfl ,e1 ,t) - (%inline * ,e1 ,t))))])])) - (define-inline 3 fx* - [() `(immediate ,(fix 1))] - [(e) (ensure-single-valued e)] - [(e1 e2) (build-fx* e1 e2 #f)] - [(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)]) - (bind #t (e1 e2) - `(if ,(build-fixnums? (list e1 e2)) - ,(bind #t ([t (build-fx* e1 e2 #t)]) - `(if (inline ,(make-info-condition-code 'multiply-overflow #f #t) ,%condition-code) - (label ,Llib ,(build-libcall #t src sexpr fx* e1 e2)) - ,t)) - (goto ,Llib))))) - (define-inline 2 fx* - [() `(immediate ,(fix 1))] - [(e) - (bind #t (e) - `(if ,(%type-check mask-fixnum type-fixnum ,e) - ,e - ,(build-libcall #t src sexpr fx* e `(immediate ,(fix 0)))))] - [(e1 e2) (go src sexpr e1 e2)] - ; TODO: 3-operand case requires 3-operand library routine - #;[(e1 e2 e3) - (let ([Llib (make-local-label 'Llib)]) - (bind #t (e1 e2 e3) - `(if ,(build-fixnums? (list e1 e2 e3)) - ,(bind #t ([t (build-fx* e1 e2 #t)]) - `(if (inline ,(make-info-condition-code 'overflow #f #t) ,%condition-code) - (label ,Llib ,(build-libcall #t src sexpr fx* e1 e2 e3)) - ,(bind #t ([t (build-fx* t e3 #t)]) - `(if (inline ,(make-info-condition-code 'overflow #f #t) ,%condition-code) - (goto ,Llib) - ,t)))) - (goto ,Llib))))] - [(e1 . e*) #f]) - (define-inline 2 r6rs:fx* ; limited to two arguments - [(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) - (bind #t (e1) - (build-fix - (%inline sra - ,(%inline + ,e1 - ,(%inline srl - ,(if (fx= p2 1) - e1 - (%inline sra ,e1 (immediate ,(fx- p2 1)))) - (immediate ,(fx- (constant fixnum-bits) p2)))) - (immediate ,(fx+ p2 (constant fixnum-offset)))))))) - - (define build-fx/ - (lambda (src sexpr e1 e2) - (or (nanopass-case (L7 Expr) e2 - [(quote ,d) - (let ([a (assv d fixnum-powers-of-two)]) - (and a (build-fx/p2 e1 (cdr a))))] - [else #f]) - (if (constant integer-divide-instruction) - (build-fix (%inline / ,e1 ,e2)) - `(call ,(make-info-call src sexpr #f #f #f) #f - ,(lookup-primref 3 '$fx/) - ,e1 ,e2))))) - - (define-inline 3 fx/ - [(e) (build-fx/ src sexpr `(quote 1) e)] - [(e1 e2) (build-fx/ src sexpr e1 e2)] - [(e1 . e*) (reduce src sexpr moi e1 e*)]) - - (define-inline 3 fxquotient - [(e) (build-fx/ src sexpr `(quote 1) e)] - [(e1 e2) (build-fx/ src sexpr e1 e2)] - [(e1 . e*) (reduce src sexpr moi e1 e*)]) - - (define-inline 3 fxremainder - [(e1 e2) - (bind #t (e1 e2) - (%inline - ,e1 - ,(build-fx* - (build-fx/ src sexpr e1 e2) - e2 #f)))])) - (let () - (define-syntax build-fx - (lambda (x) - (syntax-case x () - [(_ op a1 a2) - #`(%inline op - #,(if (number? (syntax->datum #'a1)) - #`(immediate a1) - #`,a1) - #,(if (number? (syntax->datum #'a2)) - #`(immediate a2) - #`,a2))]))) - (define (build-popcount16 e) - (constant-case popcount-instruction - [(#t) (build-fix (%inline popcount ,e))] ; no unfix needed, since not specialized to 16-bit - [else - (let ([x (make-tmp 'x 'uptr)] - [x2 (make-tmp 'x2 'uptr)] - [x3 (make-tmp 'x3 'uptr)] - [x4 (make-tmp 'x4 'uptr)]) - `(let ([,x ,(build-unfix e)]) - (let ([,x2 ,(build-fx - x (build-fx logand (build-fx srl x 1) #x5555))]) - (let ([,x3 ,(build-fx + (build-fx logand x2 #x3333) (build-fx logand (build-fx srl x2 2) #x3333))]) - (let ([,x4 ,(build-fx logand (build-fx + x3 (build-fx srl x3 4)) #x0f0f)]) - ,(build-fix (build-fx logand (build-fx + x4 (build-fx srl x4 8)) #x1f)))))))])) - (define (build-popcount32 e) - (constant-case popcount-instruction - [(#t) (build-fix (%inline popcount ,e))] ; no unfix needed, since not specialized to 32-bit - [else - (let ([x (make-tmp 'x 'uptr)] - [x2 (make-tmp 'x2 'uptr)] - [x3 (make-tmp 'x3 'uptr)] - [x4 (make-tmp 'x4 'uptr)]) - `(let ([,x ,(build-unfix e)]) - (let ([,x2 ,(build-fx - x (build-fx logand (build-fx srl x 1) #x55555555))]) - (let ([,x3 ,(build-fx + (build-fx logand x2 #x33333333) (build-fx logand (build-fx srl x2 2) #x33333333))]) - (let ([,x4 ,(build-fx logand (build-fx + x3 (build-fx srl x3 4)) #x0f0f0f0f)]) - ,(build-fix (build-fx logand (build-fx srl (build-fx * x4 #x01010101) 24) #x3f)))))))])) - (define (build-popcount e) - (constant-case popcount-instruction - [(#t) (build-fix (%inline popcount ,e))] ; no unfix needed - [else - (constant-case ptr-bits - [(32) (build-popcount32 e)] - [(64) - (let ([x (make-tmp 'x 'uptr)] - [x2 (make-tmp 'x2 'uptr)] - [x3 (make-tmp 'x3 'uptr)] - [x4 (make-tmp 'x4 'uptr)] - [x5 (make-tmp 'x5 'uptr)]) - `(let ([,x ,e]) ; no unfix needed - (let ([,x2 ,(build-fx - x (build-fx logand (build-fx srl x 1) #x5555555555555555))]) - (let ([,x3 ,(build-fx + (build-fx logand x2 #x3333333333333333) (build-fx logand (build-fx srl x2 2) #x3333333333333333))]) - (let ([,x4 ,(build-fx logand (build-fx + x3 (build-fx srl x3 4)) #x0f0f0f0f0f0f0f0f)]) - (let ([,x5 ,(build-fx logand (build-fx + x4 (build-fx srl x4 8)) #x00ff00ff00ff00ff)]) - ,(build-fix (build-fx logand (build-fx srl (build-fx * x5 #x0101010101010101) 56) #x7f))))))))])])) - (define-inline 3 fxpopcount - [(e) - (bind #f (e) - (build-popcount e))]) - (define-inline 2 fxpopcount - [(e) - (bind #t (e) - `(if ,(build-and - (%type-check mask-fixnum type-fixnum ,e) - (%inline >= ,e (immediate ,0))) - ,(build-popcount e) - ,(build-libcall #t #f sexpr fxpopcount e)))]) - (define-inline 3 fxpopcount32 - [(e) - (bind #f (e) - (build-popcount32 e))]) - (define-inline 2 fxpopcount32 - [(e) - (bind #t (e) - `(if ,(constant-case ptr-bits - [(32) - (build-and (%type-check mask-fixnum type-fixnum ,e) - (%inline >= ,e (immediate ,0)))] - [(64) - (build-and (%type-check mask-fixnum type-fixnum ,e) - (%inline u< ,e (immediate ,(fix #x100000000))))]) - ,(build-popcount32 e) - ,(build-libcall #t #f sexpr fxpopcount32 e)))]) - (define-inline 3 fxpopcount16 - [(e) - (bind #f (e) - (build-popcount16 e))]) - (define-inline 2 fxpopcount16 - [(e) - (bind #f (e) - `(if ,(build-and - (%type-check mask-fixnum type-fixnum ,e) - (%inline u< ,e (immediate ,(fix #x10000)))) - ,(build-popcount16 e) - ,(build-libcall #t #f sexpr fxpopcount16 e)))])))) - (let () - (define do-fxsll - (lambda (e1 e2) - (nanopass-case (L7 Expr) e2 - [(quote ,d) - (%inline sll ,e1 (immediate ,d))] - [else - ; TODO: bind-uptr might be handy here and also a make-unfix - (let ([t (make-tmp 't 'uptr)]) - `(let ([,t ,(build-unfix e2)]) - ,(%inline sll ,e1 ,t)))]))) - (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) - (%inline logand - ,(nanopass-case (L7 Expr) e2 - [(quote ,d) - (%inline srl ,e1 (immediate ,d))] - [else - (let ([t (make-tmp 't 'uptr)]) - `(let ([,t ,(build-unfix e2)]) - ,(%inline srl ,e1 ,t)))]) - (immediate ,(fx- (constant fixnum-factor))))]) - (let () - (define do-fxsra - (lambda (e1 e2) - (%inline logand - ,(nanopass-case (L7 Expr) e2 - [(quote ,d) - (%inline sra ,e1 (immediate ,d))] - [else - (let ([t (make-tmp 't 'uptr)]) - `(let ([,t ,(build-unfix e2)]) - ,(%inline sra ,e1 ,t)))]) - (immediate ,(fx- (constant fixnum-factor)))))) - (define-inline 3 fxsra - [(e1 e2) (do-fxsra e1 e2)]) - (define-inline 3 fxarithmetic-shift-right - [(e1 e2) (do-fxsra e1 e2)])) - (let () - (define-syntax %safe-shift - (syntax-rules () - [(_ src sexpr op libcall e1 e2 ?size) - (let ([size ?size]) - (if (constant? (lambda (x) (and (fixnum? x) (fx<= 0 x (fx- size 1)))) e2) - (bind #t (e1 e2) - `(if ,(build-fixnums? (list e1)) - ,(%inline logand - ,(%inline op ,e1 (immediate ,(constant-value e2))) - (immediate ,(- (constant fixnum-factor)))) - ,(build-libcall #t src sexpr libcall e1 e2))) - (bind #t (e1 e2) - `(if ,(build-and - (build-fixnums? (list e1 e2)) - (%inline u< ,e2 (immediate ,(fix size)))) - ,(%inline logand - ,(%inline op ,e1 ,(build-unfix e2)) - (immediate ,(- (constant fixnum-factor)))) - ,(build-libcall #t src sexpr libcall e1 e2)))))])) - (define-inline 2 fxsrl - [(e1 e2) (%safe-shift src sexpr srl fxsrl e1 e2 (+ (constant fixnum-bits) 1))]) - (define-inline 2 fxsra - [(e1 e2) (%safe-shift src sexpr sra fxsra e1 e2 (+ (constant fixnum-bits) 1))]) - (define-inline 2 fxarithmetic-shift-right - [(e1 e2) (%safe-shift src sexpr sra fxarithmetic-shift-right e1 e2 (constant fixnum-bits))])) - (define-inline 3 fxarithmetic-shift - [(e1 e2) - (or (nanopass-case (L7 Expr) e2 - [(quote ,d) - (and (fixnum? d) - (if ($fxu< d (constant fixnum-bits)) - (%inline sll ,e1 (immediate ,d)) - (and (fx< (fx- (constant fixnum-bits)) d 0) - (%inline logand - ,(%inline sra ,e1 (immediate ,(fx- d))) - (immediate ,(- (constant fixnum-factor)))))))] - [else #f]) - (build-libcall #f src sexpr fxarithmetic-shift e1 e2))]) - (define-inline 2 fxarithmetic-shift - [(e1 e2) - (or (nanopass-case (L7 Expr) e2 - [(quote ,d) - (guard (fixnum? d) (fx< (fx- (constant fixnum-bits)) d 0)) - (bind #t (e1) - `(if ,(build-fixnums? (list e1)) - ,(%inline logand - ,(%inline sra ,e1 (immediate ,(fx- d))) - (immediate ,(- (constant fixnum-factor)))) - ,(build-libcall #t src sexpr fxarithmetic-shift e1 e2)))] - [else #f]) - (build-libcall #f src sexpr fxarithmetic-shift e1 e2))]) - (let () - (define dofxlogbit0 - (lambda (e1 e2) - (if (constant? (lambda (x) (and (fixnum? x) ($fxu< x (fx- (constant fixnum-bits) 1)))) e2) - (%inline logand ,e1 - (immediate ,(fix (lognot (ash 1 (constant-value e2)))))) - (%inline logand ,e1 - ,(%inline lognot - ,(%inline sll (immediate ,(fix 1)) - ,(build-unfix e2))))))) - (define dofxlogbit1 - (lambda (e1 e2) - (if (constant? (lambda (x) (and (fixnum? x) ($fxu< x (fx- (constant fixnum-bits) 1)))) e2) - (%inline logor ,e1 - (immediate ,(fix (ash 1 (constant-value e2))))) - (%inline logor ,e1 - ,(%inline sll (immediate ,(fix 1)) - ,(build-unfix e2)))))) - (define-inline 3 fxlogbit0 - [(e1 e2) (dofxlogbit0 e2 e1)]) - (define-inline 3 fxlogbit1 - [(e1 e2) (dofxlogbit1 e2 e1)]) - (define-inline 3 fxcopy-bit - [(e1 e2 e3) - ;; NB: even in the case where e3 is not known to be 0 or 1, seems like we could do better here. - (and (fixnum-constant? e3) - (case (constant-value e3) - [(0) (dofxlogbit0 e1 e2)] - [(1) (dofxlogbit1 e1 e2)] - [else #f]))])) - (let () - (define dofxlogbit0 - (lambda (e1 e2 libcall) - (if (constant? (lambda (x) (and (fixnum? x) ($fxu< x (fx- (constant fixnum-bits) 1)))) e2) - (bind #t (e1) - `(if ,(build-fixnums? (list e1)) - ,(%inline logand ,e1 - (immediate ,(fix (lognot (ash 1 (constant-value e2)))))) - ,(libcall e1 e2))) - (bind #t (e1 e2) - `(if ,(build-and - (build-fixnums? (list e1 e2)) - (%inline u< ,e2 (immediate ,(fix (fx- (constant fixnum-bits) 1))))) - ,(%inline logand ,e1 - ,(%inline lognot - ,(%inline sll (immediate ,(fix 1)) - ,(build-unfix e2)))) - ,(libcall e1 e2)))))) - (define dofxlogbit1 - (lambda (e1 e2 libcall) - (if (constant? (lambda (x) (and (fixnum? x) ($fxu< x (fx- (constant fixnum-bits) 1)))) e2) - (bind #t (e1) - `(if ,(build-fixnums? (list e1)) - ,(%inline logor ,e1 - (immediate ,(fix (ash 1 (constant-value e2))))) - ,(libcall e1 e2))) - (bind #t (e1 e2) - `(if ,(build-and - (build-fixnums? (list e1 e2)) - (%inline u< ,e2 (immediate ,(fix (fx- (constant fixnum-bits) 1))))) - ,(%inline logor ,e1 - ,(%inline sll (immediate ,(fix 1)) - ,(build-unfix e2))) - ,(libcall e1 e2)))))) - (define-inline 2 fxlogbit0 - [(e1 e2) (dofxlogbit0 e2 e1 - (lambda (e2 e1) - (build-libcall #t src sexpr fxlogbit0 e1 e2)))]) - (define-inline 2 fxlogbit1 - [(e1 e2) (dofxlogbit1 e2 e1 - (lambda (e2 e1) - (build-libcall #t src sexpr fxlogbit1 e1 e2)))]) - (define-inline 2 fxcopy-bit - [(e1 e2 e3) - (and (fixnum-constant? e3) - (case (constant-value e3) - [(0) (dofxlogbit0 e1 e2 - (lambda (e1 e2) - (build-libcall #t src sexpr fxcopy-bit e1 e2)))] - [(1) (dofxlogbit1 e1 e2 - (lambda (e1 e2) - (build-libcall #t src sexpr fxcopy-bit e1 e2)))] - [else #f]))])) - (define-inline 3 fxzero? - [(e) (or (relop-length RELOP= e) (%inline eq? ,e (immediate 0)))]) - (define-inline 3 fxpositive? - [(e) (or (relop-length RELOP> e) (%inline > ,e (immediate 0)))]) - (define-inline 3 fxnonnegative? - [(e) (or (relop-length RELOP>= e) (%inline >= ,e (immediate 0)))]) - (define-inline 3 fxnegative? - [(e) (or (relop-length RELOP< e) (%inline < ,e (immediate 0)))]) - (define-inline 3 fxnonpositive? - [(e) (or (relop-length RELOP<= e) (%inline <= ,e (immediate 0)))]) - (define-inline 3 fxeven? - [(e) (%inline eq? - ,(%inline logand ,e (immediate ,(fix 1))) - (immediate ,(fix 0)))]) - (define-inline 3 fxodd? - [(e) (%inline eq? - ,(%inline logand ,e (immediate ,(fix 1))) - (immediate ,(fix 1)))]) - - (define-inline 2 fxzero? - [(e) (or (relop-length RELOP= e) - (bind #t (e) - (build-simple-or - (%inline eq? ,e (immediate 0)) - `(if ,(build-fixnums? (list e)) - ,(%constant sfalse) - ,(build-libcall #t src sexpr fxzero? e)))))]) - (define-inline 2 fxpositive? - [(e) (or (relop-length RELOP> e) - (bind #t (e) - `(if ,(build-fixnums? (list e)) - ,(%inline > ,e (immediate 0)) - ,(build-libcall #t src sexpr fxpositive? e))))]) - (define-inline 2 fxnonnegative? - [(e) (or (relop-length RELOP>= e) - (bind #t (e) - `(if ,(build-fixnums? (list e)) - ,(%inline >= ,e (immediate 0)) - ,(build-libcall #t src sexpr fxnonnegative? e))))]) - (define-inline 2 fxnegative? - [(e) (or (relop-length RELOP< e) - (bind #t (e) - `(if ,(build-fixnums? (list e)) - ,(%inline < ,e (immediate 0)) - ,(build-libcall #t src sexpr fxnegative? e))))]) - (define-inline 2 fxnonpositive? - [(e) (or (relop-length RELOP<= e) - (bind #t (e) - `(if ,(build-fixnums? (list e)) - ,(%inline <= ,e (immediate 0)) - ,(build-libcall #t src sexpr fxnonpositive? e))))]) - (define-inline 2 fxeven? - [(e) (bind #t (e) - `(if ,(build-fixnums? (list e)) - ,(%inline eq? - ,(%inline logand ,e (immediate ,(fix 1))) - (immediate ,(fix 0))) - ,(build-libcall #t src sexpr fxeven? e)))]) - (define-inline 2 fxodd? - [(e) (bind #t (e) - `(if ,(build-fixnums? (list e)) - ,(%inline eq? - ,(%inline logand ,e (immediate ,(fix 1))) - (immediate ,(fix 1))) - ,(build-libcall #t src sexpr fxodd? e)))]) - (let () - (define dofxlogbit? - (lambda (e1 e2) - (cond - [(constant? (lambda (x) (and (fixnum? x) (fx<= 0 x (fx- (constant fixnum-bits) 2)))) e1) - (%inline logtest ,e2 (immediate ,(fix (ash 1 (constant-value e1)))))] - [(constant? (lambda (x) (and (target-fixnum? x) (> x (fx- (constant fixnum-bits) 2)))) e1) - (%inline < ,e2 (immediate ,(fix 0)))] - [(fixnum-constant? e2) - (bind #t (e1) - `(if ,(%inline < (immediate ,(fix (fx- (constant fixnum-bits) 2))) ,e1) - ,(if (< (constant-value e2) 0) (%constant strue) (%constant sfalse)) - ,(%inline logtest - ,(%inline sra ,e2 ,(build-unfix e1)) - (immediate ,(fix 1)))))] - [else - (bind #t (e1 e2) - `(if ,(%inline < (immediate ,(fix (fx- (constant fixnum-bits) 2))) ,e1) - ,(%inline < ,e2 (immediate ,(fix 0))) - ,(%inline logtest - ,(%inline sra ,e2 ,(build-unfix e1)) - (immediate ,(fix 1)))))]))) - - (define-inline 3 fxbit-set? - [(e1 e2) (dofxlogbit? e2 e1)]) - - (define-inline 3 fxlogbit? - [(e1 e2) (dofxlogbit? e1 e2)])) - - (let () - (define dofxlogbit? - (lambda (e1 e2 libcall) - (cond - [(constant? (lambda (x) (and (fixnum? x) (fx<= 0 x (fx- (constant fixnum-bits) 2)))) e1) - (bind #t (e2) - `(if ,(build-fixnums? (list e2)) - ,(%inline logtest ,e2 - (immediate ,(fix (ash 1 (constant-value e1))))) - ,(libcall e1 e2)))] - [(constant? (lambda (x) (and (target-fixnum? x) (> x (fx- (constant fixnum-bits) 2)))) e1) - (bind #t (e2) - `(if ,(build-fixnums? (list e2)) - ,(%inline < ,e2 (immediate ,(fix 0))) - ,(libcall e1 e2)))] - [else - (bind #t (e1 e2) - `(if ,(build-and - (build-fixnums? (list e1 e2)) - (%inline u< ,e1 (immediate ,(fix (constant fixnum-bits))))) - ,(%inline logtest - ,(%inline sra ,e2 ,(build-unfix e1)) - (immediate ,(fix 1))) - ,(libcall e1 e2)))]))) - - (define-inline 2 fxbit-set? - [(e1 e2) (dofxlogbit? e2 e1 - (lambda (e2 e1) - (build-libcall #t src sexpr fxbit-set? e1 e2)))]) - (define-inline 2 fxlogbit? - [(e1 e2) (dofxlogbit? e1 e2 - (lambda (e1 e2) - (build-libcall #t src sexpr fxlogbit? e1 e2)))])) - - ; can avoid if in fxabs with: - ; t = sra(x, k) ; where k is ptr-bits - 1 - ; ; t is now -1 if x's sign bit set, otherwise 0 - ; x = xor(x, t) ; logical not if x negative, otherwise leave x alone - ; x = x - t ; add 1 to complete two's complement negation if - ; ; x was negative, otherwise leave x alone - ; tests on i3le indicate that the if is actually faster, even in a loop - ; where input alternates between positive and negative to defeat branch - ; prediction. - (define-inline 3 fxabs - [(e) (bind #t (e) - `(if ,(%inline < ,e (immediate ,(fix 0))) - ,(%inline - (immediate ,(fix 0)) ,e) - ,e))]) - - ;(define-inline 3 min ; needs library min - ; ; must take care to be inexactness-preserving - ; [(e0) e0] - ; [(e0 e1) - ; (bind #t (e0 e1) - ; `(if ,(build-fixnums? (list e0 e1)) - ; (if ,(%inline < ,e0 ,e1) ,e0 ,e1) - ; ,(build-libcall #t src sexpr min e0 e1)))] - ; [(e0 . e*) (reduce src sexpr moi e1 e*)]) - ; - ;(define-inline 3 max ; needs library max - ; ; must take care to be inexactness-preserving - ; [(e0) e0] - ; [(e0 e1) - ; (bind #t (e0 e1) - ; `(if ,(build-fixnums? (list e0 e1)) - ; (if ,(%inline < ,e0 ,e1) ,e0 ,e1) - ; ,(build-libcall #t src sexpr max e0 e1)))] - ; [(e1 . e*) (reduce src sexpr moi e1 e*)]) - - (define-inline 3 fxmin - [(e) (ensure-single-valued e)] - [(e1 e2) (bind #t (e1 e2) - `(if ,(%inline < ,e1 ,e2) - ,e1 - ,e2))] - [(e1 . e*) (reduce src sexpr moi e1 e*)]) - - (define-inline 3 fxmax - [(e) (ensure-single-valued e)] - [(e1 e2) (bind #t (e1 e2) - `(if ,(%inline < ,e2 ,e1) - ,e1 - ,e2))] - [(e1 . e*) (reduce src sexpr moi e1 e*)]) - - (define-inline 3 fxif - [(e1 e2 e3) - (bind #t (e1) - (%inline logor - ,(%inline logand ,e2 ,e1) - ,(%inline logand ,e3 - ,(%inline lognot ,e1))))]) - - (define-inline 3 fxbit-field - [(e1 e2 e3) - (and (constant? fixnum? e2) (constant? fixnum? e3) - (let ([start (constant-value e2)] [end (constant-value e3)]) - (if (fx= end start) - (%seq ,e1 (immediate ,(fix 0))) - (and (and (fx>= start 0) (fx> end start) (fx< end (constant fixnum-bits))) - (extract-unsigned-bitfield #f start end e1)))))]) - - (define-inline 3 fxcopy-bit-field - [(e1 e2 e3 e4) - (and (constant? fixnum? e2) (constant? fixnum? e3) - (let ([start (constant-value e2)] [end (constant-value e3)]) - (if (fx= end start) - e1 - (and (and (fx>= start 0) (fx> end start) (fx< end (constant fixnum-bits))) - (insert-bitfield #f start end (constant fixnum-bits) e1 e4)))))]) - - ;; could be done with one mutable variable instead of two, but this seems to generate - ;; the same code as the existing compiler - (define-inline 3 fxlength - [(e) - (let ([t (make-assigned-tmp 't 'uptr)] [result (make-assigned-tmp 'result)]) - `(let ([,t ,(build-unfix e)]) - (seq - (if ,(%inline < ,t (immediate 0)) - (set! ,t ,(%inline lognot ,t)) - ,(%constant svoid)) - (let ([,result (immediate ,(fix 0))]) - ,((lambda (body) - (constant-case fixnum-bits - [(30) body] - [(61) - `(seq - (if ,(%inline < ,t (immediate #x100000000)) - ,(%constant svoid) - (seq - (set! ,t ,(%inline srl ,t (immediate 32))) - (set! ,result - ,(%inline + ,result (immediate ,(fix 32)))))) - ,body)])) - (%seq - (if ,(%inline < ,t (immediate #x10000)) - ,(%constant svoid) - (seq - (set! ,t ,(%inline srl ,t (immediate 16))) - (set! ,result ,(%inline + ,result (immediate ,(fix 16)))))) - (if ,(%inline < ,t (immediate #x100)) - ,(%constant svoid) - (seq - (set! ,t ,(%inline srl ,t (immediate 8))) - (set! ,result ,(%inline + ,result (immediate ,(fix 8)))))) - ,(%inline + ,result - (inline ,(make-info-load 'unsigned-8 #f) ,%load - ,(%tc-ref fxlength-bv) ,t - ,(%constant bytevector-data-disp)))))))))]) - - (define-inline 3 fxfirst-bit-set - [(e) - (let ([t (make-assigned-tmp 't 'uptr)] [result (make-assigned-tmp 'result)]) - (bind #t (e) - `(if ,(%inline eq? ,e (immediate ,(fix 0))) - (immediate ,(fix -1)) - (let ([,t ,(build-unfix e)] [,result (immediate ,(fix 0))]) - ,((lambda (body) - (constant-case fixnum-bits - [(30) body] - [(61) - `(seq - (if ,(%inline logtest ,t (immediate #xffffffff)) - ,(%constant svoid) - (seq - (set! ,t ,(%inline srl ,t (immediate 32))) - (set! ,result ,(%inline + ,result (immediate ,(fix 32)))))) - ,body)])) - (%seq - (if ,(%inline logtest ,t (immediate #xffff)) - ,(%constant svoid) - (seq - (set! ,t ,(%inline srl ,t (immediate 16))) - (set! ,result ,(%inline + ,result (immediate ,(fix 16)))))) - (if ,(%inline logtest ,t (immediate #xff)) - ,(%constant svoid) - (seq - (set! ,t ,(%inline srl ,t (immediate 8))) - (set! ,result ,(%inline + ,result (immediate ,(fix 8)))))) - ,(%inline + ,result - (inline ,(make-info-load 'unsigned-8 #f) ,%load - ,(%tc-ref fxfirst-bit-set-bv) - ,(%inline logand ,t (immediate #xff)) - ,(%constant bytevector-data-disp)))))))))]) - - (let () - (define-syntax type-pred - (syntax-rules () - [(_ name? mask type) - (define-inline 2 name? - [(e) (%type-check mask type ,e)])])) - (define-syntax typed-object-pred - (syntax-rules () - [(_ name? mask type) - (define-inline 2 name? - [(e) - (bind #t (e) - (%typed-object-check mask type ,e))])])) - (type-pred boolean? mask-boolean type-boolean) - (type-pred bwp-object? mask-bwp sbwp) - (type-pred char? mask-char type-char) - (type-pred eof-object? mask-eof seof) - (type-pred fixnum? mask-fixnum type-fixnum) - (type-pred flonum? mask-flonum type-flonum) - (type-pred null? mask-nil snil) - (type-pred pair? mask-pair type-pair) - (type-pred procedure? mask-closure type-closure) - (type-pred symbol? mask-symbol type-symbol) - (type-pred $unbound-object? mask-unbound sunbound) - (typed-object-pred bignum? mask-bignum type-bignum) - (typed-object-pred box? mask-box type-box) - (typed-object-pred mutable-box? mask-mutable-box type-mutable-box) - (typed-object-pred immutable-box? mask-mutable-box type-immutable-box) - (typed-object-pred bytevector? mask-bytevector type-bytevector) - (typed-object-pred mutable-bytevector? mask-mutable-bytevector type-mutable-bytevector) - (typed-object-pred immutable-bytevector? mask-mutable-bytevector type-immutable-bytevector) - (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 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) - (typed-object-pred input-port? mask-input-port type-input-port) - (typed-object-pred output-port? mask-output-port type-output-port) - (typed-object-pred port? mask-port type-port) - (typed-object-pred ratnum? mask-ratnum type-ratnum) - (typed-object-pred $record? mask-record type-record) - (typed-object-pred string? mask-string type-string) - (typed-object-pred mutable-string? mask-mutable-string type-mutable-string) - (typed-object-pred immutable-string? mask-mutable-string type-immutable-string) - (typed-object-pred $system-code? mask-system-code type-system-code) - (typed-object-pred $tlc? mask-tlc type-tlc) - (typed-object-pred vector? mask-vector type-vector) - (typed-object-pred mutable-vector? mask-mutable-vector type-mutable-vector) - (typed-object-pred immutable-vector? mask-mutable-vector type-immutable-vector) - (typed-object-pred stencil-vector? mask-stencil-vector type-stencil-vector) - (typed-object-pred thread? mask-thread type-thread)) - (define-inline 3 $bigpositive? - [(e) (%type-check mask-signed-bignum type-positive-bignum - ,(%mref ,e ,(constant bignum-type-disp)))]) - (define-inline 3 csv7:record-field-accessible? - [(e1 e2) (%seq ,e1 ,e2 ,(%constant strue))]) - - (define-inline 2 cflonum? - [(e) (bind #t (e) - `(if ,(%type-check mask-flonum type-flonum ,e) - ,(%constant strue) - ,(%typed-object-check mask-inexactnum type-inexactnum ,e)))]) - (define-inline 2 $immediate? - [(e) (bind #t (e) - `(if ,(%type-check mask-fixnum type-fixnum ,e) - ,(%constant strue) - ,(%type-check mask-immediate type-immediate ,e)))]) - - (define-inline 3 $inexactnum-real-part - [(e) (build-$inexactnum-real-part e)]) - (define-inline 3 $inexactnum-imag-part - [(e) (build-$inexactnum-imag-part e)]) - - (define-inline 3 cfl-real-part - [(e) (bind #t (e) - `(if ,(%type-check mask-flonum type-flonum ,e) - ,e - ,(build-$inexactnum-real-part e)))]) - - (define-inline 3 cfl-imag-part - [(e) (bind #t (e) - `(if ,(%type-check mask-flonum type-flonum ,e) - (quote 0.0) - ,(build-$inexactnum-imag-part e)))]) - - (define-inline 3 $closure-ref - [(e-v e-i) - (nanopass-case (L7 Expr) e-i - [(quote ,d) - (guard (target-fixnum? d)) - (%mref ,e-v ,(+ (fix d) (constant closure-data-disp)))] - [else (%mref ,e-v ,e-i ,(constant closure-data-disp))])]) - (define-inline 3 $closure-set! - [(e-v e-i e-new) - (nanopass-case (L7 Expr) e-i - [(quote ,d) - (guard (target-fixnum? d)) - (build-dirty-store e-v (+ (fix d) (constant closure-data-disp)) e-new)] - [else (build-dirty-store e-v e-i (constant closure-data-disp) e-new)])]) - (define-inline 3 $closure-code - [(e) (%inline - - ,(%mref ,e ,(constant closure-code-disp)) - ,(%constant code-data-disp))]) - (define-inline 3 $code-free-count - [(e) (build-fix (%mref ,e ,(constant code-closure-length-disp)))]) - (define-inline 3 $code-mutable-closure? - [(e) (%typed-object-check mask-code-mutable-closure type-code-mutable-closure ,e)]) - (define-inline 3 $code-arity-in-closure? - [(e) (%typed-object-check mask-code-arity-in-closure type-code-arity-in-closure ,e)]) - (define-inline 3 $code-single-valued? - [(e) (%typed-object-check mask-code-single-valued type-code-single-valued ,e)]) - (define-inline 2 $unbound-object - [() `(quote ,($unbound-object))]) - (define-inline 2 void - [() `(quote ,(void))]) - (define-inline 2 eof-object - [() `(quote #!eof)]) - (define-inline 2 cons - [(e1 e2) - (bind #f (e1 e2) - (bind #t ([t (%constant-alloc type-pair (constant size-pair))]) - (%seq - (set! ,(%mref ,t ,(constant pair-car-disp)) ,e1) - (set! ,(%mref ,t ,(constant pair-cdr-disp)) ,e2) - ,t)))]) - (define-inline 2 box - [(e) - (bind #f (e) - (bind #t ([t (%constant-alloc type-typed-object (constant size-box))]) - (%seq - (set! ,(%mref ,t ,(constant box-type-disp)) ,(%constant type-box)) - (set! ,(%mref ,t ,(constant box-ref-disp)) ,e) - ,t)))]) - (define-inline 2 box-immutable - [(e) - (bind #f (e) - (bind #t ([t (%constant-alloc type-typed-object (constant size-box))]) - (%seq - (set! ,(%mref ,t ,(constant box-type-disp)) ,(%constant type-immutable-box)) - (set! ,(%mref ,t ,(constant box-ref-disp)) ,e) - ,t)))]) - (define-inline 3 $make-tlc - [(e-ht e-keyval e-next) - (bind #f (e-ht e-keyval e-next) - (bind #t ([t (%constant-alloc type-typed-object (constant size-tlc))]) - (%seq - (set! ,(%mref ,t ,(constant tlc-type-disp)) ,(%constant type-tlc)) - (set! ,(%mref ,t ,(constant tlc-ht-disp)) ,e-ht) - (set! ,(%mref ,t ,(constant tlc-keyval-disp)) ,e-keyval) - (set! ,(%mref ,t ,(constant tlc-next-disp)) ,e-next) - ,t)))]) - (define-inline 2 list - [e* (build-list e*)]) - (let () - (define (go e e*) - (bind #f (e) - (list-bind #f (e*) - (bind #t ([t (%constant-alloc type-pair (fx* (constant size-pair) (length e*)))]) - (let loop ([e e] [e* e*] [i 0]) - (let ([e2 (car e*)] [e* (cdr e*)]) - `(seq - (set! ,(%mref ,t ,(fx+ i (constant pair-car-disp))) ,e) - ,(if (null? e*) - `(seq - (set! ,(%mref ,t ,(fx+ i (constant pair-cdr-disp))) ,e2) - ,t) - (let ([next-i (fx+ i (constant size-pair))]) - `(seq - (set! ,(%mref ,t ,(fx+ i (constant pair-cdr-disp))) - ,(%inline + ,t (immediate ,next-i))) - ,(loop e2 e* next-i))))))))))) - (define-inline 2 list* - [(e) (ensure-single-valued e)] - [(e . e*) (go e e*)]) - (define-inline 2 cons* - [(e) (ensure-single-valued e)] - [(e . e*) (go e e*)])) - (define-inline 2 vector - [() `(quote #())] - [e* - (let ([n (length e*)]) - (list-bind #f (e*) - (bind #t ([t (%constant-alloc type-typed-object - (fx+ (constant header-size-vector) (fx* n (constant ptr-bytes))))]) - (let loop ([e* e*] [i 0]) - (if (null? e*) - `(seq - (set! ,(%mref ,t ,(constant vector-type-disp)) - (immediate ,(+ (fx* n (constant vector-length-factor)) - (constant type-vector)))) - ,t) - `(seq - (set! ,(%mref ,t ,(fx+ i (constant vector-data-disp))) ,(car e*)) - ,(loop (cdr e*) (fx+ i (constant ptr-bytes)))))))))]) - (let () - (define (go e*) - (let ([n (length e*)]) - (list-bind #f (e*) - (bind #t ([t (%constant-alloc type-typed-object - (fx+ (constant header-size-fxvector) (fx* n (constant ptr-bytes))))]) - (let loop ([e* e*] [i 0]) - (if (null? e*) - `(seq - (set! ,(%mref ,t ,(constant fxvector-type-disp)) - (immediate ,(+ (fx* n (constant fxvector-length-factor)) - (constant type-fxvector)))) - ,t) - `(seq - (set! ,(%mref ,t ,(fx+ i (constant fxvector-data-disp))) ,(car e*)) - ,(loop (cdr e*) (fx+ i (constant ptr-bytes)))))))))) - (define-inline 2 fxvector - [() `(quote #vfx())] - [e* (and (andmap (lambda (x) (constant? target-fixnum? x)) e*) (go e*))]) - (define-inline 3 fxvector - [() `(quote #vfx())] - [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-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*) - `(seq - (set! ,(%mref ,t ,(constant string-type-disp)) - (immediate ,(+ (fx* n (constant string-length-factor)) - (constant type-string)))) - ,t) - `(seq - (inline ,(make-info-load (string-char-type) #f) ,%store ,t ,%zero - (immediate ,(fx+ i (constant string-data-disp))) - ,(car e*)) - ,(loop (cdr e*) (fx+ i (constant string-char-bytes)))))))))) - (define-inline 2 string - [() `(quote "")] - [e* (and (andmap (lambda (x) (constant? char? x)) e*) (go e*))]) - (define-inline 3 string - [() `(quote "")] - [e* (go e*)])) - (let () ; level 2 car, cdr, caar, etc. - (define-syntax def-c..r* - (lambda (x) - (define (go ad*) - (let ([id (datum->syntax #'* (string->symbol (format "c~{~a~}r" ad*)))]) - #`(define-inline 2 #,id - [(e) (let ([Lerr (make-local-label 'Lerr)]) - #,(let f ([ad* ad*]) - (let ([builder (if (char=? (car ad*) #\a) #'build-car #'build-cdr)] - [ad* (cdr ad*)]) - (if (null? ad*) - #`(bind #t (e) - `(if ,(build-pair? e) - ,(#,builder e) - (label ,Lerr ,(build-libcall #t src sexpr #,id e)))) - #`(bind #t ([t #,(f ad*)]) - `(if ,(build-pair? t) - ,(#,builder t) - (goto ,Lerr)))))))]))) - (let f ([n 4] [ad* '()]) - (let ([f (lambda (ad*) - (let ([defn (go ad*)]) - (if (fx= n 1) - defn - #`(begin #,defn #,(f (fx- n 1) ad*)))))]) - #`(begin - #,(f (cons #\a ad*)) - #,(f (cons #\d ad*))))))) - def-c..r*) - (let () ; level 3 car, cdr, caar, etc. - (define-syntax def-c..r* - (lambda (x) - (define (go ad*) - (let ([id (datum->syntax #'* (string->symbol (format "c~{~a~}r" ad*)))]) - #`(define-inline 3 #,id - [(e) #,(let f ([ad* ad*]) - (let ([builder (if (char=? (car ad*) #\a) #'build-car #'build-cdr)] - [ad* (cdr ad*)]) - (if (null? ad*) - #`(#,builder e) - #`(#,builder #,(f ad*)))))]))) - (let f ([n 4] [ad* '()]) - (let ([f (lambda (ad*) - (let ([defn (go ad*)]) - (if (fx= n 1) - defn - #`(begin #,defn #,(f (fx- n 1) ad*)))))]) - #`(begin - #,(f (cons #\a ad*)) - #,(f (cons #\d ad*))))))) - def-c..r*) - (let () ; level 3 simple accessors, e.g., unbox, vector-length - (define-syntax inline-accessor - (syntax-rules () - [(_ prim disp) - (define-inline 3 prim - [(e) (%mref ,e ,(constant disp))])])) - (inline-accessor unbox box-ref-disp) - (inline-accessor $symbol-name symbol-name-disp) - (inline-accessor $symbol-property-list symbol-plist-disp) - (inline-accessor $system-property-list symbol-splist-disp) - (inline-accessor $symbol-hash symbol-hash-disp) - (inline-accessor $ratio-numerator ratnum-numerator-disp) - (inline-accessor $ratio-denominator ratnum-denominator-disp) - (inline-accessor $exactnum-real-part exactnum-real-disp) - (inline-accessor $exactnum-imag-part exactnum-imag-disp) - (inline-accessor binary-port-input-buffer port-ibuffer-disp) - (inline-accessor textual-port-input-buffer port-ibuffer-disp) - (inline-accessor binary-port-output-buffer port-obuffer-disp) - (inline-accessor textual-port-output-buffer port-obuffer-disp) - (inline-accessor $code-name code-name-disp) - (inline-accessor $code-arity-mask code-arity-mask-disp) - (inline-accessor $code-info code-info-disp) - (inline-accessor $code-pinfo* code-pinfo*-disp) - (inline-accessor $continuation-link continuation-link-disp) - (inline-accessor $continuation-winders continuation-winders-disp) - (inline-accessor $continuation-attachments continuation-attachments-disp) - (inline-accessor csv7:record-type-descriptor record-type-disp) - (inline-accessor $record-type-descriptor record-type-disp) - (inline-accessor record-rtd record-type-disp) - (inline-accessor record-type-uid record-type-uid-disp) - (inline-accessor $port-handler port-handler-disp) - (inline-accessor $port-info port-info-disp) - (inline-accessor port-name port-name-disp) - (inline-accessor $thread-tc thread-tc-disp) - ) - (constant-case architecture - [(pb) - ;; Don't try to inline seginfo access, because the C pointer size used - ;; in the table may not match the 64-bit `ptr` size - (void)] - [else - (let () - (define (build-seginfo maybe? e) - (let ([ptr (make-assigned-tmp 'ptr)] - [seginfo (make-assigned-tmp 'seginfo)]) - (define (build-level-3 seginfo k) - (constant-case segment-table-levels - [(3) - (let ([s3 (make-assigned-tmp 's3)]) - `(let ([,s3 ,(%mref ,seginfo - ,(%inline sll ,(%inline srl ,ptr (immediate ,(+ (constant segment-t1-bits) - (constant segment-t2-bits)))) - (immediate ,(constant log2-ptr-bytes))) - ,0)]) - ,(if maybe? - `(if ,(%inline eq? ,s3 (immediate 0)) - (immediate 0) - ,(k s3)) - (k s3))))] - [else (k seginfo)])) - (define (build-level-2 s3 k) - (constant-case segment-table-levels - [(2 3) - (let ([s2 (make-assigned-tmp 's2)]) - `(let ([,s2 ,(%mref ,s3 ,(%inline logand - ,(%inline srl ,ptr (immediate ,(fx- (constant segment-t1-bits) - (constant log2-ptr-bytes)))) - (immediate ,(fxsll (fx- (fxsll 1 (constant segment-t2-bits)) 1) - (constant log2-ptr-bytes)))) - 0)]) - ,(if maybe? - `(if ,(%inline eq? ,s2 (immediate 0)) - (immediate 0) - ,(k s2)) - (k s2))))] - [else (k s3)])) - `(let ([,ptr ,(%inline srl ,(%inline + ,e (immediate ,(fx- (constant typemod) 1))) - (immediate ,(constant segment-offset-bits)))]) - (let ([,seginfo (literal ,(make-info-literal #f 'entry (lookup-c-entry segment-info) 0))]) - ,(build-level-3 seginfo - (lambda (s3) - (build-level-2 s3 - (lambda (s2) - (%mref ,s2 ,(%inline sll ,(%inline logand ,ptr - (immediate ,(fx- (fxsll 1 (constant segment-t1-bits)) 1))) - (immediate ,(constant log2-ptr-bytes))) - 0))))))))) - (define (build-space-test e space) - `(if ,(%type-check mask-fixnum type-fixnum ,e) - ,(%constant sfalse) - (if ,(%type-check mask-immediate type-immediate ,e) - ,(%constant sfalse) - ,(let ([s-e (build-seginfo #T e)] - [si (make-assigned-tmp 'si)]) - `(let ([,si ,s-e]) - (if ,(%inline eq? ,si (immediate 0)) - ,(%constant sfalse) - ,(let ([s `(inline ,(make-info-load 'unsigned-8 #f) ,%load ,si ,%zero (immediate 0))]) - (%inline eq? (immediate ,space) ,s)))))))) - - (define-inline 2 $maybe-seginfo - [(e) - (bind #t (e) - `(if ,(%type-check mask-fixnum type-fixnum ,e) - ,(%constant sfalse) - (if ,(%type-check mask-immediate type-immediate ,e) - ,(%constant sfalse) - ,(let ([s-e (build-seginfo #t e)] - [si (make-assigned-tmp 'si)]) - `(let ([,si ,s-e]) - (if ,(%inline eq? ,si (immediate 0)) - ,(%constant sfalse) - ,si))))))]) - (define-inline 2 $seginfo - [(e) - (bind #t (e) (build-seginfo #f e))]) - (define-inline 2 $seginfo-generation - [(e) - (bind #f (e) (build-object-ref #f 'unsigned-8 e %zero (constant seginfo-generation-disp)))]) - (define-inline 2 $seginfo-space - [(e) - (bind #f (e) - (build-object-ref #f 'unsigned-8 e %zero (constant seginfo-space-disp)))]) - (define-inline 2 $list-bits-ref - [(e) - (bind #t (e) - (let ([si (make-assigned-tmp 'si)] - [list-bits (make-assigned-tmp 'list-bits)] - [offset (make-assigned-tmp 'offset)] - [byte (make-assigned-tmp 'byte)]) - `(let ([,si ,(build-seginfo #f e)]) - (let ([,list-bits ,(%mref ,si ,(constant seginfo-list-bits-disp))]) - (if ,(%inline eq? ,list-bits (immediate 0)) - (immediate 0) - (let ([,offset ,(%inline srl ,(%inline logand ,(%inline + ,e (immediate ,(fx- (constant typemod) 1))) - (immediate ,(fx- (constant bytes-per-segment) 1))) - (immediate ,(constant log2-ptr-bytes)))]) - (let ([,byte (inline ,(make-info-load 'unsigned-8 #f) ,%load ,list-bits ,%zero ,(%inline srl ,offset (immediate 3)))]) - ,(build-fix (%inline logand ,(%inline srl ,byte ,(%inline logand ,offset (immediate 7))) - (immediate ,(constant list-bits-mask)))))))))))]) - (define-inline 2 $generation - [(e) - (bind #t (e) - `(if ,(%type-check mask-fixnum type-fixnum ,e) - ,(%constant sfalse) - ,(let ([s-e (build-seginfo #t e)] - [si (make-assigned-tmp 'si)]) - `(let ([,si ,s-e]) - (if ,(%inline eq? ,si (immediate 0)) - ,(%constant sfalse) - ,(build-object-ref #f 'unsigned-8 si %zero 1))))))]) - (define-inline 2 weak-pair? - [(e) (bind #t (e) (build-space-test e (constant space-weakpair)))]) - (define-inline 2 ephemeron-pair? - [(e) (bind #t (e) (build-space-test e (constant space-ephemeron)))]))]) - - (define-inline 2 unbox - [(e) - (bind #t (e) - `(if ,(%typed-object-check mask-box type-box ,e) - ,(%mref ,e ,(constant box-ref-disp)) - ,(build-libcall #t src sexpr unbox e)))]) - (let () - (define-syntax def-len - (syntax-rules () - [(_ prim type-disp length-offset) - (define-inline 3 prim - [(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) - (def-len stencil-vector-mask stencil-vector-type-disp stencil-vector-mask-offset)) - (let () - (define-syntax def-len - (syntax-rules () - [(_ prim mask type type-disp length-offset) - (define-inline 2 prim - [(e) (let ([Lerr (make-local-label 'Lerr)]) - (bind #t (e) - `(if ,(%type-check mask-typed-object type-typed-object ,e) - ,(bind #t ([t/l (%mref ,e ,(constant type-disp))]) - `(if ,(%type-check mask type ,t/l) - ,(extract-length t/l (constant length-offset)) - (goto ,Lerr))) - (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)) - ; TODO: consider adding integer-valued?, rational?, rational-valued?, - ; real?, and real-valued? - (define-inline 2 integer? - [(e) (bind #t (e) - (build-simple-or - (%type-check mask-fixnum type-fixnum ,e) - (build-simple-or - (%typed-object-check mask-bignum type-bignum ,e) - (build-and - (%type-check mask-flonum type-flonum ,e) - `(call ,(make-info-call src sexpr #f #f #f) #f ,(lookup-primref 3 'flinteger?) ,e)))))]) - (let () - (define build-number? - (lambda (e) - (bind #t (e) - (build-simple-or - (%type-check mask-fixnum type-fixnum ,e) - (build-simple-or - (%type-check mask-flonum type-flonum ,e) - (build-and - (%type-check mask-typed-object type-typed-object ,e) - (%type-check mask-other-number type-other-number - ,(%mref ,e ,(constant bignum-type-disp))))))))) - (define-inline 2 number? - [(e) (build-number? e)]) - (define-inline 2 complex? - [(e) (build-number? e)])) - (define-inline 3 set-car! - [(e1 e2) (build-dirty-store e1 (constant pair-car-disp) e2)]) - (define-inline 3 set-cdr! - [(e1 e2) (build-dirty-store e1 (constant pair-cdr-disp) e2)]) - (define-inline 3 set-box! - [(e1 e2) (build-dirty-store e1 (constant box-ref-disp) e2)]) - (define-inline 3 box-cas! - [(e1 e2 e3) - (bind #t (e2) - (build-dirty-store e1 %zero (constant box-ref-disp) e3 (make-build-cas e2) build-cas-seq))]) - (define-inline 3 $set-symbol-name! - [(e1 e2) (build-dirty-store e1 (constant symbol-name-disp) e2)]) - (define-inline 3 $set-symbol-property-list! - [(e1 e2) (build-dirty-store e1 (constant symbol-plist-disp) e2)]) - (define-inline 3 $set-system-property-list! - [(e1 e2) (build-dirty-store e1 (constant symbol-splist-disp) e2)]) - (define-inline 3 $set-port-info! - [(e1 e2) (build-dirty-store e1 (constant port-info-disp) e2)]) - (define-inline 3 set-port-name! - [(e1 e2) (build-dirty-store e1 (constant port-name-disp) e2)]) - (define-inline 2 set-box! - [(e-box e-new) - (bind #t (e-box e-new) - `(if ,(%typed-object-check mask-mutable-box type-mutable-box ,e-box) - ,(build-dirty-store e-box (constant box-ref-disp) e-new) - ,(build-libcall #t src sexpr set-box! e-box e-new)))]) - (define-inline 2 box-cas! - [(e-box e-old e-new) - (bind #t (e-box e-old e-new) - `(if ,(%typed-object-check mask-mutable-box type-mutable-box ,e-box) - ,(build-dirty-store e-box %zero (constant box-ref-disp) e-new (make-build-cas e-old) build-cas-seq) - ,(build-libcall #t src sexpr box-cas! e-box e-old e-new)))]) - (define-inline 2 set-car! - [(e-pair e-new) - (bind #t (e-pair e-new) - `(if ,(%type-check mask-pair type-pair ,e-pair) - ,(build-dirty-store e-pair (constant pair-car-disp) e-new) - ,(build-libcall #t src sexpr set-car! e-pair e-new)))]) - (define-inline 2 set-cdr! - [(e-pair e-new) - (bind #t (e-pair e-new) - `(if ,(%type-check mask-pair type-pair ,e-pair) - ,(build-dirty-store e-pair (constant pair-cdr-disp) e-new) - ,(build-libcall #t src sexpr set-cdr! e-pair e-new)))]) - (define-inline 3 $set-symbol-hash! - ; no need for dirty store---e2 should be a fixnum - [(e1 e2) `(set! ,(%mref ,e1 ,(constant symbol-hash-disp)) ,e2)]) - (define-inline 2 memory-order-acquire - [() (if-feature pthreads - (constant-case architecture - [(arm32 arm64) (%seq ,(%inline acquire-fence) (quote ,(void)))] - [else `(quote ,(void))]) - `(quote ,(void)))]) - (define-inline 2 memory-order-release - [() (if-feature pthreads - (constant-case architecture - [(arm32 arm64) (%seq ,(%inline release-fence) (quote ,(void)))] - [else `(quote ,(void))]) - `(quote ,(void)))]) - (let () - (define-syntax define-tlc-parameter - (syntax-rules () - [(_ name disp) - (define-inline 3 name - [(e-x) (%mref ,e-x ,(constant disp))])] - [(_ name name! disp) - (begin - (define-tlc-parameter name disp) - (define-inline 3 name! - [(e-x e-new) (build-dirty-store e-x (constant disp) e-new)]))])) - (define-tlc-parameter $tlc-keyval tlc-keyval-disp) - (define-tlc-parameter $tlc-ht tlc-ht-disp) - (define-tlc-parameter $tlc-next $set-tlc-next! tlc-next-disp)) - (define-inline 2 $top-level-value - [(e) (nanopass-case (L7 Expr) e - [(quote ,d) - (guard (symbol? d)) - (if (any-set? (prim-mask (or primitive system)) ($sgetprop d '*flags* 0)) - (Symref d) - (bind #t (e) - (bind #t ([t (%mref ,e ,(constant symbol-value-disp))]) - `(if ,(%type-check mask-unbound sunbound ,t) - ,(build-libcall #t #f sexpr $top-level-value e) - ,t))))] - [else - (bind #t (e) - (let ([Lfail (make-local-label 'tlv-fail)]) - `(if ,(%type-check mask-symbol type-symbol ,e) - ,(bind #t ([t (%mref ,e ,(constant symbol-value-disp))]) - `(if ,(%type-check mask-unbound sunbound ,t) - (goto ,Lfail) - ,t)) - (label ,Lfail ,(build-libcall #t #f sexpr $top-level-value e)))))])]) - (define-inline 3 $top-level-value - [(e) (nanopass-case (L7 Expr) e - [(quote ,d) (guard (symbol? d)) (Symref d)] - [else (%mref ,e ,(constant symbol-value-disp))])]) - (let () - (define (go e-sym e-value) - (bind #t (e-sym) - `(seq - ,(build-dirty-store e-sym (constant symbol-value-disp) e-value) - (set! ,(%mref ,e-sym ,(constant symbol-pvalue-disp)) - (literal - ,(make-info-literal #f 'library - (lookup-libspec nonprocedure-code) - (constant code-data-disp))))))) - (define-inline 3 $set-top-level-value! - [(e-sym e-value) (go e-sym e-value)]) - (define-inline 2 $set-top-level-value! - [(e-sym e-value) (and (constant? symbol? e-sym) (go e-sym e-value))])) - (define-inline 3 $top-level-bound? - [(e-sym) - (build-not - (%type-check mask-unbound sunbound - ,(nanopass-case (L7 Expr) e-sym - [(quote ,d) (guard (symbol? d)) (Symref d)] - [else (%mref ,e-sym ,(constant symbol-value-disp))])))]) - (let () - (define parse-format - (lambda (who src cntl-arg args) - (nanopass-case (L7 Expr) cntl-arg - [(quote ,d) - (guard (c [(and (assertion-violation? c) - (format-condition? c) - (message-condition? c) - (irritants-condition? c)) - ($source-warning 'compile - src #t - "~? in call to ~s" - (condition-message c) - (condition-irritants c) - who) - #f]) - (#%$parse-format-string who d (length args)))] - [else #f]))) - (define fmt->expr - ($make-fmt->expr - (lambda (d) `(quote ,d)) - (lambda (e1 e2) `(seq ,e1 ,e2)) - (lambda (src sexpr prim arg*) - `(call ,(make-info-call src sexpr #f #f #f) #f - ,(lookup-primref 3 prim) - ,arg* ...)))) - (define build-format - (lambda (who src sexpr op-arg cntl-arg arg*) - (let ([x (parse-format who src cntl-arg arg*)]) - (and x - (cond - [(and (fx= (length x) 1) - (string? (car x)) - (nanopass-case (L7 Expr) op-arg - [(quote ,d) (eq? d #f)] - [else #f])) - (%primcall src sexpr string-copy (quote ,(car x)))] - [(and (nanopass-case (L7 Expr) op-arg - [(quote ,d) (not (eq? d #f))] - [else #t]) - (let-values ([(op-arg dobind) (binder #t 'ptr op-arg)] - [(arg* dobind*) (list-binder #t 'ptr arg*)]) - (let ([e (fmt->expr src sexpr x op-arg arg*)]) - (and e (dobind (dobind* e))))))] - [else - (%primcall src sexpr $dofmt (quote ,who) ,op-arg ,cntl-arg - (quote ,x) - ,(build-list arg*))]))))) - (define-inline 2 errorf - [(e-who e-str . e*) - (parse-format 'errorf src e-str e*) - `(seq (pariah) (call ,(make-info-call src sexpr #f #t #t) #f ,(Symref 'errorf) ,e-who ,e-str ,e* ...))]) - (define-inline 2 assertion-violationf - [(e-who e-str . e*) - (parse-format 'assertion-violationf src e-str e*) - `(seq (pariah) (call ,(make-info-call src sexpr #f #t #t) #f ,(Symref 'assertion-violationf) ,e-who ,e-str ,e* ...))]) - (define-inline 2 $oops - [(e-who e-str . e*) - (parse-format '$oops src e-str e*) - `(seq (pariah) (call ,(make-info-call src sexpr #f #t #t) #f ,(Symref '$oops) ,e-who ,e-str ,e* ...))]) - (define-inline 2 $impoops - [(e-who e-str . e*) - (parse-format '$impoops src e-str e*) - `(seq (pariah) (call ,(make-info-call src sexpr #f #t #t) #f ,(Symref '$impoops) ,e-who ,e-str ,e* ...))]) - (define-inline 2 warningf - [(e-who e-str . e*) - (parse-format 'warningf src e-str e*) - `(seq (pariah) (call ,(make-info-call src sexpr #f #t #f) #f ,(Symref 'warningf) ,e-who ,e-str ,e* ...))]) - (define-inline 2 $source-violation - [(e-who e-src e-start? e-str . e*) - (parse-format '$source-violation src e-str e*) - `(seq (pariah) (call ,(make-info-call src sexpr #f #t #t) #f ,(Symref '$source-violation) - ,e-who ,e-src ,e-start? ,e-str ,e* ...))]) - (define-inline 2 $source-warning - [(e-who e-src e-start? e-str . e*) - (parse-format '$source-warning src e-str e*) - `(seq (pariah) (call ,(make-info-call src sexpr #f #t #f) #f ,(Symref '$source-warning) - ,e-who ,e-src ,e-start? ,e-str ,e* ...))]) - (define-inline 2 fprintf - [(e-op e-str . e*) - (parse-format 'fprintf src e-str e*) - #f]) - (define-inline 3 fprintf - [(e-op e-str . e*) (build-format 'fprintf src sexpr e-op e-str e*)]) - (define-inline 2 printf - [(e-str . e*) - (build-format 'printf src sexpr (%tc-ref current-output) e-str e*)]) - (define-inline 2 format - [(e . e*) - (nanopass-case (L7 Expr) e - [(quote ,d) - (if (string? d) - (build-format 'format src sexpr `(quote #f) e e*) - (and (not (null? e*)) - (cond - [(eq? d #f) (build-format 'format src sexpr e (car e*) (cdr e*))] - [(eq? d #t) (build-format 'format src sexpr - (%tc-ref current-output) - (car e*) (cdr e*))] - [else #f])))] - [else #f])])) - (let () - (define hand-coded-closure? - (lambda (name) - (not (memq name '(nuate nonprocedure-code error-invoke invoke - $wrapper-apply wrapper-apply arity-wrapper-apply - popcount-slow cpu-features))))) - (define-inline 2 $hand-coded - [(name) - (nanopass-case (L7 Expr) name - [(quote ,d) - (guard (symbol? d)) - (let ([l (make-local-label 'hcl)]) - (set! new-l* (cons l new-l*)) - (set! new-le* (cons (with-output-language (L9 CaseLambdaExpr) `(hand-coded ,d)) new-le*)) - (if (hand-coded-closure? d) - `(literal ,(make-info-literal #f 'closure l 0)) - `(label-ref ,l 0)))] - [(seq (profile ,src) ,[e]) `(seq (profile ,src) ,e)] - [else ($oops '$hand-coded "~s is not a quoted symbol" name)])])) - (define-inline 2 $tc - [() %tc]) - (define-inline 3 $tc-field - [(e-fld e-tc) - (nanopass-case (L7 Expr) e-fld - [(quote ,d) - (let () - (define-syntax a - (lambda (x) - #`(case d - #,@(fold-left - (lambda (ls field) - (apply - (lambda (name type disp len) - (if (eq? type 'ptr) - (cons - (with-syntax ([name (datum->syntax #'* name)]) - #'[(name) (%tc-ref ,e-tc name)]) - ls) - ls)) - field)) - '() (getprop 'tc '*fields* '())) - [else #f]))) - a)] - [else #f])] - [(e-fld e-tc e-val) - (nanopass-case (L7 Expr) e-fld - [(quote ,d) - (let () - (define-syntax a - (lambda (x) - #`(case d - #,@(fold-left - (lambda (ls field) - (apply - (lambda (name type disp len) - (if (eq? type 'ptr) - (cons - (with-syntax ([name (datum->syntax #'* name)]) - #'[(name) `(set! ,(%tc-ref ,e-tc name) ,e-val)]) - ls) - ls)) - field)) - '() (getprop 'tc '*fields* '())) - [else #f]))) - a)] - [else #f])]) - (let () - (define-syntax define-tc-parameter - (syntax-rules () - [(_ name tc-name) - (begin - (define-inline 2 name - [() (%tc-ref tc-name)] - [(x) #f]) - (define-inline 3 name - [() (%tc-ref tc-name)] - [(x) `(set! ,(%tc-ref tc-name) ,x)]))])) - - (define-tc-parameter current-input-port current-input) - (define-tc-parameter current-output-port current-output) - (define-tc-parameter current-error-port current-error) - (define-tc-parameter generate-inspector-information generate-inspector-information) - (define-tc-parameter generate-procedure-source-information generate-procedure-source-information) - (define-tc-parameter generate-profile-forms generate-profile-forms) - (define-tc-parameter $compile-profile compile-profile) - (define-tc-parameter optimize-level optimize-level) - (define-tc-parameter subset-mode subset-mode) - (define-tc-parameter $suppress-primitive-inlining suppress-primitive-inlining) - (define-tc-parameter $block-counter block-counter) - (define-tc-parameter $sfd sfd) - (define-tc-parameter $current-mso current-mso) - (define-tc-parameter $target-machine target-machine) - (define-tc-parameter $current-stack-link stack-link) - (define-tc-parameter $current-winders winders) - (define-tc-parameter $current-attachments attachments) - (define-tc-parameter default-record-equal-procedure default-record-equal-procedure) - (define-tc-parameter default-record-hash-procedure default-record-hash-procedure) - ) - - (let () - (define (make-wrapper-closure-alloc e-proc e-arity-mask e-data libspec) - (bind #t ([c (%constant-alloc type-closure (fx* (if e-data 4 3) (constant ptr-bytes)))]) - (%seq - (set! ,(%mref ,c ,(constant closure-code-disp)) - (literal ,(make-info-literal #f 'library libspec (constant code-data-disp)))) - (set! ,(%mref ,c ,(constant closure-data-disp)) ,e-proc) - (set! ,(%mref ,c ,(fx+ (constant ptr-bytes) (constant closure-data-disp))) ,e-arity-mask) - ,(if e-data - (%seq - (set! ,(%mref ,c ,(fx+ (fx* (constant ptr-bytes) 2) (constant closure-data-disp))) ,e-data) - ,c) - c)))) - (define-inline 3 $make-wrapper-procedure - [(e-proc e-arity-mask) - (bind #f (e-proc e-arity-mask) - (make-wrapper-closure-alloc e-proc e-arity-mask #f (lookup-libspec $wrapper-apply)))]) - (define-inline 3 make-wrapper-procedure - [(e-proc e-arity-mask e-data) - (bind #f (e-proc e-arity-mask e-data) - (make-wrapper-closure-alloc e-proc e-arity-mask e-data (lookup-libspec wrapper-apply)))]) - (define-inline 3 make-arity-wrapper-procedure - [(e-proc e-arity-mask e-data) - (bind #f (e-proc e-arity-mask e-data) - (make-wrapper-closure-alloc e-proc e-arity-mask e-data (lookup-libspec arity-wrapper-apply)))])) - - (define-inline 3 $install-guardian - [(e-obj e-rep e-tconc ordered?) - (bind #f (e-obj e-rep e-tconc ordered?) - (bind #t ([t (%constant-alloc typemod (constant size-guardian-entry))]) - (%seq - (set! ,(%mref ,t ,(constant guardian-entry-obj-disp)) ,e-obj) - (set! ,(%mref ,t ,(constant guardian-entry-rep-disp)) ,e-rep) - (set! ,(%mref ,t ,(constant guardian-entry-tconc-disp)) ,e-tconc) - (set! ,(%mref ,t ,(constant guardian-entry-next-disp)) ,(%tc-ref guardian-entries)) - (set! ,(%mref ,t ,(constant guardian-entry-ordered?-disp)) ,ordered?) - (set! ,(%mref ,t ,(constant guardian-entry-pending-disp)) ,(%constant snil)) - (set! ,(%tc-ref guardian-entries) ,t))))]) - - (define-inline 3 $install-ftype-guardian - [(e-obj e-tconc) - (bind #f (e-obj e-tconc) - (bind #t ([t (%constant-alloc typemod (constant size-guardian-entry))]) - (%seq - (set! ,(%mref ,t ,(constant guardian-entry-obj-disp)) ,e-obj) - (set! ,(%mref ,t ,(constant guardian-entry-rep-disp)) (immediate ,(constant ftype-guardian-rep))) - (set! ,(%mref ,t ,(constant guardian-entry-tconc-disp)) ,e-tconc) - (set! ,(%mref ,t ,(constant guardian-entry-next-disp)) ,(%tc-ref guardian-entries)) - (set! ,(%mref ,t ,(constant guardian-entry-ordered?-disp)) ,(%constant sfalse)) - (set! ,(%mref ,t ,(constant guardian-entry-pending-disp)) ,(%constant snil)) - (set! ,(%tc-ref guardian-entries) ,t))))]) - - (define-inline 2 guardian? - [(e) - (bind #t (e) - (build-and - (%type-check mask-closure type-closure ,e) - (%type-check mask-guardian-code type-guardian-code - ,(%mref - ,(%inline - - ,(%mref ,e ,(constant closure-code-disp)) - ,(%constant code-data-disp)) - ,(constant code-type-disp)))))]) - - (define-inline 3 $make-phantom-bytevector - [() - (bind #f () - (bind #t ([t (%constant-alloc type-typed-object (constant size-phantom))]) - (%seq - (set! ,(%mref ,t ,(constant phantom-type-disp)) - ,(%constant type-phantom)) - (set! ,(%mref ,t ,(constant phantom-length-disp)) - (immediate 0)) - ,t)))]) - - (define-inline 3 phantom-bytevector-length - [(e-ph) - (bind #f (e-ph) - (unsigned->ptr (%mref ,e-ph ,(constant phantom-length-disp)) - (constant ptr-bits)))]) - - (define-inline 2 virtual-register-count - [() `(quote ,(constant virtual-register-count))]) - (let () - (define constant-ref - (lambda (e-idx) - (nanopass-case (L7 Expr) e-idx - [(quote ,d) - (guard (and (fixnum? d) ($fxu< d (constant virtual-register-count)))) - (%mref ,%tc ,(fx+ (constant tc-virtual-registers-disp) (fx* d (constant ptr-bytes))))] - [else #f]))) - (define constant-set - (lambda (e-idx e-val) - (let ([ref (constant-ref e-idx)]) - (and ref `(set! ,ref ,e-val))))) - (define index-check - (lambda (e-idx libcall e) - `(if (if ,(%type-check mask-fixnum type-fixnum ,e-idx) - ,(%inline u< ,e-idx (immediate ,(fix (constant virtual-register-count)))) - ,(%constant sfalse)) - ,e - ,libcall))) - (meta-assert (= (constant log2-ptr-bytes) (constant fixnum-offset))) - (define-inline 3 virtual-register - [(e-idx) - (or (constant-ref e-idx) - (%mref ,%tc ,e-idx ,(constant tc-virtual-registers-disp)))]) - (define-inline 2 virtual-register - [(e-idx) - (or (constant-ref e-idx) - (bind #t (e-idx) - (index-check e-idx - (build-libcall #t src sexpr virtual-register e-idx) - (%mref ,%tc ,e-idx ,(constant tc-virtual-registers-disp)))))]) - (define-inline 3 set-virtual-register! - [(e-idx e-val) - (or (constant-set e-idx e-val) - `(set! ,(%mref ,%tc ,e-idx ,(constant tc-virtual-registers-disp)) ,e-val))]) - (define-inline 2 set-virtual-register! - [(e-idx e-val) - (or (constant-set e-idx e-val) - (bind #t (e-idx) - (bind #f (e-val) - (index-check e-idx - (build-libcall #t src sexpr set-virtual-register! e-idx) - `(set! ,(%mref ,%tc ,e-idx ,(constant tc-virtual-registers-disp)) ,e-val)))))])) - - (define-inline 2 $thread-list - [() `(literal ,(make-info-literal #t 'entry (lookup-c-entry thread-list) 0))]) - (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 - [() `(literal ,(make-info-literal #f 'entry (lookup-c-entry raw-collect-thread0-cond) 0))])) - (define-inline 2 not - [(e) `(if ,e ,(%constant sfalse) ,(%constant strue))]) - (define-inline 2 most-negative-fixnum - [() `(quote ,(constant most-negative-fixnum))]) - (define-inline 2 most-positive-fixnum - [() `(quote ,(constant most-positive-fixnum))]) - (define-inline 2 least-fixnum - [() `(quote ,(constant most-negative-fixnum))]) - (define-inline 2 greatest-fixnum - [() `(quote ,(constant most-positive-fixnum))]) - (define-inline 2 fixnum-width - [() `(quote ,(constant fixnum-bits))]) - (constant-case native-endianness - [(unknown) (void)] - [else - (define-inline 2 native-endianness - [() `(quote ,(constant native-endianness))])]) - (define-inline 2 directory-separator - [() `(quote ,(if-feature windows #\\ #\/))]) - (let () ; level 2 char=?, r6rs:char=?, etc. - (define-syntax char-pred - (syntax-rules () - [(_ op r6rs:op inline-op) - (let () - (define (go2 src sexpr e1 e2) - (bind #t (e1 e2) - `(if ,(build-chars? e1 e2) - ,(%inline inline-op ,e1 ,e2) - ,(build-libcall #t src sexpr op e1 e2)))) - (define (go3 src sexpr e1 e2 e3) - (and (constant? char? e1) - (constant? char? e3) - (bind #t (e2) - `(if ,(%type-check mask-char type-char ,e2) - ,(build-and - (%inline inline-op ,e1 ,e2) - (%inline inline-op ,e2 ,e3)) - ; could also pass e2 and e3: - ,(build-libcall #t src sexpr op e1 e2))))) - (define-inline 2 op - [(e1 e2) (go2 src sexpr e1 e2)] - [(e1 e2 e3) (go3 src sexpr e1 e2 e3)] - [(e1 . e*) #f]) - (define-inline 2 r6rs:op - [(e1 e2) (go2 src sexpr e1 e2)] - [(e1 e2 e3) (go3 src sexpr e1 e2 e3)] - [(e1 e2 . e*) #f]))])) - (char-pred char<? r6rs:char<? <) - (char-pred char<=? r6rs:char<=? <=) - (char-pred char=? r6rs:char=? eq?) - (char-pred char>=? r6rs:char>=? >=) - (char-pred char>? r6rs:char>? >)) - (let () ; level 3 char=?, r6rs:char=?, etc. - (define-syntax char-pred - (syntax-rules () - [(_ op r6rs:op inline-op) - (let () - (define (go2 e1 e2) - (%inline inline-op ,e1 ,e2)) - (define (go3 e1 e2 e3) - (bind #t (e2) - (bind #f (e3) - (build-and - (go2 e1 e2) - (go2 e2 e3))))) - (define-inline 3 op - [(e) `(seq ,e ,(%constant strue))] - [(e1 e2) (go2 e1 e2)] - [(e1 e2 e3) (go3 e1 e2 e3)] - [(e1 . e*) #f]) - (define-inline 3 r6rs:op - [(e1 e2) (go2 e1 e2)] - [(e1 e2 e3) (go3 e1 e2 e3)] - [(e1 e2 . e*) #f]))])) - (char-pred char<? r6rs:char<? <) - (char-pred char<=? r6rs:char<=? <=) - (char-pred char=? r6rs:char=? eq?) - (char-pred char>=? r6rs:char>=? >=) - (char-pred char>? r6rs:char>? >)) - (define-inline 3 map - [(e-proc e-ls) - (or (nanopass-case (L7 Expr) e-proc - [,pr - (and (all-set? (prim-mask unsafe) (primref-flags pr)) - (let ([name (primref-name pr)]) - (or (and (eq? name 'car) (build-libcall #f src sexpr map-car e-ls)) - (and (eq? name 'cdr) (build-libcall #f src sexpr map-cdr e-ls)))))] - [else #f]) - (build-libcall #f src sexpr map1 e-proc e-ls))] - [(e-proc e-ls1 e-ls2) - (or (nanopass-case (L7 Expr) e-proc - [,pr - (and (eq? (primref-name pr) 'cons) - (build-libcall #f src sexpr map-cons e-ls1 e-ls2))] - [else #f]) - (build-libcall #f src sexpr map2 e-proc e-ls1 e-ls2))] - [(e-proc e-ls . e-ls*) #f]) - (define-inline 3 andmap - [(e-proc e-ls) (build-libcall #f src sexpr andmap1 e-proc e-ls)] - [(e-proc e-ls . e-ls*) #f]) - (define-inline 3 for-all - [(e-proc e-ls) (build-libcall #f src sexpr andmap1 e-proc e-ls)] - [(e-proc e-ls . e-ls*) #f]) - (define-inline 3 ormap - [(e-proc e-ls) (build-libcall #f src sexpr ormap1 e-proc e-ls)] - [(e-proc e-ls . e-ls*) #f]) - (define-inline 3 exists - [(e-proc e-ls) (build-libcall #f src sexpr ormap1 e-proc e-ls)] - [(e-proc e-ls . e-ls*) #f]) - (define-inline 3 fold-left - [(e-proc e-base e-ls) (build-libcall #f src sexpr fold-left1 e-proc e-base e-ls)] - [(e-proc e-base e-ls1 e-ls2) (build-libcall #f src sexpr fold-left2 e-proc e-base e-ls1 e-ls2)] - [(e-proc e-base e-ls . e-ls*) #f]) - (define-inline 3 fold-right - [(e-proc e-base e-ls) (build-libcall #f src sexpr fold-right1 e-proc e-base e-ls)] - [(e-proc e-base e-ls1 e-ls2) (build-libcall #f src sexpr fold-right2 e-proc e-base e-ls1 e-ls2)] - [(e-proc e-base e-ls . e-ls*) #f]) - (define-inline 3 for-each - [(e-proc e-ls) (build-libcall #f src sexpr for-each1 e-proc e-ls)] - [(e-proc e-ls1 e-ls2) (build-libcall #f src sexpr for-each2 e-proc e-ls1 e-ls2)] - [(e-proc e-ls . e-ls*) #f]) - (define-inline 3 vector-map - [(e-proc e-ls) (build-libcall #f src sexpr vector-map1 e-proc e-ls)] - [(e-proc e-ls1 e-ls2) (build-libcall #f src sexpr vector-map2 e-proc e-ls1 e-ls2)] - [(e-proc e-ls . e-ls*) #f]) - (define-inline 3 vector-for-each - [(e-proc e-ls) (build-libcall #f src sexpr vector-for-each1 e-proc e-ls)] - [(e-proc e-ls1 e-ls2) (build-libcall #f src sexpr vector-for-each2 e-proc e-ls1 e-ls2)] - [(e-proc e-ls . e-ls*) #f]) - (define-inline 3 string-for-each - [(e-proc e-ls) (build-libcall #f src sexpr string-for-each1 e-proc e-ls)] - [(e-proc e-ls1 e-ls2) (build-libcall #f src sexpr string-for-each2 e-proc e-ls1 e-ls2)] - [(e-proc e-ls . e-ls*) #f]) - (define-inline 3 reverse - [(e) (build-libcall #f src sexpr reverse e)]) - (let () - (define inline-getprop - (lambda (plist-offset e-sym e-key e-dflt) - (let ([t-ls (make-assigned-tmp 't-ls)] [t-cdr (make-tmp 't-cdr)] [Ltop (make-local-label 'Ltop)]) - (bind #t (e-key e-dflt) - ; indirect symbol after evaluating e-key and e-dflt - `(let ([,t-ls ,(%mref ,e-sym ,plist-offset)]) - (label ,Ltop - (if ,(%inline eq? ,t-ls ,(%constant snil)) - ,e-dflt - (let ([,t-cdr ,(%mref ,t-ls ,(constant pair-cdr-disp))]) - (if ,(%inline eq? ,(%mref ,t-ls ,(constant pair-car-disp)) ,e-key) - ,(%mref ,t-cdr ,(constant pair-car-disp)) - (seq - (set! ,t-ls ,(%mref ,t-cdr ,(constant pair-cdr-disp))) - (goto ,Ltop))))))))))) - (define-inline 3 getprop - [(e-sym e-key) (inline-getprop (constant symbol-plist-disp) e-sym e-key (%constant sfalse))] - [(e-sym e-key e-dflt) (inline-getprop (constant symbol-plist-disp) e-sym e-key e-dflt)]) - (define-inline 3 $sgetprop - [(e-sym e-key e-dflt) (inline-getprop (constant symbol-splist-disp) e-sym e-key e-dflt)])) - (define-inline 3 assq - [(e-key e-ls) - (let ([t-ls (make-assigned-tmp 't-ls)] [Ltop (make-local-label 'Ltop)]) - (bind #t (e-key) - `(let ([,t-ls ,e-ls]) - (label ,Ltop - (if ,(%inline eq? ,t-ls ,(%constant snil)) - ,(%constant sfalse) - ,(bind #t ([t-a (%mref ,t-ls ,(constant pair-car-disp))]) - `(if ,(%inline eq? ,(%mref ,t-a ,(constant pair-car-disp)) ,e-key) - ,t-a - (seq - (set! ,t-ls ,(%mref ,t-ls ,(constant pair-cdr-disp))) - (goto ,Ltop)))))))))]) - (define-inline 3 length - [(e-ls) - (let ([t-ls (make-assigned-tmp 't-ls)] - [t-n (make-assigned-tmp 't-n)] - [Ltop (make-local-label 'Ltop)]) - (bind #t (e-ls) - `(if ,(%inline eq? ,e-ls ,(%constant snil)) - (immediate ,(fix 0)) - (let ([,t-ls ,e-ls] [,t-n (immediate ,(fix 0))]) - (label ,Ltop - ,(%seq - (set! ,t-ls ,(%mref ,t-ls ,(constant pair-cdr-disp))) - (set! ,t-n ,(%inline + ,t-n (immediate ,(fix 1)))) - (if ,(%inline eq? ,t-ls ,(%constant snil)) - ,t-n - (goto ,Ltop))))))))]) - (define-inline 3 append - ; TODO: hand-coded library routine that allocates the new pairs in a block - [() (%constant snil)] - [(e-ls) e-ls] - [(e-ls1 e-ls2) (build-libcall #f src sexpr append e-ls1 e-ls2)] - [(e-ls1 e-ls2 e-ls3) - (build-libcall #f src sexpr append e-ls1 - (build-libcall #f #f sexpr append e-ls2 e-ls3))] - [(e-ls . e-ls*) #f]) - (define-inline 3 apply - [(e0 e1) (build-libcall #f src sexpr apply0 e0 e1)] - [(e0 e1 e2) (build-libcall #f src sexpr apply1 e0 e1 e2)] - [(e0 e1 e2 e3) (build-libcall #f src sexpr apply2 e0 e1 e2 e3)] - [(e0 e1 e2 e3 e4) (build-libcall #f src sexpr apply3 e0 e1 e2 e3 e4)] - [(e0 e1 . e*) #f]) - (define-inline 2 fxsll - [(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)]) - (define-inline 3 call-with-current-continuation - [(e) (build-libcall #f src sexpr callcc e)]) - (define-inline 3 call/cc - [(e) (build-libcall #f src sexpr callcc e)]) - (define-inline 3 call/1cc - [(e) (build-libcall #f src sexpr call1cc e)]) - (define-inline 2 $event - [() (build-libcall #f src sexpr event)]) - (define-inline 3 eq-hashtable-ref - [(e1 e2 e3) (build-libcall #f src sexpr eq-hashtable-ref e1 e2 e3)]) - (define-inline 3 eq-hashtable-ref-cell - [(e1 e2) (build-libcall #f src sexpr eq-hashtable-ref-cell e1 e2)]) - (define-inline 3 eq-hashtable-contains? - [(e1 e2) (build-libcall #f src sexpr eq-hashtable-contains? e1 e2)]) - (define-inline 3 eq-hashtable-set! - [(e1 e2 e3) (build-libcall #f src sexpr eq-hashtable-set! e1 e2 e3)]) - (define-inline 3 eq-hashtable-update! - [(e1 e2 e3 e4) (build-libcall #f src sexpr eq-hashtable-update! e1 e2 e3 e4)]) - (define-inline 3 eq-hashtable-cell - [(e1 e2 e3) (build-libcall #f src sexpr eq-hashtable-cell e1 e2 e3)]) - (define-inline 3 eq-hashtable-try-atomic-cell - [(e1 e2 e3) (build-libcall #f src sexpr eq-hashtable-try-atomic-cell e1 e2 e3)]) - (define-inline 3 eq-hashtable-delete! - [(e1 e2) (build-libcall #f src sexpr eq-hashtable-delete! e1 e2)]) - (define-inline 3 symbol-hashtable-ref - [(e1 e2 e3) (build-libcall #f src sexpr symbol-hashtable-ref e1 e2 e3)]) - (define-inline 3 symbol-hashtable-ref-cell - [(e1 e2) (build-libcall #f src sexpr symbol-hashtable-ref-cell e1 e2)]) - (define-inline 3 symbol-hashtable-contains? - [(e1 e2) (build-libcall #f src sexpr symbol-hashtable-contains? e1 e2)]) - (define-inline 3 symbol-hashtable-set! - [(e1 e2 e3) (build-libcall #f src sexpr symbol-hashtable-set! e1 e2 e3)]) - (define-inline 3 symbol-hashtable-update! - [(e1 e2 e3 e4) (build-libcall #f src sexpr symbol-hashtable-update! e1 e2 e3 e4)]) - (define-inline 3 symbol-hashtable-cell - [(e1 e2 e3) (build-libcall #f src sexpr symbol-hashtable-cell e1 e2 e3)]) - (define-inline 3 symbol-hashtable-delete! - [(e1 e2) (build-libcall #f src sexpr symbol-hashtable-delete! e1 e2)]) - (define-inline 2 bytevector-s8-set! - [(e1 e2 e3) (build-libcall #f src sexpr bytevector-s8-set! e1 e2 e3)]) - (define-inline 2 bytevector-u8-set! - [(e1 e2 e3) (build-libcall #f src sexpr bytevector-u8-set! e1 e2 e3)]) - (define-inline 3 bytevector=? - [(e1 e2) (build-libcall #f src sexpr bytevector=? e1 e2)]) - (let () - (define eqvop-flonum - (lambda (e1 e2) - (nanopass-case (L7 Expr) e1 - [(quote ,d) (and (flonum? d) - (bind #t (e2) - (build-and - (%type-check mask-flonum type-flonum ,e2) - (if ($nan? d) - ;; NaN: invert `fl=` on self - (bind #t (e2) - (build-not (build-fl= e2 e2))) - ;; Non-NaN: compare bits - (constant-case ptr-bits - [(32) - (safe-assert (not (eq? (constant native-endianness) 'unknown))) - (let ([d0 (if (eq? (constant native-endianness) (native-endianness)) 0 4)]) - (let ([word1 ($object-ref 'integer-32 d (fx+ (constant flonum-data-disp) d0))] - [word2 ($object-ref 'integer-32 d (fx+ (constant flonum-data-disp) (fx- 4 d0)))]) - (build-and - (%inline eq? - ,(%mref ,e2 ,(constant flonum-data-disp)) - (immediate ,word1)) - (%inline eq? - ,(%mref ,e2 ,(fx+ (constant flonum-data-disp) 4)) - (immediate ,word2)))))] - [(64) - (let ([word ($object-ref 'integer-64 d (constant flonum-data-disp))]) - (%inline eq? - ,(%mref ,e2 ,(constant flonum-data-disp)) - (immediate ,word)))] - [else ($oops 'compiler-internal - "eqv doesn't handle ptr-bits = ~s" - (constant ptr-bits))])))))] - [else #f]))) - (define eqok-help? - (lambda (obj) - (or (symbol? obj) - (char? obj) - (target-fixnum? obj) - (null? obj) - (boolean? obj) - (eqv? obj "") - (eqv? obj '#()) - (eqv? obj '#vu8()) - (eqv? obj '#0=#0#) - (eq? obj (void)) - (eof-object? obj) - (bwp-object? obj) - ($unbound-object? obj) - (eqv? obj '#vfx())))) - (define eqvok-help? number?) - (define eqvnever-help? (lambda (obj) (not (number? obj)))) - (define e*ok? - (lambda (e*ok-help?) - (lambda (e) - (nanopass-case (L7 Expr) e - [(quote ,d) (e*ok-help? d)] - [else #f])))) - (define eqok? (e*ok? eqok-help?)) - (define eqvok? (e*ok? eqvok-help?)) - (define eqvnever? (e*ok? eqvnever-help?)) - (define-inline 2 eqv? - [(e1 e2) (or (eqvop-null-fptr e1 e2) - (relop-length RELOP= e1 e2) - (eqvop-flonum e1 e2) - (eqvop-flonum e2 e1) - (if (or (eqok? e1) (eqok? e2) - (eqvnever? e1) (eqvnever? e2)) - (build-eq? e1 e2) - (build-eqv? src sexpr e1 e2)))]) - (let () - (define xform-equal? - (lambda (src sexpr e1 e2) - (nanopass-case (L7 Expr) e1 - [(quote ,d1) - (let xform ([d1 d1] [e2 e2] [n 3] [k (lambda (e n) e)]) - (if (eqok-help? d1) - (k (build-eq? `(quote ,d1) e2) n) - (if (eqvok-help? d1) - (k (build-eqv? src sexpr `(quote ,d1) e2) n) - (and (fx> n 0) - (pair? d1) - (let-values ([(e2 dobind) (binder #t 'ptr e2)]) - (xform (car d1) (build-car e2) (fx- n 1) - (lambda (a n) - (xform (cdr d1) (build-cdr e2) n - (lambda (d n) - (k (dobind - (build-and - (build-pair? e2) - (build-and a d))) - n))))))))))] - [else #f]))) - (define-inline 2 equal? - [(e1 e2) (or (eqvop-null-fptr e1 e2) - (relop-length RELOP= e1 e2) - (xform-equal? src sexpr e1 e2) - (xform-equal? src sexpr e2 e1))])) - (let () - (define mem*ok? - (lambda (e*ok-help?) - (lambda (x) - (nanopass-case (L7 Expr) x - [(quote ,d) - (and (list? d) - (let f ([d d]) - (or (null? d) - (and (e*ok-help? (car d)) - (f (cdr d))))))] - [else #f])))) - (define memqok? (mem*ok? eqok-help?)) - (define memvok? (mem*ok? eqvok-help?)) - (define mem*->e*?s - (lambda (build-e*? limit) - (lambda (e-key e-ls) - (nanopass-case (L7 Expr) e-ls - [(quote ,d) - (and (let f ([d d] [n 0]) - (or (null? d) - (and (pair? d) - (fx< n limit) - (f (cdr d) (fx1+ n))))) - (bind #t (e-key) - (let f ([ls d]) - (if (null? ls) - `(quote #f) - `(if ,(build-e*? e-key `(quote ,(car ls))) - (quote ,ls) - ,(f (cdr ls)))))))] - [else #f])))) - (define memq->eq?s (mem*->e*?s build-eq? 8)) - (define (memv->eqv?s src sexpr) (mem*->e*?s (make-build-eqv? src sexpr) 4)) - (define do-memq - (lambda (src sexpr e-key e-ls) - (or (memq->eq?s e-key e-ls) - (let ([t-ls (make-assigned-tmp 't-ls)] [Ltop (make-local-label 'Ltop)]) - (bind #t (e-key) - `(let ([,t-ls ,e-ls]) - (label ,Ltop - (if ,(%inline eq? ,t-ls ,(%constant snil)) - ,(%constant sfalse) - (if ,(%inline eq? ,(%mref ,t-ls ,(constant pair-car-disp)) ,e-key) - ,t-ls - (seq - (set! ,t-ls ,(%mref ,t-ls ,(constant pair-cdr-disp))) - (goto ,Ltop))))))))))) - (define do-memv - (lambda (src sexpr e-key e-ls) - (or ((memv->eqv?s src sexpr) e-key e-ls) - (build-libcall #f src sexpr memv e-key e-ls)))) - (define-inline 3 memq - [(e-key e-ls) (do-memq src sexpr e-key e-ls)]) - (define-inline 3 memv - [(e-key e-ls) - (if (or (eqok? e-key) (memqok? e-ls)) - (do-memq src sexpr e-key e-ls) - (do-memv src sexpr e-key e-ls))]) - (define-inline 3 member - [(e-key e-ls) - (if (or (eqok? e-key) (memqok? e-ls)) - (do-memq src sexpr e-key e-ls) - (and (or (eqvok? e-key) (memvok? e-ls)) - (do-memv src sexpr e-key e-ls)))]) - (define-inline 2 memq - [(e-key e-ls) (memq->eq?s e-key e-ls)]) - (define-inline 2 memv - [(e-key e-ls) (or (and (memqok? e-ls) (memq->eq?s e-key e-ls)) - ((memv->eqv?s src sexpr) e-key e-ls))]) - (define-inline 2 member - [(e-key e-ls) (or (and (memqok? e-ls) (memq->eq?s e-key e-ls)) - (and (memvok? e-ls) ((memv->eqv?s src sexpr) e-key e-ls)))]))) - ; NB: for all of the I/O routines, consider putting optimize-level 2 code out-of-line - ; w/o going all the way to the port handler, i.e., always defer to library routine but - ; have library routine do the checks and run the optimize-level 3 version...this could - ; save a lot of code - ; NB: verify that the inline checks don't always fail, i.e., don't always send us to the - ; library routine - (let () - (define (go src sexpr e-p check? update? do-libcall) - (let ([Llib (and check? (make-local-label 'Llib))]) - (define maybe-add-port-check - (lambda (e-p body) - (if Llib - `(if (if ,(%type-check mask-typed-object type-typed-object ,e-p) - ,(%type-check mask-binary-input-port type-binary-input-port - ,(%mref ,e-p ,(constant typed-object-type-disp))) - ,(%constant sfalse)) - ,body - (goto ,Llib)) - body))) - (define maybe-add-update - (lambda (t0 e-icount body) - (if update? - `(seq - (set! ,e-icount ,(%inline + ,t0 (immediate 1))) - ,body) - body))) - (bind #t (e-p) - (let ([e-icount (%mref ,e-p ,(constant port-icount-disp))]) - (maybe-add-port-check e-p - (bind #t ([t0 e-icount]) - `(if ,(%inline eq? ,t0 (immediate 0)) - ,(maybe-add-label Llib (do-libcall src sexpr e-p)) - ,(maybe-add-update t0 e-icount - ; TODO: this doesn't completely fall away when used in effect context - (build-fix - `(inline ,(make-info-load 'unsigned-8 #f) ,%load - ,t0 - ,(%mref ,e-p ,(constant port-ilast-disp)) - (immediate 0))))))))))) - (define (unsafe-lookahead-u8-libcall src sexpr e-p) (build-libcall #t src sexpr unsafe-lookahead-u8 e-p)) - (define (safe-lookahead-u8-libcall src sexpr e-p) (build-libcall #t src sexpr safe-lookahead-u8 e-p)) - (define (unsafe-get-u8-libcall src sexpr e-p) (build-libcall #t src sexpr unsafe-get-u8 e-p)) - (define (safe-get-u8-libcall src sexpr e-p) (build-libcall #t src sexpr safe-get-u8 e-p)) - (define-inline 3 lookahead-u8 - [(e-p) (go src sexpr e-p #f #f unsafe-lookahead-u8-libcall)]) - (define-inline 2 lookahead-u8 - [(e-p) (go src sexpr e-p #t #f safe-lookahead-u8-libcall)]) - (define-inline 3 get-u8 - [(e-p) (go src sexpr e-p #f #t unsafe-get-u8-libcall)]) - (define-inline 2 get-u8 - [(e-p) (go src sexpr e-p #t #t safe-get-u8-libcall)])) - (let () - (define (go src sexpr e-p check? update? do-libcall) - (let ([Llib (and check? (make-local-label 'Llib))]) - (define maybe-add-port-check - (lambda (e-p body) - (if Llib - `(if (if ,(%type-check mask-typed-object type-typed-object ,e-p) - ,(%type-check mask-textual-input-port type-textual-input-port - ,(%mref ,e-p ,(constant typed-object-type-disp))) - ,(%constant sfalse)) - ,body - (goto ,Llib)) - body))) - (define maybe-add-update - (lambda (t0 e-icount body) - (if update? - `(seq - (set! ,e-icount ,(%inline + ,t0 ,(%constant string-char-bytes))) - ,body) - body))) - (bind #t (e-p) - (let ([e-icount (%mref ,e-p ,(constant port-icount-disp))]) - (maybe-add-port-check e-p - (bind #t ([t0 e-icount]) - `(if ,(%inline eq? ,t0 (immediate 0)) - ,(maybe-add-label Llib (do-libcall src sexpr e-p)) - ,(maybe-add-update t0 e-icount - ; TODO: this doesn't completely fall away when used in effect context - `(inline ,(make-info-load (string-char-type) #f) ,%load - ,t0 - ,(%mref ,e-p ,(constant port-ilast-disp)) - (immediate 0)))))))))) - (define (unsafe-lookahead-char-libcall src sexpr e-p) (build-libcall #t src sexpr unsafe-lookahead-char e-p)) - (define (safe-lookahead-char-libcall src sexpr e-p) (build-libcall #t src sexpr safe-lookahead-char e-p)) - (define (unsafe-peek-char-libcall src sexpr e-p) (build-libcall #t src sexpr unsafe-peek-char e-p)) - (define (safe-peek-char-libcall src sexpr e-p) (build-libcall #t src sexpr safe-peek-char e-p)) - (define (unsafe-get-char-libcall src sexpr e-p) (build-libcall #t src sexpr unsafe-get-char e-p)) - (define (safe-get-char-libcall src sexpr e-p) (build-libcall #t src sexpr safe-get-char e-p)) - (define (unsafe-read-char-libcall src sexpr e-p) (build-libcall #t src sexpr unsafe-read-char e-p)) - (define (safe-read-char-libcall src sexpr e-p) (build-libcall #t src sexpr safe-read-char e-p)) - (define-inline 3 lookahead-char - [(e-p) (go src sexpr e-p #f #f unsafe-lookahead-char-libcall)]) - (define-inline 2 lookahead-char - [(e-p) (go src sexpr e-p #t #f safe-lookahead-char-libcall)]) - (define-inline 3 peek-char - [() (go src sexpr (%tc-ref current-input) #f #f unsafe-peek-char-libcall)] - [(e-p) (go src sexpr e-p #f #f unsafe-peek-char-libcall)]) - (define-inline 2 peek-char - [() (go src sexpr (%tc-ref current-input) #f #f unsafe-peek-char-libcall)] - [(e-p) (go src sexpr e-p #t #f safe-peek-char-libcall)]) - (define-inline 3 get-char - [(e-p) (go src sexpr e-p #f #t unsafe-get-char-libcall)]) - (define-inline 2 get-char - [(e-p) (go src sexpr e-p #t #t safe-get-char-libcall)]) - (define-inline 3 read-char - [() (go src sexpr (%tc-ref current-input) #f #t unsafe-read-char-libcall)] - [(e-p) (go src sexpr e-p #f #t unsafe-read-char-libcall)]) - (define-inline 2 read-char - [() (go src sexpr (%tc-ref current-input) #f #t unsafe-read-char-libcall)] - [(e-p) (go src sexpr e-p #t #t safe-read-char-libcall)])) - (let () - (define (go src sexpr e-p e-c check-port? check-char? do-libcall) - (let ([const-char? (constant? char? e-c)]) - (let ([Llib (and (or check-char? check-port? (not const-char?)) (make-local-label 'Llib))]) - (define maybe-add-port-check - (lambda (e-p body) - (if check-port? - `(if (if ,(%type-check mask-typed-object type-typed-object ,e-p) - ,(%type-check mask-textual-input-port type-textual-input-port - ,(%mref ,e-p ,(constant typed-object-type-disp))) - ,(%constant sfalse)) - ,body - (goto ,Llib)) - body))) - (define maybe-add-eof-check - (lambda (e-c body) - (if const-char? - body - `(if ,(%inline eq? ,e-c ,(%constant seof)) - (goto ,Llib) - ,body)))) - (define maybe-add-char-check - (lambda (e-c body) - (if check-char? - `(if ,(%type-check mask-char type-char ,e-c) - ,body - (goto ,Llib)) - body))) - (bind #t (e-c e-p) - (let ([e-icount (%mref ,e-p ,(constant port-icount-disp))]) - (maybe-add-port-check e-p - (maybe-add-eof-check e-c - (maybe-add-char-check e-c - (bind #t ([t0 e-icount]) - `(if ,(%inline eq? ,t0 - ,(%inline - - ,(%inline + - ,(%mref ,e-p ,(constant port-ibuffer-disp)) - ,(%constant string-data-disp)) - ,(%mref ,e-p ,(constant port-ilast-disp)))) - ,(maybe-add-label Llib (do-libcall src sexpr e-p e-c)) - (set! ,e-icount ,(%inline - ,t0 ,(%constant string-char-bytes))))))))))))) - (define (unsafe-unget-char-libcall src sexpr e-p e-c) (build-libcall #t src sexpr unsafe-unget-char e-p e-c)) - (define (safe-unget-char-libcall src sexpr e-p e-c) (build-libcall #t src sexpr safe-unget-char e-p e-c)) - (define (unsafe-unread-char-libcall src sexpr e-p e-c) (build-libcall #t src sexpr unsafe-unread-char e-c e-p)) - (define (safe-unread-char-libcall src sexpr e-p e-c) (build-libcall #t src sexpr safe-unread-char e-c e-p)) - (define-inline 3 unget-char - [(e-p e-c) (go src sexpr e-p e-c #f #f unsafe-unget-char-libcall)]) - (define-inline 2 unget-char - [(e-p e-c) (go src sexpr e-p e-c #t (not (constant? char? e-c)) safe-unget-char-libcall)]) - (define-inline 3 unread-char - [(e-c) (go src sexpr (%tc-ref current-input) e-c #f #f unsafe-unread-char-libcall)] - [(e-c e-p) (go src sexpr e-p e-c #f #f unsafe-unread-char-libcall)]) - (define-inline 2 unread-char - [(e-c) (if (constant? char? e-c) - (go src sexpr (%tc-ref current-input) e-c #f #f unsafe-unread-char-libcall) - (go src sexpr (%tc-ref current-input) e-c #f #t safe-unread-char-libcall))] - [(e-c e-p) (go src sexpr e-p e-c #t (not (constant? char? e-c)) safe-unread-char-libcall)])) - (let () - (define octet? - (lambda (x) - (and (fixnum? x) (fx<= 0 x 255)))) - (define maybe-add-octet-check - (lambda (check-octet? Llib e-o body) - (if check-octet? - `(if ,(%type-check mask-octet type-octet ,e-o) - ,body - (goto ,Llib)) - body))) - (let () - (define (go src sexpr e-p e-o check-port? check-octet? do-libcall) - (let ([const-octet? (constant? octet? e-o)]) - (let ([Llib (and (or check-octet? check-port? (not const-octet?)) (make-local-label 'Llib))]) - (define maybe-add-port-check - (lambda (e-p body) - (if check-port? - `(if (if ,(%type-check mask-typed-object type-typed-object ,e-p) - ,(%type-check mask-binary-input-port type-binary-input-port - ,(%mref ,e-p ,(constant typed-object-type-disp))) - ,(%constant sfalse)) - ,body - (goto ,Llib)) - body))) - (define maybe-add-eof-check - (lambda (e-o body) - (if const-octet? - body - `(if ,(%inline eq? ,e-o ,(%constant seof)) - (goto ,Llib) - ,body)))) - (bind #t (e-o e-p) - (let ([e-icount (%mref ,e-p ,(constant port-icount-disp))]) - (maybe-add-port-check e-p - (maybe-add-eof-check e-o - (maybe-add-octet-check check-octet? Llib e-o - (bind #t ([t0 e-icount]) - `(if ,(%inline eq? ,t0 - ,(%inline - - ,(%inline + - ,(%mref ,e-p ,(constant port-ibuffer-disp)) - ,(%constant bytevector-data-disp)) - ,(%mref ,e-p ,(constant port-ilast-disp)))) - ,(maybe-add-label Llib (do-libcall src sexpr e-p e-o)) - (set! ,e-icount ,(%inline - ,t0 (immediate 1))))))))))))) - (define (unsafe-unget-u8-libcall src sexpr e-p e-o) (build-libcall #t src sexpr unsafe-unget-u8 e-p e-o)) - (define (safe-unget-u8-libcall src sexpr e-p e-o) (build-libcall #t src sexpr safe-unget-u8 e-p e-o)) - (define-inline 3 unget-u8 - [(e-p e-o) (go src sexpr e-p e-o #f #f unsafe-unget-u8-libcall)]) - (define-inline 2 unget-u8 - [(e-p e-o) (go src sexpr e-p e-o #t (not (constant? octet? e-o)) safe-unget-u8-libcall)])) - (let () - (define (go src sexpr e-p e-o check-port? check-octet? do-libcall) - (let ([Llib (and (or check-octet? check-port?) (make-local-label 'Llib))]) - (define maybe-add-port-check - (lambda (e-p body) - (if check-port? - `(if (if ,(%type-check mask-typed-object type-typed-object ,e-p) - ,(%type-check mask-binary-output-port type-binary-output-port - ,(%mref ,e-p ,(constant typed-object-type-disp))) - ,(%constant sfalse)) - ,body - (goto ,Llib)) - body))) - (define add-update - (lambda (t0 e-ocount body) - `(seq - (set! ,e-ocount ,(%inline + ,t0 (immediate 1))) - ,body))) - (bind check-octet? (e-o) - (bind #t (e-p) - (let ([e-ocount (%mref ,e-p ,(constant port-ocount-disp))]) - (maybe-add-octet-check check-octet? Llib e-o - (maybe-add-port-check e-p - (bind #t ([t0 e-ocount]) - `(if ,(%inline eq? ,t0 (immediate 0)) - ,(maybe-add-label Llib (do-libcall src sexpr e-o e-p)) - ,(add-update t0 e-ocount - `(inline ,(make-info-load 'unsigned-8 #f) ,%store - ,t0 - ,(%mref ,e-p ,(constant port-olast-disp)) - (immediate 0) - ,(build-unfix e-o)))))))))))) - (define (unsafe-put-u8-libcall src sexpr e-o e-p) (build-libcall #t src sexpr unsafe-put-u8 e-p e-o)) - (define (safe-put-u8-libcall src sexpr e-o e-p) (build-libcall #t src sexpr safe-put-u8 e-p e-o)) - (define-inline 3 put-u8 - [(e-p e-o) (go src sexpr e-p e-o #f #f unsafe-put-u8-libcall)]) - (define-inline 2 put-u8 - [(e-p e-o) (go src sexpr e-p e-o #t (not (constant? octet? e-o)) safe-put-u8-libcall)]))) - (let () - (define (go src sexpr e-p e-c check-port? check-char? do-libcall) - (let ([Llib (and (or check-char? check-port?) (make-local-label 'Llib))]) - (define maybe-add-char-check - (lambda (e-c body) - (if check-char? - `(if ,(%type-check mask-char type-char ,e-c) - ,body - (goto ,Llib)) - body))) - (define maybe-add-port-check - (lambda (e-p body) - (if check-port? - `(if (if ,(%type-check mask-typed-object type-typed-object ,e-p) - ,(%type-check mask-textual-output-port type-textual-output-port - ,(%mref ,e-p ,(constant typed-object-type-disp))) - ,(%constant sfalse)) - ,body - (goto ,Llib)) - body))) - (define add-update - (lambda (t0 e-ocount body) - `(seq - (set! ,e-ocount ,(%inline + ,t0 ,(%constant string-char-bytes))) - ,body))) - (bind check-char? (e-c) - (bind #t (e-p) - (let ([e-ocount (%mref ,e-p ,(constant port-ocount-disp))]) - (maybe-add-char-check e-c - (maybe-add-port-check e-p - (bind #t ([t0 e-ocount]) - `(if ,(%inline eq? ,t0 (immediate 0)) - ,(maybe-add-label Llib (do-libcall src sexpr e-c e-p)) - ,(add-update t0 e-ocount - `(inline ,(make-info-load (string-char-type) #f) ,%store - ,t0 - ,(%mref ,e-p ,(constant port-olast-disp)) - (immediate 0) - ,e-c))))))))))) - (define (unsafe-put-char-libcall src sexpr e-c e-p) (build-libcall #t src sexpr unsafe-put-char e-p e-c)) - (define (safe-put-char-libcall src sexpr e-c e-p) (build-libcall #t src sexpr safe-put-char e-p e-c)) - (define (unsafe-write-char-libcall src sexpr e-c e-p) (build-libcall #t src sexpr unsafe-write-char e-c e-p)) - (define (safe-write-char-libcall src sexpr e-c e-p) (build-libcall #t src sexpr safe-write-char e-c e-p)) - (define (unsafe-newline-libcall src sexpr e-c e-p) (build-libcall #t src sexpr unsafe-newline e-p)) - (define (safe-newline-libcall src sexpr e-c e-p) (build-libcall #t src sexpr safe-newline e-p)) - (define-inline 3 put-char - [(e-p e-c) (go src sexpr e-p e-c #f #f unsafe-put-char-libcall)]) - (define-inline 2 put-char - [(e-p e-c) (go src sexpr e-p e-c #t (not (constant? char? e-c)) safe-put-char-libcall)]) - (define-inline 3 write-char - [(e-c) (go src sexpr (%tc-ref current-output) e-c #f #f unsafe-write-char-libcall)] - [(e-c e-p) (go src sexpr e-p e-c #f #f unsafe-write-char-libcall)]) - (define-inline 2 write-char - [(e-c) (if (constant? char? e-c) - (go src sexpr (%tc-ref current-output) e-c #f #f unsafe-write-char-libcall) - (go src sexpr (%tc-ref current-output) e-c #f #t safe-write-char-libcall))] - [(e-c e-p) (go src sexpr e-p e-c #t (not (constant? char? e-c)) safe-write-char-libcall)]) - (define-inline 3 newline - [() (go src sexpr (%tc-ref current-output) `(quote #\newline) #f #f unsafe-newline-libcall)] - [(e-p) (go src sexpr e-p `(quote #\newline) #f #f unsafe-newline-libcall)]) - (define-inline 2 newline - [() (go src sexpr (%tc-ref current-output) `(quote #\newline) #f #f unsafe-newline-libcall)] - [(e-p) (go src sexpr e-p `(quote #\newline) #t #f safe-newline-libcall)])) - (let () - (define build-fxop? - (lambda (op overflow-flag e1 e2 adjust k) - (let ([Lfail (make-local-label 'Lfail)]) - (bind #t (e1 e2) - `(if ,(build-fixnums? (list e1 e2)) - ,(bind #f ([t `(inline ,null-info ,op ,e1 ,(adjust e2))]) - `(if (inline ,(make-info-condition-code overflow-flag #f #t) ,%condition-code) - (label ,Lfail ,(k e1 e2)) - ,t)) - (goto ,Lfail)))))) - (define-inline 2 + - [() `(immediate ,(fix 0))] - [(e) (build-fxop? %+/ovfl 'overflow e `(quote 0) values (lambda (e1 e2) (build-libcall #t src sexpr + e1 e2)))] - [(e1 e2) (build-fxop? %+/ovfl 'overflow e1 e2 values (lambda (e1 e2) (build-libcall #t src sexpr + e1 e2)))] - ; TODO: handle 3-operand case ala fx+, w/3-operand library + - [(e1 . e*) #f]) - (define-inline 2 * - [() `(immediate ,(fix 1))] - [(e) (build-fxop? %*/ovfl 'multiply-overflow e `(quote 1) build-unfix (lambda (e1 e2) (build-libcall #t src sexpr * e1 e2)))] - ; TODO: swap e1 & e2 if e1 is constant - [(e1 e2) (build-fxop? %*/ovfl 'multiply-overflow e1 e2 build-unfix (lambda (e1 e2) (build-libcall #t src sexpr * e1 e2)))] - ; TODO: handle 3-operand case ala fx+, w/3-operand library * - [(e1 . e*) #f]) - (define-inline 2 - - [(e) (build-fxop? %-/ovfl 'overflow `(quote 0) e values (lambda (e1 e2) (build-libcall #t src sexpr - e1 e2)))] - [(e1 e2) (build-fxop? %-/ovfl 'overflow e1 e2 values (lambda (e1 e2) (build-libcall #t src sexpr - e1 e2)))] - ; TODO: handle 3-operand case ala fx+, w/3-operand library - - [(e1 e2 . e*) #f])) - (let () - (define build-fxop? - (lambda (op e k) - (let ([Lfail (make-local-label 'Lfail)]) - (bind #t (e) - `(if ,(%type-check mask-fixnum type-fixnum ,e) - ,(bind #f ([t `(inline ,null-info ,op ,e (immediate ,(fix 1)))]) - `(if (inline ,(make-info-condition-code 'overflow #f #t) ,%condition-code) - (label ,Lfail ,(k e)) - ,t)) - (goto ,Lfail)))))) - - (define-syntax define-inline-1op - (syntax-rules () - [(_ op name) - (define-inline 2 name - [(e) (build-fxop? op e (lambda (e) (build-libcall #t src sexpr name e)))])])) - - (define-inline-1op %-/ovfl 1-) - (define-inline-1op %-/ovfl -1+) - (define-inline-1op %-/ovfl sub1) - (define-inline-1op %+/ovfl 1+) - (define-inline-1op %+/ovfl add1)) - - (define-inline 2 / - [(e) (build-libcall #f src sexpr / `(immediate ,(fix 1)) e)] - [(e1 e2) (build-libcall #f src sexpr / e1 e2)] - [(e1 . e*) #f]) - - (let () - (define (zgo src sexpr e e1 e2) - (build-simple-or - (%inline eq? ,e (immediate 0)) - `(if ,(build-fixnums? (list e)) - ,(%constant sfalse) - ,(build-libcall #t src sexpr = e1 e2)))) - (define (go src sexpr e1 e2) - (or (eqvop-null-fptr e1 e2) - (relop-length RELOP= e1 e2) - (cond - [(constant? (lambda (x) (eqv? x 0)) e1) - (bind #t (e2) (zgo src sexpr e2 e1 e2))] - [(constant? (lambda (x) (eqv? x 0)) e2) - (bind #t (e1) (zgo src sexpr e1 e1 e2))] - [else (bind #t (e1 e2) - `(if ,(build-fixnums? (list e1 e2)) - ,(%inline eq? ,e1 ,e2) - ,(build-libcall #t src sexpr = e1 e2)))]))) - (define-inline 2 = - [(e1 e2) (go src sexpr e1 e2)] - [(e1 . e*) #f]) - (define-inline 2 r6rs:= - [(e1 e2) (go src sexpr e1 e2)] - [(e1 e2 . e*) #f])) - (let () - (define-syntax define-relop-inline - (syntax-rules () - [(_ name r6rs:name relop op) - (let () - (define builder - (lambda (e1 e2 libcall) - (or (relop-length relop e1 e2) - (bind #t (e1 e2) - `(if ,(build-fixnums? (list e1 e2)) - ,(%inline op ,e1 ,e2) - ,(libcall e1 e2)))))) - (define-inline 2 name - [(e1 e2) - (builder e1 e2 - (lambda (e1 e2) (build-libcall #t src sexpr name e1 e2)))] - ; TODO: handle 3-operand case w/3-operand library routine - [(e1 . e*) #f]) - (define-inline 2 r6rs:name - [(e1 e2) - (builder e1 e2 - (lambda (e1 e2) (build-libcall #t src sexpr name e1 e2)))] - ; TODO: handle 3-operand case w/3-operand library routine - [(e1 e2 . e*) #f]))])) - (define-relop-inline < r6rs:< RELOP< <) - (define-relop-inline <= r6rs:<= RELOP<= <=) - (define-relop-inline >= r6rs:>= RELOP>= >=) - (define-relop-inline > r6rs:> RELOP> >)) - (define-inline 3 positive? ; 3 so opt-level 2 errors come from positive? - [(e) (handle-prim src sexpr 3 '> (list e `(quote 0)))]) - (define-inline 3 nonnegative? ; 3 so opt-level 2 errors come from nonnegative? - [(e) (handle-prim src sexpr 3 '>= (list e `(quote 0)))]) - (define-inline 3 negative? ; 3 so opt-level 2 errors come from negative? - [(e) (handle-prim src sexpr 3 '< (list e `(quote 0)))]) - (define-inline 3 nonpositive? ; 3 so opt-level 2 errors come from nonpositive? - [(e) (handle-prim src sexpr 3 '<= (list e `(quote 0)))]) - (define-inline 2 zero? - [(e) - (or (relop-length RELOP= e) - (nanopass-case (L7 Expr) e - [(call ,info ,mdcl ,pr ,e) - (guard - (eq? (primref-name pr) 'ftype-pointer-address) - (all-set? (prim-mask unsafe) (primref-flags pr))) - (make-ftype-pointer-null? e)] - [else - (bind #t (e) - (build-simple-or - (%inline eq? ,e (immediate ,(fix 0))) - `(if ,(%type-check mask-fixnum type-fixnum ,e) - ,(%constant sfalse) - ,(build-libcall #t src sexpr zero? e))))]))]) - (define-inline 2 positive? [(e) (relop-length RELOP> e)]) - (define-inline 2 nonnegative? [(e) (relop-length RELOP>= e)]) - (define-inline 2 negative? [(e) (relop-length RELOP< e)]) - (define-inline 2 nonpositive? [(e) (relop-length RELOP<= e)]) - (let () - (define-syntax define-logorop-inline - (syntax-rules () - [(_ name ...) - (let () - (define build-logop - (lambda (src sexpr e1 e2 libcall) - (bind #t (e1 e2) - (bind #t ([t (%inline logor ,e1 ,e2)]) - `(if ,(%type-check mask-fixnum type-fixnum ,t) - ,t - ,(libcall src sexpr e1 e2)))))) - (let () - (define libcall (lambda (src sexpr e1 e2) (build-libcall #t src sexpr name e1 e2))) - (define-inline 2 name - [() `(immediate ,(fix 0))] - [(e) (build-logop src sexpr e `(immediate ,(fix 0)) libcall)] - [(e1 e2) (build-logop src sexpr e1 e2 libcall)] - [(e1 . e*) #f])) - ...)])) - (define-logorop-inline logor logior bitwise-ior)) - (let () - (define-syntax define-logop-inline - (syntax-rules () - [(_ op unit name ...) - (let () - (define build-logop - (lambda (src sexpr e1 e2 libcall) - (bind #t (e1 e2) - `(if ,(build-fixnums? (list e1 e2)) - ,(%inline op ,e1 ,e2) - ,(libcall src sexpr e1 e2))))) - (let () - (define libcall (lambda (src sexpr e1 e2) (build-libcall #t src sexpr name e1 e2))) - (define-inline 2 name - [() `(immediate ,(fix unit))] - [(e) (build-logop src sexpr e `(immediate ,(fix unit)) libcall)] - [(e1 e2) (build-logop src sexpr e1 e2 libcall)] - [(e1 . e*) #f])) - ...)])) - (define-logop-inline logand -1 logand bitwise-and) - (define-logop-inline logxor 0 logxor bitwise-xor)) - (let () - (define build-lognot - (lambda (e libcall) - (bind #t (e) - `(if ,(%type-check mask-fixnum type-fixnum ,e) - ,(%inline logxor ,e (immediate ,(fxlognot (constant mask-fixnum)))) - ,(libcall e))))) - - (define-inline 2 lognot - [(e) (build-lognot e (lambda (e) (build-libcall #t src sexpr lognot e)))]) - (define-inline 2 bitwise-not - [(e) (build-lognot e (lambda (e) (build-libcall #t src sexpr bitwise-not e)))])) - - (let () - (define build-logbit? - (lambda (e1 e2 libcall) - (or (nanopass-case (L7 Expr) e1 - [(quote ,d) - (or (and (and (fixnum? d) (fx<= 0 d (fx- (constant fixnum-bits) 2))) - (bind #t (e2) - `(if ,(%type-check mask-fixnum type-fixnum ,e2) - ,(%inline logtest ,e2 (immediate ,(fix (ash 1 d)))) - ,(libcall e1 e2)))) - (and (and (target-fixnum? d) (> d (fx- (constant fixnum-bits) 2))) - (bind #t (e2) - `(if ,(%type-check mask-fixnum type-fixnum ,e2) - ,(%inline < ,e2 (immediate ,(fix 0))) - ,(libcall e1 e2)))))] - [else #f]) - (bind #t (e1 e2) - `(if ,(build-and - (build-fixnums? (list e1 e2)) - (%inline u< ,e1 (immediate ,(fix (constant fixnum-bits))))) - ,(%inline logtest - ,(%inline sra ,e2 ,(build-unfix e1)) - (immediate ,(fix 1))) - ,(libcall e1 e2)))))) - - (define-inline 2 logbit? - [(e1 e2) (build-logbit? e1 e2 (lambda (e1 e2) (build-libcall #t src sexpr logbit? e1 e2)))]) - (define-inline 2 bitwise-bit-set? - [(e1 e2) (build-logbit? e2 e1 (lambda (e2 e1) (build-libcall #t src sexpr bitwise-bit-set? e1 e2)))])) - - (define-inline 2 logbit1 - [(e1 e2) (or (nanopass-case (L7 Expr) e1 - [(quote ,d) - (and (and (fixnum? d) (fx<= 0 d (fx- (constant fixnum-bits) 2))) - (bind #t (e2) - `(if ,(%type-check mask-fixnum type-fixnum ,e2) - ,(%inline logor ,e2 (immediate ,(fix (ash 1 d)))) - ,(build-libcall #t src sexpr logbit1 e1 e2))))] - [else #f]) - (bind #t (e1 e2) - `(if ,(build-and - (build-fixnums? (list e1 e2)) - (%inline u< ,e1 (immediate ,(fix (fx- (constant fixnum-bits) 1))))) - ,(%inline logor ,e2 - ,(%inline sll (immediate ,(fix 1)) ,(build-unfix e1))) - ,(build-libcall #t src sexpr logbit1 e1 e2))))]) - (define-inline 2 logbit0 - [(e1 e2) (or (nanopass-case (L7 Expr) e1 - [(quote ,d) - (and (and (fixnum? d) (fx<= 0 d (fx- (constant fixnum-bits) 2))) - (bind #t (e2) - `(if ,(%type-check mask-fixnum type-fixnum ,e2) - ,(%inline logand ,e2 (immediate ,(fix (lognot (ash 1 d))))) - ,(build-libcall #t src sexpr logbit0 e1 e2))))] - [else #f]) - (bind #t (e1 e2) - `(if ,(build-and - (build-fixnums? (list e1 e2)) - (%inline u< ,e1 (immediate ,(fix (fx- (constant fixnum-bits) 1))))) - ,(%inline logand ,e2 - ,(%inline lognot - ,(%inline sll (immediate ,(fix 1)) ,(build-unfix e1)))) - ,(build-libcall #t src sexpr logbit0 e1 e2))))]) - (define-inline 2 logtest - [(e1 e2) (bind #t (e1 e2) - `(if ,(build-fixnums? (list e1 e2)) - ,(%inline logtest ,e1 ,e2) - ,(build-libcall #t src sexpr logtest e1 e2)))]) - (define-inline 3 $flhash - [(e) (bind #t (e) - `(if ,(build-fl= e e) - ,(%inline logand - ,(%inline srl - ,(constant-case ptr-bits - [(32) (%inline + - ,(%mref ,e ,(constant flonum-data-disp)) - ,(%mref ,e ,(fx+ (constant flonum-data-disp) 4)))] - [(64) (%mref ,e ,(constant flonum-data-disp))]) - (immediate 1)) - (immediate ,(- (constant fixnum-factor)))) - ;; +nan.0 - (immediate ,(fix #xfa1e))))]) - (let () - (define build-flonum-extractor - (lambda (pos size e1) - (let ([cnt (- pos (constant fixnum-offset))] - [mask (* (- (expt 2 size) 1) (expt 2 (constant fixnum-offset)))]) - (%inline logand - ,(let ([body (constant-case native-endianness - [(unknown) - (constant-case ptr-bits - [(64) - (%inline srl ,(%mref ,e1 ,(constant flonum-data-disp)) (immediate 32))] - [(32) - (inline ,(make-info-unboxed-args '(#t)) ,%fpcastto/hi ,e)])] - [else - `(inline ,(make-info-load 'integer-32 #f) ,%load ,e1 ,%zero - (immediate ,(constant-case native-endianness - [(little) (fx+ (constant flonum-data-disp) 4)] - [(big) (constant flonum-data-disp)])))])]) - (let ([body (if (fx> cnt 0) - (%inline srl ,body (immediate ,cnt)) - body)]) - (if (fx< cnt 0) - (%inline sll ,body (immediate ,(fx- 0 cnt))) - body))) - (immediate ,mask))))) - - (define-inline 3 fllp - [(e) (build-flonum-extractor 19 12 e)]) - - (define-inline 3 $flonum-sign - [(e) (build-flonum-extractor 31 1 e)]) - - (define-inline 3 $flonum-exponent - [(e) (build-flonum-extractor 20 11 e)])) - - (define-inline 3 $fleqv? - [(e1 e2) - (bind #t (e1 e2) - `(if ,(build-fl= e1 e1) ; check e1 not +nan.0 - ,(constant-case ptr-bits - [(32) (build-and - (%inline eq? - ,(%mref ,e1 ,(constant flonum-data-disp)) - ,(%mref ,e2 ,(constant flonum-data-disp))) - (%inline eq? - ,(%mref ,e1 ,(fx+ (constant flonum-data-disp) 4)) - ,(%mref ,e2 ,(fx+ (constant flonum-data-disp) 4))))] - [(64) (%inline eq? - ,(%mref ,e1 ,(constant flonum-data-disp)) - ,(%mref ,e2 ,(constant flonum-data-disp)))] - [else ($oops 'compiler-internal - "$fleqv doesn't handle ptr-bits = ~s" - (constant ptr-bits))]) - ;; If e1 is +nan.0, see if e2 is +nan.0: - ,(build-not (build-fl= e2 e2))))]) - - (let () - (define build-fp-op-1 - (lambda (op e) - (bind #f fp (e) - (if (procedure? op) (op e) `(unboxed-fp (inline ,(make-info-unboxed-args '(#t)) ,op ,e)))))) - (define build-fp-op-2 - (lambda (op e1 e2) - (bind #f fp (e1 e2) - (if (procedure? op) (op e1 e2) `(unboxed-fp (inline ,(make-info-unboxed-args '(#t #t)) ,op ,e1 ,e2)))))) - (define build-fl-adjust-sign - (lambda (e combine base) - `(unboxed-fp - ,(constant-case ptr-bits - [(64) - (let ([t (make-tmp 'flsgn)]) - `(let ([,t (inline ,(make-info-unboxed-args '(#t)) ,%fpcastto ,e)]) - (inline ,null-info ,%fpcastfrom (inline ,null-info ,combine ,t ,base))))] - [(32) - (let ([thi (make-tmp 'flsgnh)] - [tlo (make-tmp 'flsgnl)]) - (bind #t fp (e) - `(let ([,thi (inline ,(make-info-unboxed-args '(#t)) ,%fpcastto/hi ,e)] - [,tlo (inline ,(make-info-unboxed-args '(#t)) ,%fpcastto/lo ,e)]) - (inline ,null-info ,%fpcastfrom (inline ,null-info ,combine ,thi ,base) ,tlo))))])))) - (define build-flabs - (lambda (e) - (build-fl-adjust-sign e %logand (%inline srl (immediate -1) (immediate 1))))) - (define build-flneg - (lambda (e) - (build-fl-adjust-sign e %logxor (%inline sll (immediate -1) (immediate ,(fx- (constant ptr-bits) 1)))))) - (define build-fl-call - (lambda (entry . e*) - `(foreign-call ,(with-output-language (Ltype Type) - (make-info-foreign '(atomic) (map (lambda (e) `(fp-double-float)) e*) `(fp-double-float) #t)) - (literal ,(make-info-literal #f 'entry entry 0)) - ,e* ...))) - - (define-inline 3 fl+ - [() `(quote 0.0)] - [(e) (ensure-single-valued e)] - [(e1 e2) (build-fp-op-2 %fp+ e1 e2)] - [(e1 . e*) (reduce-fp src sexpr 3 'fl+ e1 e*)]) - - (define-inline 3 fl* - [() `(quote 1.0)] - [(e) (ensure-single-valued e)] - [(e1 e2) (build-fp-op-2 %fp* e1 e2)] - [(e1 . e*) (reduce-fp src sexpr 3 'fl* e1 e*)]) - - (define-inline 3 fl- - [(e) (build-flneg e)] - [(e1 e2) (build-fp-op-2 %fp- e1 e2)] - [(e1 . e*) (reduce-fp src sexpr 3 'fl- e1 e*)]) - - (define-inline 3 fl/ - [(e) (build-fp-op-2 %fp/ `(quote 1.0) e)] - [(e1 e2) (build-fp-op-2 %fp/ e1 e2)] - [(e1 . e*) (reduce-fp src sexpr 3 'fl/ e1 e*)]) - - (define-inline 3 flsqrt - [(e) - (constant-case architecture - [(x86 x86_64 arm32 arm64 pb) (build-fp-op-1 %fpsqrt e)] - [(ppc32) (build-fl-call (lookup-c-entry flsqrt) e)])]) - - (define-inline 3 flsingle - [(e) (build-fp-op-1 %fpsingle e)]) - - (define-inline 3 flabs - [(e) (build-flabs e)]) - - (let () - (define-syntax define-fl-call - (syntax-rules () - [(_ id extra ...) - (define-inline 3 id - [(e) (build-fl-call (lookup-c-entry id) e)] - extra ...)])) - (define-syntax define-fl2-call - (syntax-rules () - [(_ id id2) - (define-fl-call id - [(e1 e2) (build-fl-call (lookup-c-entry id2) e1 e2)])])) - (define-fl-call flround) ; no support in SSE2 for flround, though this was added in SSE4.1 - (define-fl-call flfloor) - (define-fl-call flceiling) - (define-fl-call fltruncate) - (define-fl-call flsin) - (define-fl-call flcos) - (define-fl-call fltan) - (define-fl-call flasin) - (define-fl-call flacos) - (define-fl2-call flatan flatan2) - (define-fl-call flexp) - (define-fl2-call fllog fllog2)) - - (define-inline 3 flexpt - [(e1 e2) (build-fl-call (lookup-c-entry flexpt) e1 e2)]) - - (let () - (define build-fl-make-rectangular - (lambda (e1 e2) - (bind #f (e1 e2) - (bind #t ([t (%constant-alloc type-typed-object (constant size-inexactnum))]) - (%seq - (set! ,(%mref ,t ,(constant inexactnum-type-disp)) - ,(%constant type-inexactnum)) - (set! ,(%mref ,t ,%zero ,(constant inexactnum-real-disp) fp) - ,(%mref ,e1 ,%zero ,(constant flonum-data-disp) fp)) - (set! ,(%mref ,t ,%zero ,(constant inexactnum-imag-disp) fp) - ,(%mref ,e2 ,%zero ,(constant flonum-data-disp) fp)) - ,t))))) - - (define-inline 3 fl-make-rectangular - [(e1 e2) (build-fl-make-rectangular e1 e2)]) - - (define-inline 3 cfl- - [(e) (bind #t (e) - `(if ,(%type-check mask-flonum type-flonum ,e) - ,(build-flneg e) - ,(build-fl-make-rectangular - (build-flneg (build-$inexactnum-real-part e)) - (build-flneg (build-$inexactnum-imag-part e)))))] - [(e1 e2) (build-libcall #f src sexpr cfl- e1 e2)] - ; TODO: add 3 argument version of cfl- library function - #;[(e1 e2 e3) (build-libcall #f src sexpr cfl- e1 e2 e3)] - [(e1 e2 . e*) #f]) - - (define-inline 3 cfl+ - [() `(quote 0.0)] - [(e) (ensure-single-valued e)] - [(e1 e2) (build-libcall #f src sexpr cfl+ e1 e2)] - ; TODO: add 3 argument version of cfl+ library function - #;[(e1 e2 e3) (build-libcall #f src sexpr cfl+ e1 e2 e3)] - [(e1 e2 . e*) #f]) - - (define-inline 3 cfl* - [() `(quote 1.0)] - [(e) (ensure-single-valued e)] - [(e1 e2) (build-libcall #f src sexpr cfl* e1 e2)] - ; TODO: add 3 argument version of cfl* library function - #;[(e1 e2 e3) (build-libcall #f src sexpr cfl* e1 e2 e3)] - [(e1 e2 . e*) #f]) - - (define-inline 3 cfl/ - [(e) (build-libcall #f src sexpr cfl/ `(quote 1.0) e)] - [(e1 e2) (build-libcall #f src sexpr cfl/ e1 e2)] - ; TODO: add 3 argument version of cfl/ library function - #;[(e1 e2 e3) (build-libcall #f src sexpr cfl/ e1 e2 e3)] - [(e1 e2 . e*) #f]) - - (define-inline 3 cfl-conjugate - [(e) (bind #t (e) - `(if ,(%type-check mask-flonum type-flonum ,e) - ,e - ,(build-fl-make-rectangular - (build-$inexactnum-real-part e) - (build-flneg (build-$inexactnum-imag-part e)))))])) - - (define-inline 3 $make-exactnum - [(e1 e2) (bind #f (e1 e2) - (bind #t ([t (%constant-alloc type-typed-object (constant size-exactnum))]) - (%seq - (set! ,(%mref ,t ,(constant exactnum-type-disp)) - ,(%constant type-exactnum)) - (set! ,(%mref ,t ,(constant exactnum-real-disp)) ,e1) - (set! ,(%mref ,t ,(constant exactnum-imag-disp)) ,e2) - ,t)))]) - - (let () - (define (build-fl< e1 e2) `(inline ,(make-info-unboxed-args '(#t #t)) ,%fp< ,e1 ,e2)) - (define build-fl= - (case-lambda - [(e) (if (constant nan-single-comparison-true?) - (%seq ,e (quote #t)) - (bind #t fp (e) (build-fl= e e)))] - [(e1 e2) (bind #f fp (e1 e2) - `(inline ,(make-info-unboxed-args '(#t #t)) ,%fp= ,e1 ,e2))])) - (define (build-fl<= e1 e2) `(inline ,(make-info-unboxed-args '(#t #t)) ,%fp<= ,e1 ,e2)) - - (let () - (define-syntax define-fl-cmp-inline - (lambda (x) - (syntax-case x () - [(_ op r6rs:op builder inequality? swapped?) - (with-syntax ([(args ...) (if (datum swapped?) #'(e2 e1) #'(e1 e2))] - [reducer (if (datum inequality?) - #'(reduce-fp-compare reduce-inequality) - #'(reduce-fp-compare reduce-equality))]) - #'(begin - (define-inline 3 op - [(e) (build-fl= e)] - [(e1 e2) (builder args ...)] - [(e1 e2 . e*) (reducer src sexpr moi e1 e2 e*)]) - (define-inline 3 r6rs:op - [(e1 e2) (builder args ...)] - [(e1 e2 . e*) (reducer src sexpr moi e1 e2 e*)])))]))) - - (define-fl-cmp-inline fl= fl=? build-fl= #f #f) - (define-fl-cmp-inline fl< fl<? build-fl< #t #f) - (define-fl-cmp-inline fl> fl>? build-fl< #t #t) - (define-fl-cmp-inline fl<= fl<=? build-fl<= #t #f) - (define-fl-cmp-inline fl>= fl>=? build-fl<= #t #t)) - (let () - (define-syntax build-bind-and-check - (syntax-rules () - [(_ src sexpr op e1 e2 body) - (if (known-flonum-result? e1) - (if (known-flonum-result? e2) - body - (bind #t (e2) - `(if ,(%type-check mask-flonum type-flonum ,e2) - ,body - ,(build-libcall #t src sexpr op e2 e2)))) - (if (known-flonum-result? e2) - (bind #t (e1) - `(if ,(%type-check mask-flonum type-flonum ,e1) - ,body - ,(build-libcall #t src sexpr op e1 e1))) - (bind #t (e1 e2) - `(if ,(build-and - (%type-check mask-flonum type-flonum ,e1) - (%type-check mask-flonum type-flonum ,e2)) - ,body - ,(build-libcall #t src sexpr op e1 e2)))))])) - (define build-check-fp-arguments - (lambda (e* build-libcall k) - (let loop ([e* e*] [check-e* '()] [all-e* '()]) - (cond - [(null? e*) - (let loop ([check-e* (reverse check-e*)]) - (cond - [(null? check-e*) (apply k (reverse all-e*))] - [(null? (cdr check-e*)) - (let ([e1 (car check-e*)]) - `(if ,(%type-check mask-flonum type-flonum ,e1) - ,(loop '()) - ,(build-libcall e1 e1)))] - [else - (let ([e1 (car check-e*)] - [e2 (cadr check-e*)]) - `(if ,(build-and - (%type-check mask-flonum type-flonum ,e1) - (%type-check mask-flonum type-flonum ,e2)) - ,(loop (cddr check-e*)) - ,(build-libcall e1 e2)))]))] - [else - (let ([e1 (car e*)]) - (if (known-flonum-result? e1) - (loop (cdr e*) check-e* (cons e1 all-e*)) - (bind #t (e1) - (loop (cdr e*) (cons e1 check-e*) (cons e1 all-e*)))))])))) - (define-syntax define-fl-cmp-inline - (lambda (x) - (syntax-case x () - [(_ op r6rs:op builder inequality? swapped?) - (with-syntax ([(args ...) (if (datum swapped?) #'(e2 e1) #'(e1 e2))] - [reducer (if (datum inequality?) - #'(reduce-fp-compare reduce-inequality) - #'(reduce-fp-compare reduce-equality))]) - #'(begin - (define-inline 2 op - [(e1) (if (known-flonum-result? e1) - (build-fl= e1) - (bind #t (e1) - `(if ,(%type-check mask-flonum type-flonum ,e1) - ,(build-fl= e1) - ,(build-libcall #t src sexpr op e1 e1))))] - [(e1 e2) (build-bind-and-check src sexpr op e1 e2 (builder args ...))] - [(e1 e2 . e*) (and - (fx<= (length e*) (fx- inline-args-limit 2)) - (build-check-fp-arguments (cons* e1 e2 e*) - (lambda (e1 e2) (build-libcall #t src sexpr op e1 e2)) - (lambda (e1 e2 . e*) (reducer src sexpr moi e1 e2 e*))))]) - (define-inline 2 r6rs:op - [(e1 e2) (build-bind-and-check src sexpr r6rs:op e1 e2 (builder args ...))] - [(e1 e2 . e*) (and - (fx<= (length e*) (fx- inline-args-limit 2)) - (build-check-fp-arguments (cons* e1 e2 e*) - (lambda (e1 e2) (build-libcall #t src sexpr r6rs:op e1 e2)) - (lambda (e1 e2 . e*) (reducer src sexpr moi e1 e2 e*))))])))]))) - - (define-fl-cmp-inline fl= fl=? build-fl= #f #f) - (define-fl-cmp-inline fl< fl<? build-fl< #t #f) - (define-fl-cmp-inline fl> fl>? build-fl< #t #t) - (define-fl-cmp-inline fl<= fl<=? build-fl<= #t #f) - (define-fl-cmp-inline fl>= fl>=? build-fl<= #t #t)) - (let () - (define build-cfl= - ; NB: e1 and e2 must be bound - (lambda (e1 e2) - `(if ,(%type-check mask-flonum type-flonum ,e1) - (if ,(%type-check mask-flonum type-flonum ,e2) - ,(build-fl= e1 e2) - ,(build-and - (build-fl= `(quote 0.0) (build-$inexactnum-imag-part e2)) - (build-fl= e1 (build-$inexactnum-real-part e2)))) - (if ,(%type-check mask-flonum type-flonum ,e2) - ,(build-and - (build-fl= `(quote 0.0) (build-$inexactnum-imag-part e1)) - (build-fl= e2 (build-$inexactnum-real-part e1))) - ,(build-and - (build-fl= - (build-$inexactnum-imag-part e1) - (build-$inexactnum-imag-part e2)) - (build-fl= - (build-$inexactnum-real-part e1) - (build-$inexactnum-real-part e2))))))) - (define-inline 3 cfl= - [(e) (if (constant nan-single-comparison-true?) - (%seq ,e (quote #t)) - (bind #f (e) (build-cfl= e e)))] - [(e1 e2) (bind #f (e1 e2) (build-cfl= e1 e2))] - ; TODO: should we avoid building for more then the 3 item case? - [(e1 e2 . e*) (reduce-equality src sexpr moi e1 e2 e*)]))) - - (let () - (define build-checked-fp-op - (case-lambda - [(e k) - (if (known-flonum-result? e) - e - (bind #t (e) - `(if ,(build-flonums? (list e)) - ,e - ,(k e))))] - [(e1 op k) ; `op` can be a procedure that produces an unboxed value - (if (known-flonum-result? e1) - (build-fp-op-1 op e1) - (bind #t (e1) - (let ([e (build-fp-op-1 op e1)] - [k (lambda (e) - `(if ,(build-flonums? (list e1)) - ,e - ,(k e1)))]) - ((lift-fp-unboxed k) e))))] - [(e1 e2 op k) ; `op` can be a procedure that produces an unboxed value - ;; uses result of `e1` or `e2` twice for error if other is always a flonum - (let ([build (lambda (e1 e2) - (build-fp-op-2 op e1 e2))]) - (if (known-flonum-result? e1) - (if (known-flonum-result? e2) - (build e1 e2) - (bind #t (e2) - (build e1 `(if ,(build-flonums? (list e2)) - ,e2 - ,(k e2 e2))))) - (if (known-flonum-result? e2) - (bind #t (e1) - (build `(if ,(build-flonums? (list e1)) - ,e1 - ,(k e1 e1)) - e2)) - (bind #t (e1 e2) - (let ([e (build e1 e2)] - [k (lambda (e) - `(if ,(build-flonums? (list e1 e2)) - ,e - ,(k e1 e2)))]) - ((lift-fp-unboxed k) e))))))])) - - (define-inline 2 fl+ - [() `(quote 0.0)] - [(e) (build-checked-fp-op e - (lambda (e) - (build-libcall #t src sexpr fl+ e `(quote 0.0))))] - [(e1 e2) (build-checked-fp-op e1 e2 %fp+ - (lambda (e1 e2) - (build-libcall #t src sexpr fl+ e1 e2)))] - [(e1 . e*) (reduce-fp src sexpr 2 'fl+ e1 e*)]) - - (define-inline 2 fl* - [() `(quote 1.0)] - [(e) (build-checked-fp-op e - (lambda (e) - (build-libcall #t src sexpr fl* e `(quote 1.0))))] - [(e1 e2) (build-checked-fp-op e1 e2 %fp* - (lambda (e1 e2) - (build-libcall #t src sexpr fl* e1 e2)))] - [(e1 . e*) (reduce-fp src sexpr 2 'fl* e1 e*)]) - - (define-inline 2 fl- - [(e) (build-checked-fp-op e build-flneg - (lambda (e) - (build-libcall #t src sexpr flnegate e)))] - [(e1 e2) (build-checked-fp-op e1 e2 %fp- - (lambda (e1 e2) - (build-libcall #t src sexpr fl- e1 e2)))] - [(e1 . e*) (reduce-fp src sexpr 2 'fl- e1 e*)]) - - (define-inline 2 fl/ - [(e) (build-checked-fp-op `(quote 1.0) e %fp/ - (lambda (e1 e2) - (build-libcall #t src sexpr fl/ e1 e2)))] - [(e1 e2) (build-checked-fp-op e1 e2 %fp/ - (lambda (e1 e2) - (build-libcall #t src sexpr fl/ e1 e2)))] - [(e1 . e*) (reduce-fp src sexpr 2 'fl/ e1 e*)]) - - (define-inline 2 flabs - [(e) (build-checked-fp-op e build-flabs - (lambda (e) - (build-libcall #t src sexpr flabs e)))]) - - (define-inline 2 flsqrt - [(e) - (build-checked-fp-op e - (lambda (e) - (constant-case architecture - [(x86 x86_64 arm32 arm64 pb) (build-fp-op-1 %fpsqrt e)] - [(ppc32) (build-fl-call (lookup-c-entry flsqrt) e)])) - (lambda (e) - (build-libcall #t src sexpr flsqrt e)))]) - - (define-inline 2 flsingle - [(e) - (build-checked-fp-op e - (lambda (e) (build-fp-op-1 %fpsingle e)) - (lambda (e) - (build-libcall #t src sexpr flsingle e)))]) - - (let () - (define-syntax define-fl-call - (syntax-rules () - [(_ id) - (define-inline 2 id - [(e) (build-checked-fp-op e (lambda (e) (build-fl-call (lookup-c-entry id) e)) - (lambda (e) - (build-libcall #t src sexpr id e)))])])) - (define-syntax define-fl2-call - (syntax-rules () - [(_ id id2) - (define-inline 2 id - [(e) (build-checked-fp-op e (lambda (e) (build-fl-call (lookup-c-entry id) e)) - (lambda (e) - (build-libcall #t src sexpr id e)))] - [(e1 e2) (build-checked-fp-op e1 e2 (lambda (e1 e2) (build-fl-call (lookup-c-entry id2) e1 e2)) - (lambda (e1 e2) - (build-libcall #t src sexpr id2 e1 e2)))])])) - (define-fl-call flround) - (define-fl-call flfloor) - (define-fl-call flceiling) - (define-fl-call fltruncate) - (define-fl-call flsin) - (define-fl-call flcos) - (define-fl-call fltan) - (define-fl-call flasin) - (define-fl-call flacos) - (define-fl2-call flatan flatan2) - (define-fl-call flexp) - (define-fl2-call fllog fllog2)) - - (define-inline 2 flexpt - [(e1 e2) (build-checked-fp-op e1 e2 - (lambda (e1 e2) (build-fl-call (lookup-c-entry flexpt) e1 e2)) - (lambda (e1 e2) - (build-libcall #t src sexpr flexpt e1 e2)))]) - - ;; NB: assuming that we have a trunc instruction for now, will need to change to support Sparc - (define-inline 3 flonum->fixnum - [(e-x) (bind #f fp (e-x) - (build-fix - `(inline ,(make-info-unboxed-args '(#t)) ,%fptrunc ,e-x)))]) - (define-inline 2 flonum->fixnum - [(e-x) (build-checked-fp-op e-x - (lambda (e-x) - (define (build-fl< e1 e2) `(inline ,(make-info-unboxed-args '(#t #t)) ,%fp< ,e1 ,e2)) - (bind #t (e-x) - `(if ,(build-and - (build-fl< e-x `(quote ,(constant too-positive-flonum-for-fixnum))) - (build-fl< `(quote ,(constant too-negative-flonum-for-fixnum)) e-x)) - ,(build-fix - `(inline ,(make-info-unboxed-args '(#t)) ,%fptrunc ,e-x)) - ;; We have to box the flonum to report an error: - ,(let ([t (make-tmp 't)]) - `(let ([,t ,(%constant-alloc type-flonum (constant size-flonum))]) - (seq - (set! ,(%mref ,t ,%zero ,(constant flonum-data-disp) fp) ,e-x) - ,(build-libcall #t src sexpr flonum->fixnum t))))))) - (lambda (e-x) - (build-libcall #t src sexpr flonum->fixnum e-x)))]))) - - (let () - (define build-fixnum->flonum - ; NB: x must already be bound in order to ensure it is done before the flonum is allocated - (lambda (e-x k) - (k `(unboxed-fp ,(%inline fpt ,(build-unfix e-x)))))) - (define-inline 3 fixnum->flonum - [(e-x) (bind #f (e-x) (build-fixnum->flonum e-x values))]) - (define-inline 2 fixnum->flonum - [(e-x) (bind #t (e-x) - (build-fixnum->flonum e-x - (lift-fp-unboxed - (lambda (e) - `(if ,(%type-check mask-fixnum type-fixnum ,e-x) - ,e - ,(build-libcall #t src sexpr fixnum->flonum e-x))))))]) - (define-inline 2 real->flonum - [(e-x) - (if (known-flonum-result? e-x) - e-x - (bind #t (e-x) - `(if ,(%type-check mask-fixnum type-fixnum ,e-x) - ,(build-fixnum->flonum e-x values) - (if ,(%type-check mask-flonum type-flonum ,e-x) - ,e-x - ,(build-libcall #t src sexpr real->flonum e-x `(quote real->flonum))))))])) - (define-inline 3 $real->flonum - [(x who) (build-$real->flonum src sexpr x who)]) - (define-inline 2 $record - [(tag . args) (build-$record tag args)]) - (define-inline 3 $object-address - [(e-ptr e-offset) - (unsigned->ptr - (%inline + ,e-ptr ,(build-unfix e-offset)) - (type->width ptr-type))]) - (define-inline 3 $address->object - [(e-addr e-roffset) - (bind #f (e-roffset) - (%inline - - ,(ptr->integer e-addr (type->width ptr-type)) - ,(build-unfix e-roffset)))]) - (define-inline 2 $object-ref - [(type base offset) - (nanopass-case (L7 Expr) type - [(quote ,d) - (let ([type (filter-foreign-type d)]) - (and (memq type (record-datatype list)) - (not (memq type '(char wchar boolean))) - (build-object-ref #f type base offset)))] - [else #f])]) - (define-inline 2 $swap-object-ref - [(type base offset) - (nanopass-case (L7 Expr) type - [(quote ,d) - (let ([type (filter-foreign-type d)]) - (and (memq type (record-datatype list)) - (not (memq type '(char wchar boolean))) - (build-object-ref #t type base offset)))] - [else #f])]) - (define-inline 3 foreign-ref - [(e-type e-addr e-offset) - (nanopass-case (L7 Expr) e-type - [(quote ,d) - (let ([type (filter-foreign-type d)]) - (and (memq type (record-datatype list)) - (not (memq type '(char wchar boolean))) - (bind #f (e-offset) - (build-object-ref #f type - (ptr->integer e-addr (constant ptr-bits)) - e-offset))))] - [else #f])]) - (define-inline 3 $foreign-swap-ref - [(e-type e-addr e-offset) - (nanopass-case (L7 Expr) e-type - [(quote ,d) - (let ([type (filter-foreign-type d)]) - (and (memq type (record-datatype list)) - (not (memq type '(char wchar boolean))) - (bind #f (e-offset) - (build-object-ref #t type - (ptr->integer e-addr (constant ptr-bits)) - e-offset))))] - [else #f])]) - (define-inline 2 $object-set! - [(type base offset value) - (nanopass-case (L7 Expr) type - [(quote ,d) - (let ([type (filter-foreign-type d)]) - (and (memq type (record-datatype list)) - (not (memq type '(char wchar boolean))) - (or (>= (constant ptr-bits) (type->width type)) (eq? type 'double-float)) - (build-object-set! type base offset value)))] - [else #f])]) - (define-inline 3 foreign-set! - [(e-type e-addr e-offset e-value) - (nanopass-case (L7 Expr) e-type - [(quote ,d) - (let ([type (filter-foreign-type d)]) - (and (memq type (record-datatype list)) - (not (memq type '(char wchar boolean))) - (or (>= (constant ptr-bits) (type->width type)) (eq? type 'double-float)) - (bind #f (e-offset e-value) - (build-object-set! type - (ptr->integer e-addr (constant ptr-bits)) - e-offset - e-value))))] - [else #f])]) - (define-inline 3 $foreign-swap-set! - [(e-type e-addr e-offset e-value) - (nanopass-case (L7 Expr) e-type - [(quote ,d) - (let ([type (filter-foreign-type d)]) - (and (memq type (record-datatype list)) - (not (memq type '(char wchar boolean single-float))) - (>= (constant ptr-bits) (type->width type)) - (bind #f (e-offset e-value) - (build-swap-object-set! type - (ptr->integer e-addr (constant ptr-bits)) - e-offset - e-value))))] - [else #f])]) - (define-inline 2 $make-fptr - [(e-ftype e-addr) - (nanopass-case (L7 Expr) e-addr - [(call ,info ,mdcl ,pr ,e1) - (guard - (eq? (primref-name pr) 'ftype-pointer-address) - (all-set? (prim-mask unsafe) (primref-flags pr))) - (bind #f (e-ftype e1) - (bind #t ([t (%constant-alloc type-typed-object (fx* 2 (constant ptr-bytes)))]) - (%seq - (set! ,(%mref ,t ,(constant record-type-disp)) ,e-ftype) - (set! ,(%mref ,t ,(constant record-data-disp)) - ,(%mref ,e1 ,(constant record-data-disp))) - ,t)))] - [else - (bind #f (e-ftype e-addr) - (bind #t ([t (%constant-alloc type-typed-object (fx* 2 (constant ptr-bytes)))]) - (%seq - (set! ,(%mref ,t ,(constant record-type-disp)) ,e-ftype) - (set! ,(%mref ,t ,(constant record-data-disp)) - ,(ptr->integer e-addr (constant ptr-bits))) - ,t)))])]) - (define-inline 3 ftype-pointer-address - [(e-fptr) - (build-object-ref #f - (constant-case ptr-bits - [(64) 'unsigned-64] - [(32) 'unsigned-32]) - e-fptr %zero (constant record-data-disp))]) - (define-inline 3 ftype-pointer-null? - [(e-fptr) (make-ftype-pointer-null? e-fptr)]) - (define-inline 3 ftype-pointer=? - [(e1 e2) (make-ftype-pointer-equal? e1 e2)]) - (let () - (define build-fx+raw - (lambda (fx-arg raw-arg) - (if (constant? (lambda (x) (eqv? x 0)) fx-arg) - raw-arg - (%inline + ,raw-arg ,(build-unfix fx-arg))))) - (define $extract-fptr-address - (lambda (e-fptr) - (define suppress-unsafe-cast - (lambda (e-fptr) - (nanopass-case (L7 Expr) e-fptr - [(call ,info1 ,mdcl1 ,pr1 (quote ,d) (call ,info2 ,mdcl2 ,pr2 ,e)) - (guard - (eq? (primref-name pr1) '$make-fptr) - (all-set? (prim-mask unsafe) (primref-flags pr2)) - (eq? (primref-name pr2) 'ftype-pointer-address) - (all-set? (prim-mask unsafe) (primref-flags pr2))) - e] - [else e-fptr]))) - (nanopass-case (L7 Expr) e-fptr - ; skip allocation and dereference of ftype-pointer for $fptr-fptr-ref - [(call ,info ,mdcl ,pr ,e1 ,e2 ,e3) ; e1, e2, e3 = fptr, offset, ftd - (guard - (eq? (primref-name pr) '$fptr-fptr-ref) - (all-set? (prim-mask unsafe) (primref-flags pr))) - (let-values ([(e-index imm-offset) (offset-expr->index+offset e2)]) - (bind #f (e-index e3) - `(inline ,(make-info-load ptr-type #f) ,%load - ,($extract-fptr-address e1) - ,e-index (immediate ,imm-offset))))] - ; skip allocation and dereference of ftype-pointer for $fptr-&ref - [(call ,info ,mdcl ,pr ,e1 ,e2 ,e3) ; e1, e2, e3 = fptr, offset, ftd - (guard - (eq? (primref-name pr) '$fptr-&ref) - (all-set? (prim-mask unsafe) (primref-flags pr))) - (build-fx+raw e2 ($extract-fptr-address e1))] - ; skip allocation and dereference of ftype-pointer for $make-fptr - [(call ,info ,mdcl ,pr ,e1 ,e2) ; e1, e2 = ftd, (ptr) addr - (guard - (eq? (primref-name pr) '$make-fptr) - (all-set? (prim-mask unsafe) (primref-flags pr))) - (nanopass-case (L7 Expr) e2 - [(call ,info ,mdcl ,pr ,e3) - (guard - (eq? (primref-name pr) 'ftype-pointer-address) - (all-set? (prim-mask unsafe) (primref-flags pr))) - (bind #f (e1) - (%mref ,e3 ,(constant record-data-disp)))] - [else - (bind #f (e1) - (ptr->integer e2 (constant ptr-bits)))])] - [else - `(inline ,(make-info-load ptr-type #f) ,%load ,(suppress-unsafe-cast e-fptr) ,%zero - ,(%constant record-data-disp))]))) - (let () - (define-inline 3 $fptr-offset-addr - [(e-fptr e-offset) - ; bind offset before doing the load (a) to maintain applicative order---the - ; load can cause an invalid memory reference---and (b) so that the raw value - ; isn't live across any calls - (bind #f (e-offset) - (build-fx+raw e-offset - ($extract-fptr-address e-fptr)))]) - (define-inline 3 $fptr-&ref - [(e-fptr e-offset e-ftd) - ; see comment in $fptr-offset-addr - (bind #f (e-offset e-ftd) - (build-$record e-ftd - (list (build-fx+raw e-offset ($extract-fptr-address e-fptr)))))])) - (define-inline 3 $fptr-fptr-ref - [(e-fptr e-offset e-ftd) - (let-values ([(e-index imm-offset) (offset-expr->index+offset e-offset)]) - (bind #f (e-index) - (build-$record e-ftd - (list `(inline ,(make-info-load ptr-type #f) ,%load - ,($extract-fptr-address e-fptr) - ,e-index (immediate ,imm-offset))))))]) - (define-inline 3 $fptr-fptr-set! - [(e-fptr e-offset e-val) - (let-values ([(e-index imm-offset) (offset-expr->index+offset e-offset)]) - (bind #f ([e-addr ($extract-fptr-address e-fptr)] e-index e-val) - `(inline ,(make-info-load ptr-type #f) ,%store ,e-addr ,e-index (immediate ,imm-offset) - (inline ,(make-info-load ptr-type #f) ,%load ,e-val ,%zero - ,(%constant record-data-disp)))))]) - (let () - (define $do-fptr-ref-inline - (lambda (swapped? type e-fptr e-offset) - (bind #f (e-offset) - (build-object-ref swapped? type ($extract-fptr-address e-fptr) e-offset)))) - (define-syntax define-fptr-ref-inline - (lambda (x) - (define build-inline - (lambda (name type ref maybe-k) - #`(define-inline 3 #,name - [(e-fptr e-offset) - #,((lambda (body) (if maybe-k #`(#,maybe-k #,body) body)) - #`($do-fptr-ref-inline #,ref #,type e-fptr e-offset))]))) - (syntax-case x () - [(_ name ?type ref) (build-inline #'name #'?type #'ref #f)] - [(_ name ?type ref ?k) (build-inline #'name #'?type #'ref #'?k)]))) - - (define-fptr-ref-inline $fptr-ref-integer-8 'integer-8 #f) - (define-fptr-ref-inline $fptr-ref-unsigned-8 'unsigned-8 #f) - - (define-fptr-ref-inline $fptr-ref-integer-16 'integer-16 #f) - (define-fptr-ref-inline $fptr-ref-unsigned-16 'unsigned-16 #f) - (define-fptr-ref-inline $fptr-ref-swap-integer-16 'integer-16 #t) - (define-fptr-ref-inline $fptr-ref-swap-unsigned-16 'unsigned-16 #t) - - (when-known-endianness - (define-fptr-ref-inline $fptr-ref-integer-24 'integer-24 #f) - (define-fptr-ref-inline $fptr-ref-unsigned-24 'unsigned-24 #f) - (define-fptr-ref-inline $fptr-ref-swap-integer-24 'integer-24 #t) - (define-fptr-ref-inline $fptr-ref-swap-unsigned-24 'unsigned-24 #t)) - - (define-fptr-ref-inline $fptr-ref-integer-32 'integer-32 #f) - (define-fptr-ref-inline $fptr-ref-unsigned-32 'unsigned-32 #f) - (define-fptr-ref-inline $fptr-ref-swap-integer-32 'integer-32 #t) - (define-fptr-ref-inline $fptr-ref-swap-unsigned-32 'unsigned-32 #t) - - (when-known-endianness - (define-fptr-ref-inline $fptr-ref-integer-40 'integer-40 #f) - (define-fptr-ref-inline $fptr-ref-unsigned-40 'unsigned-40 #f) - (define-fptr-ref-inline $fptr-ref-swap-integer-40 'integer-40 #t) - (define-fptr-ref-inline $fptr-ref-swap-unsigned-40 'unsigned-40 #t) - - (define-fptr-ref-inline $fptr-ref-integer-48 'integer-48 #f) - (define-fptr-ref-inline $fptr-ref-unsigned-48 'unsigned-48 #f) - (define-fptr-ref-inline $fptr-ref-swap-integer-48 'integer-48 #t) - (define-fptr-ref-inline $fptr-ref-swap-unsigned-48 'unsigned-48 #t) - - (define-fptr-ref-inline $fptr-ref-integer-56 'integer-56 #f) - (define-fptr-ref-inline $fptr-ref-unsigned-56 'unsigned-56 #f) - (define-fptr-ref-inline $fptr-ref-swap-integer-56 'integer-56 #t) - (define-fptr-ref-inline $fptr-ref-swap-unsigned-56 'unsigned-56 #t)) - - (define-fptr-ref-inline $fptr-ref-integer-64 'integer-64 #f) - (define-fptr-ref-inline $fptr-ref-unsigned-64 'unsigned-64 #f) - (define-fptr-ref-inline $fptr-ref-swap-integer-64 'integer-64 #t) - (define-fptr-ref-inline $fptr-ref-swap-unsigned-64 'unsigned-64 #t) - - (define-fptr-ref-inline $fptr-ref-double-float 'double-float #f) - (define-fptr-ref-inline $fptr-ref-swap-double-float 'double-float #t) - - (define-fptr-ref-inline $fptr-ref-single-float 'single-float #f) - (define-fptr-ref-inline $fptr-ref-swap-single-float 'single-float #t) - - (define-fptr-ref-inline $fptr-ref-char 'unsigned-8 #f - (lambda (x) (build-integer->char x))) - - (define-fptr-ref-inline $fptr-ref-wchar - (constant-case wchar-bits [(16) 'unsigned-16] [(32) 'unsigned-32]) - #f - (lambda (x) (build-integer->char x))) - (define-fptr-ref-inline $fptr-ref-swap-wchar - (constant-case wchar-bits [(16) 'unsigned-16] [(32) 'unsigned-32]) - #t - (lambda (x) (build-integer->char x))) - - (define-fptr-ref-inline $fptr-ref-boolean - (constant-case int-bits [(32) 'unsigned-32] [(64) 'unsigned-64]) - #f - (lambda (x) - `(if ,(%inline eq? ,x (immediate 0)) - ,(%constant sfalse) - ,(%constant strue)))) - (define-fptr-ref-inline $fptr-ref-swap-boolean - (constant-case int-bits [(32) 'unsigned-32] [(64) 'unsigned-64]) - #t - (lambda (x) - `(if ,(%inline eq? ,x (immediate 0)) - ,(%constant sfalse) - ,(%constant strue)))) - - (define-fptr-ref-inline $fptr-ref-fixnum 'fixnum #f) - (define-fptr-ref-inline $fptr-ref-swap-fixnum 'fixnum #t)) - (let () - (define $do-fptr-set!-inline - (lambda (set type e-fptr e-offset e-val) - (bind #f (e-offset) - (set type ($extract-fptr-address e-fptr) e-offset e-val)))) - (define-syntax define-fptr-set!-inline - (lambda (x) - (define build-body - (lambda (type set maybe-massage-val) - #``(seq ,e-info - #,(let ([body #`($do-fptr-set!-inline #,set #,type e-fptr e-offset e-val)]) - (if maybe-massage-val - #`,(bind #f (e-offset [e-val (#,maybe-massage-val e-val)]) #,body) - #`,(bind #f (e-offset e-val) #,body)))))) - (define build-inline - (lambda (name check-64? body) - #`(define-inline 3 #,name - [(e-info e-fptr e-offset e-val) - #,(if check-64? - #`(and (fx>= (constant ptr-bits) 64) #,body) - body)]))) - (syntax-case x () - [(_ check-64? name ?type set) - (build-inline #'name (datum check-64?) (build-body #'?type #'set #f))] - [(_ check-64? name ?type set ?massage-value) - (build-inline #'name (datum check-64?) (build-body #'?type #'set #'?massage-value))]))) - - (define-fptr-set!-inline #f $fptr-set-integer-8! 'integer-8 build-object-set!) - (define-fptr-set!-inline #f $fptr-set-unsigned-8! 'unsigned-8 build-object-set!) - - (define-fptr-set!-inline #f $fptr-set-integer-16! 'integer-16 build-object-set!) - (define-fptr-set!-inline #f $fptr-set-unsigned-16! 'unsigned-16 build-object-set!) - (define-fptr-set!-inline #f $fptr-set-swap-integer-16! 'integer-16 build-swap-object-set!) - (define-fptr-set!-inline #f $fptr-set-swap-unsigned-16! 'unsigned-16 build-swap-object-set!) - - (when-known-endianness - (define-fptr-set!-inline #f $fptr-set-integer-24! 'integer-24 build-object-set!) - (define-fptr-set!-inline #f $fptr-set-unsigned-24! 'unsigned-24 build-object-set!) - (define-fptr-set!-inline #f $fptr-set-swap-integer-24! 'integer-24 build-swap-object-set!) - (define-fptr-set!-inline #f $fptr-set-swap-unsigned-24! 'unsigned-24 build-swap-object-set!)) - - (define-fptr-set!-inline #f $fptr-set-integer-32! 'integer-32 build-object-set!) - (define-fptr-set!-inline #f $fptr-set-unsigned-32! 'unsigned-32 build-object-set!) - (define-fptr-set!-inline #f $fptr-set-swap-integer-32! 'integer-32 build-swap-object-set!) - (define-fptr-set!-inline #f $fptr-set-swap-unsigned-32! 'unsigned-32 build-swap-object-set!) - - (when-known-endianness - (define-fptr-set!-inline #t $fptr-set-integer-40! 'integer-40 build-object-set!) - (define-fptr-set!-inline #t $fptr-set-unsigned-40! 'unsigned-40 build-object-set!) - (define-fptr-set!-inline #t $fptr-set-swap-integer-40! 'integer-40 build-swap-object-set!) - (define-fptr-set!-inline #t $fptr-set-swap-unsigned-40! 'unsigned-40 build-swap-object-set!) - - (define-fptr-set!-inline #t $fptr-set-integer-48! 'integer-48 build-object-set!) - (define-fptr-set!-inline #t $fptr-set-unsigned-48! 'unsigned-48 build-object-set!) - (define-fptr-set!-inline #t $fptr-set-swap-integer-48! 'integer-48 build-swap-object-set!) - (define-fptr-set!-inline #t $fptr-set-swap-unsigned-48! 'unsigned-48 build-swap-object-set!) - - (define-fptr-set!-inline #t $fptr-set-integer-56! 'integer-56 build-object-set!) - (define-fptr-set!-inline #t $fptr-set-unsigned-56! 'unsigned-56 build-object-set!) - (define-fptr-set!-inline #t $fptr-set-swap-integer-56! 'integer-56 build-swap-object-set!) - (define-fptr-set!-inline #t $fptr-set-swap-unsigned-56! 'unsigned-56 build-swap-object-set!)) - - (define-fptr-set!-inline #t $fptr-set-integer-64! 'integer-64 build-object-set!) - (define-fptr-set!-inline #t $fptr-set-unsigned-64! 'unsigned-64 build-object-set!) - (define-fptr-set!-inline #t $fptr-set-swap-integer-64! 'integer-64 build-swap-object-set!) - (define-fptr-set!-inline #t $fptr-set-swap-unsigned-64! 'unsigned-64 build-swap-object-set!) - - (define-fptr-set!-inline #f $fptr-set-double-float! 'double-float build-object-set!) - (define-fptr-set!-inline #t $fptr-set-swap-double-float! 'double-float build-swap-object-set!) - - (define-fptr-set!-inline #f $fptr-set-single-float! 'single-float build-object-set!) - - (define-fptr-set!-inline #f $fptr-set-char! 'unsigned-8 build-object-set! - (lambda (z) (build-char->integer z))) - - (define-fptr-set!-inline #f $fptr-set-wchar! - (constant-case wchar-bits - [(16) 'unsigned-16] - [(32) 'unsigned-32]) - build-object-set! - (lambda (z) (build-char->integer z))) - (define-fptr-set!-inline #f $fptr-set-swap-wchar! - (constant-case wchar-bits - [(16) 'unsigned-16] - [(32) 'unsigned-32]) - build-swap-object-set! - (lambda (z) (build-char->integer z))) - - (define-fptr-set!-inline #f $fptr-set-boolean! - (constant-case int-bits - [(32) 'unsigned-32] - [(64) 'unsigned-64]) - build-object-set! - (lambda (z) `(if ,z (immediate ,(fix 1)) (immediate ,(fix 0))))) - (define-fptr-set!-inline #f $fptr-set-swap-boolean! - (constant-case int-bits - [(32) 'unsigned-32] - [(64) 'unsigned-64]) - build-swap-object-set! - (lambda (z) `(if ,z (immediate ,(fix 1)) (immediate ,(fix 0))))) - - (define-fptr-set!-inline #f $fptr-set-fixnum! 'fixnum build-object-set!) - (define-fptr-set!-inline #f $fptr-set-swap-fixnum! 'fixnum build-swap-object-set!)) - (let () - (define-syntax define-fptr-bits-ref-inline - (lambda (x) - (syntax-case x () - [(_ name signed? type swapped?) - #'(define-inline 3 name - [(e-fptr e-offset e-start e-end) - (and (fixnum-constant? e-start) (fixnum-constant? e-end) - (let ([imm-start (constant-value e-start)] [imm-end (constant-value e-end)]) - (and (<= (type->width 'type) (constant ptr-bits)) - (and (fx>= imm-start 0) (fx> imm-end imm-start) (fx<= imm-end (constant ptr-bits))) - ((if signed? fx<= fx<) (fx- imm-end imm-start) (constant fixnum-bits)) - (let-values ([(e-index imm-offset) (offset-expr->index+offset e-offset)]) - (bind #f (e-index) - (build-int-load swapped? 'type ($extract-fptr-address e-fptr) e-index imm-offset - (lambda (x) - ((if signed? extract-signed-bitfield extract-unsigned-bitfield) #t imm-start imm-end x))))))))])]))) - - (define-fptr-bits-ref-inline $fptr-ref-ibits-unsigned-8 #t unsigned-8 #f) - (define-fptr-bits-ref-inline $fptr-ref-ubits-unsigned-8 #f unsigned-8 #f) - - (define-fptr-bits-ref-inline $fptr-ref-ibits-unsigned-16 #t unsigned-16 #f) - (define-fptr-bits-ref-inline $fptr-ref-ubits-unsigned-16 #f unsigned-16 #f) - (define-fptr-bits-ref-inline $fptr-ref-ibits-swap-unsigned-16 #t unsigned-16 #t) - (define-fptr-bits-ref-inline $fptr-ref-ubits-swap-unsigned-16 #f unsigned-16 #t) - - (when-known-endianness - (define-fptr-bits-ref-inline $fptr-ref-ibits-unsigned-24 #t unsigned-24 #f) - (define-fptr-bits-ref-inline $fptr-ref-ubits-unsigned-24 #f unsigned-24 #f) - (define-fptr-bits-ref-inline $fptr-ref-ibits-swap-unsigned-24 #t unsigned-24 #t) - (define-fptr-bits-ref-inline $fptr-ref-ubits-swap-unsigned-24 #f unsigned-24 #t)) - - (define-fptr-bits-ref-inline $fptr-ref-ibits-unsigned-32 #t unsigned-32 #f) - (define-fptr-bits-ref-inline $fptr-ref-ubits-unsigned-32 #f unsigned-32 #f) - (define-fptr-bits-ref-inline $fptr-ref-ibits-swap-unsigned-32 #t unsigned-32 #t) - (define-fptr-bits-ref-inline $fptr-ref-ubits-swap-unsigned-32 #f unsigned-32 #t) - - (when-known-endianness - (define-fptr-bits-ref-inline $fptr-ref-ibits-unsigned-40 #t unsigned-40 #f) - (define-fptr-bits-ref-inline $fptr-ref-ubits-unsigned-40 #f unsigned-40 #f) - (define-fptr-bits-ref-inline $fptr-ref-ibits-swap-unsigned-40 #t unsigned-40 #t) - (define-fptr-bits-ref-inline $fptr-ref-ubits-swap-unsigned-40 #f unsigned-40 #t) - - (define-fptr-bits-ref-inline $fptr-ref-ibits-unsigned-48 #t unsigned-48 #f) - (define-fptr-bits-ref-inline $fptr-ref-ubits-unsigned-48 #f unsigned-48 #f) - (define-fptr-bits-ref-inline $fptr-ref-ibits-swap-unsigned-48 #t unsigned-48 #t) - (define-fptr-bits-ref-inline $fptr-ref-ubits-swap-unsigned-48 #f unsigned-48 #t) - - (define-fptr-bits-ref-inline $fptr-ref-ibits-unsigned-56 #t unsigned-56 #f) - (define-fptr-bits-ref-inline $fptr-ref-ubits-unsigned-56 #f unsigned-56 #f) - (define-fptr-bits-ref-inline $fptr-ref-ibits-swap-unsigned-56 #t unsigned-56 #t) - (define-fptr-bits-ref-inline $fptr-ref-ubits-swap-unsigned-56 #f unsigned-56 #t)) - - (define-fptr-bits-ref-inline $fptr-ref-ibits-unsigned-64 #t unsigned-64 #f) - (define-fptr-bits-ref-inline $fptr-ref-ubits-unsigned-64 #f unsigned-64 #f) - (define-fptr-bits-ref-inline $fptr-ref-ibits-swap-unsigned-64 #t unsigned-64 #t) - (define-fptr-bits-ref-inline $fptr-ref-ubits-swap-unsigned-64 #f unsigned-64 #t)) - (let () - (define-syntax define-fptr-bits-set-inline - (lambda (x) - (syntax-case x () - [(_ check-64? name type swapped?) - (with-syntax ([(checks ...) #'((fixnum-constant? e-start) (fixnum-constant? e-end))]) - (with-syntax ([(checks ...) (if (datum check-64?) - #'((fx>= (constant ptr-bits) 64) checks ...) - #'(checks ...))]) - #`(define-inline 3 name - [(e-fptr e-offset e-start e-end e-val) - (and - checks ... - (let ([imm-start (constant-value e-start)] [imm-end (constant-value e-end)]) - (and (<= (type->width 'type) (constant ptr-bits)) - (and (fx>= imm-start 0) (fx> imm-end imm-start) (fx<= imm-end (constant ptr-bits))) - (fx< (fx- imm-end imm-start) (constant fixnum-bits)) - (let-values ([(e-index imm-offset) (offset-expr->index+offset e-offset)]) - (bind #t (e-index) - (bind #f (e-val) - (bind #t ([e-addr ($extract-fptr-address e-fptr)]) - (build-int-load swapped? 'type e-addr e-index imm-offset - (lambda (x) - (build-int-store swapped? 'type e-addr e-index imm-offset - (insert-bitfield #t imm-start imm-end (type->width 'type) x - e-val)))))))))))])))]))) - - (define-fptr-bits-set-inline #f $fptr-set-bits-unsigned-8! unsigned-8 #f) - - (define-fptr-bits-set-inline #f $fptr-set-bits-unsigned-16! unsigned-16 #f) - (define-fptr-bits-set-inline #f $fptr-set-bits-swap-unsigned-16! unsigned-16 #t) - - (when-known-endianness - (define-fptr-bits-set-inline #f $fptr-set-bits-unsigned-24! unsigned-24 #f) - (define-fptr-bits-set-inline #f $fptr-set-bits-swap-unsigned-24! unsigned-24 #t)) - - (define-fptr-bits-set-inline #f $fptr-set-bits-unsigned-32! unsigned-32 #f) - (define-fptr-bits-set-inline #f $fptr-set-bits-swap-unsigned-32! unsigned-32 #t) - - (when-known-endianness - (define-fptr-bits-set-inline #f $fptr-set-bits-unsigned-40! unsigned-40 #f) - (define-fptr-bits-set-inline #f $fptr-set-bits-swap-unsigned-40! unsigned-40 #t) - - (define-fptr-bits-set-inline #f $fptr-set-bits-unsigned-48! unsigned-48 #f) - (define-fptr-bits-set-inline #f $fptr-set-bits-swap-unsigned-48! unsigned-48 #t) - - (define-fptr-bits-set-inline #f $fptr-set-bits-unsigned-56! unsigned-56 #f) - (define-fptr-bits-set-inline #f $fptr-set-bits-swap-unsigned-56! unsigned-56 #t)) - - (define-fptr-bits-set-inline #t $fptr-set-bits-unsigned-64! unsigned-64 #f) - (define-fptr-bits-set-inline #t $fptr-set-bits-swap-unsigned-64! unsigned-64 #t)) - (define-inline 3 $fptr-locked-decr! - [(e-fptr e-offset) - `(seq - ,(let-values ([(e-index imm-offset) (offset-expr->index+offset e-offset)]) - (%inline locked-decr! - ,($extract-fptr-address e-fptr) - ,e-index (immediate ,imm-offset))) - (inline ,(make-info-condition-code 'eq? #f #t) ,%condition-code))]) - (define-inline 3 $fptr-locked-incr! - [(e-fptr e-offset) - `(seq - ,(let-values ([(e-index imm-offset) (offset-expr->index+offset e-offset)]) - (%inline locked-incr! - ,($extract-fptr-address e-fptr) - ,e-index (immediate ,imm-offset))) - (inline ,(make-info-condition-code 'eq? #f #t) ,%condition-code))]) - (let () - (define clear-lock - (lambda (e-fptr e-offset) - (let ([lock-type (constant-case ptr-bits [(32) 'integer-32] [(64) 'integer-64])]) - (let-values ([(e-index imm-offset) (offset-expr->index+offset e-offset)]) - `(inline ,(make-info-load lock-type #f) ,%store - ,($extract-fptr-address e-fptr) - ,e-index (immediate ,imm-offset) (immediate 0)))))) - (define-inline 3 $fptr-init-lock! - [(e-fptr e-offset) (clear-lock e-fptr e-offset)]) - (define-inline 3 $fptr-unlock! - [(e-fptr e-offset) (clear-lock e-fptr e-offset)])) - (define-inline 3 $fptr-lock! - [(e-fptr e-offset) - (let-values ([(e-index imm-offset) (offset-expr->index+offset e-offset)]) - (bind #t ([e-base ($extract-fptr-address e-fptr)]) - (%inline lock! ,e-base ,e-index (immediate ,imm-offset))))]) - (define-inline 3 $fptr-spin-lock! - [(e-fptr e-offset) - (let-values ([(e-index imm-offset) (offset-expr->index+offset e-offset)]) - (bind #t ([e-base ($extract-fptr-address e-fptr)]) - (bind #t (e-index) - (let ([L1 (make-local-label 'L1)] [L2 (make-local-label 'L2)]) - `(label ,L1 - (if ,(%inline lock! ,e-base ,e-index (immediate ,imm-offset)) - ,(%constant svoid) - (seq - (pariah) - (label ,L2 - (seq - ,(%inline pause) - (if ,(%inline eq? (mref ,e-base ,e-index ,imm-offset uptr) (immediate 0)) - (goto ,L1) - (goto ,L2)))))))))))])) - (let () - (define build-port-flags-set? - (lambda (e-p e-flags) - (%inline logtest - ,(%mref ,e-p ,(constant port-type-disp)) - ,(nanopass-case (L7 Expr) e-flags - [(quote ,d) `(immediate ,(ash d (constant port-flags-offset)))] - [else (%inline sll ,e-flags - (immediate ,(fx- (constant port-flags-offset) (constant fixnum-offset))))])))) - (define build-port-input-empty? - (lambda (e-p) - (%inline eq? - ,(%mref ,e-p ,(constant port-icount-disp)) - (immediate 0)))) - (define-inline 3 binary-port? - [(e-p) (build-port-flags-set? e-p `(quote ,(constant port-flag-binary)))]) - (define-inline 3 textual-port? - [(e-p) (build-not (build-port-flags-set? e-p `(quote ,(constant port-flag-binary))))]) - (define-inline 3 port-closed? - [(e-p) (build-port-flags-set? e-p `(quote ,(constant port-flag-closed)))]) - (define-inline 3 $port-flags-set? - [(e-p e-flags) (build-port-flags-set? e-p e-flags)]) - (define-inline 3 port-eof? - [(e-p) - (bind #t (e-p) - `(if ,(build-port-input-empty? e-p) - (if ,(build-port-flags-set? e-p `(quote ,(constant port-flag-eof))) - (immediate ,(constant strue)) - ,(build-libcall #t src sexpr unsafe-port-eof? e-p)) - (immediate ,(constant sfalse))))]) - (define-inline 2 port-eof? - [(e-p) - (let ([Llib (make-local-label 'Llib)]) - (bind #t (e-p) - `(if ,(%type-check mask-typed-object type-typed-object ,e-p) - ,(bind #t ([t0 (%mref ,e-p ,(constant typed-object-type-disp))]) - `(if ,(%type-check mask-input-port type-input-port ,t0) - (if ,(build-port-input-empty? e-p) - (if ,(%inline logtest ,t0 - (immediate ,(ash (constant port-flag-eof) (constant port-flags-offset)))) - (immediate ,(constant strue)) - (label ,Llib ,(build-libcall #t src sexpr safe-port-eof? e-p))) - (immediate ,(constant sfalse))) - (goto ,Llib))) - (goto ,Llib))))]) - (define-inline 3 port-input-empty? - [(e-p) (build-port-input-empty? e-p)]) - (define-inline 3 port-output-full? - [(e-p) - (%inline eq? - ,(%mref ,e-p ,(constant port-ocount-disp)) - (immediate 0))])) - (let () - (define build-set-port-flags! - (lambda (e-p e-flags) - (bind #t (e-p) - `(set! ,(%mref ,e-p ,(constant port-type-disp)) - ,(%inline logor - ,(%mref ,e-p ,(constant port-type-disp)) - ,(nanopass-case (L7 Expr) e-flags - [(quote ,d) `(immediate ,(ash d (constant port-flags-offset)))] - [else - (translate e-flags - (constant fixnum-offset) - (constant port-flags-offset))])))))) - (define build-reset-port-flags! - (lambda (e-p e-flags) - (bind #t (e-p) - `(set! ,(%mref ,e-p ,(constant port-type-disp)) - ,(%inline logand - ,(%mref ,e-p ,(constant port-type-disp)) - ,(nanopass-case (L7 Expr) e-flags - [(quote ,d) `(immediate ,(lognot (ash d (constant port-flags-offset))))] - [else - (%inline lognot - ,(translate e-flags - (constant fixnum-offset) - (constant port-flags-offset)))])))))) - (define-inline 3 $set-port-flags! - [(e-p e-flags) (build-set-port-flags! e-p e-flags)]) - (define-inline 3 $reset-port-flags! - [(e-p e-flags) (build-reset-port-flags! e-p e-flags)]) - (define-inline 3 mark-port-closed! - [(e-p) (build-set-port-flags! e-p `(quote ,(constant port-flag-closed)))]) - (let () - (define (go e-p e-bool flag) - (let ([e-flags `(quote ,flag)]) - (nanopass-case (L7 Expr) e-bool - [(quote ,d) - ((if d build-set-port-flags! build-reset-port-flags!) e-p e-flags)] - [else - (bind #t (e-p) - `(if ,e-bool - ,(build-set-port-flags! e-p e-flags) - ,(build-reset-port-flags! e-p e-flags)))]))) - (define-inline 3 set-port-bol! - [(e-p e-bool) (go e-p e-bool (constant port-flag-bol))]) - (define-inline 3 set-port-eof! - [(e-p e-bool) (go e-p e-bool (constant port-flag-eof))]))) - (let () - (define (build-port-input-size port-type e-p) - (bind #t (e-p) - (translate - (%inline - - ,(%inline - - ,(%mref ,e-p ,(constant port-ilast-disp)) - ,(%mref ,e-p ,(constant port-ibuffer-disp))) - (immediate - ,(if (eq? port-type 'textual) - (constant string-data-disp) - (constant bytevector-data-disp)))) - (if (eq? port-type 'textual) (constant string-char-offset) 0) - (constant fixnum-offset)))) - (define-inline 3 textual-port-input-size - [(e-p) (build-port-input-size 'textual e-p)]) - (define-inline 3 binary-port-input-size - [(e-p) (build-port-input-size 'binary e-p)])) - (let () - (define (build-port-output-size port-type e-p) - (bind #t (e-p) - (translate - (%inline - - ,(%inline - - ,(%mref ,e-p ,(constant port-olast-disp)) - ,(%mref ,e-p ,(constant port-obuffer-disp))) - (immediate - ,(if (eq? port-type 'textual) - (constant string-data-disp) - (constant bytevector-data-disp)))) - (if (eq? port-type 'textual) (constant string-char-offset) 0) - (constant fixnum-offset)))) - (define-inline 3 textual-port-output-size - [(e-p) (build-port-output-size 'textual e-p)]) - (define-inline 3 binary-port-output-size - [(e-p) (build-port-output-size 'binary e-p)])) - (let () - (define (build-port-input-index port-type e-p) - (bind #t (e-p) - (translate - ; TODO: use lea2? - (%inline + - ,(%inline - - ,(%inline - - ,(%mref ,e-p ,(constant port-ilast-disp)) - ,(%mref ,e-p ,(constant port-ibuffer-disp))) - (immediate - ,(if (eq? port-type 'textual) - (constant string-data-disp) - (constant bytevector-data-disp)))) - ,(%mref ,e-p ,(constant port-icount-disp))) - (if (eq? port-type 'textual) (constant string-char-offset) 0) - (constant fixnum-offset)))) - (define-inline 3 textual-port-input-index - [(e-p) (build-port-input-index 'textual e-p)]) - (define-inline 3 binary-port-input-index - [(e-p) (build-port-input-index 'binary e-p)])) - (let () - (define (build-port-output-index port-type e-p) - (bind #t (e-p) - (translate - (%inline + - ,(%inline - - ,(%inline - - ,(%mref ,e-p ,(constant port-olast-disp)) - ,(%mref ,e-p ,(constant port-obuffer-disp))) - (immediate - ,(if (eq? port-type 'textual) - (constant string-data-disp) - (constant bytevector-data-disp)))) - ,(%mref ,e-p ,(constant port-ocount-disp))) - (if (eq? port-type 'textual) (constant string-char-offset) 0) - (constant fixnum-offset)))) - (define-inline 3 textual-port-output-index - [(e-p) (build-port-output-index 'textual e-p)]) - (define-inline 3 binary-port-output-index - [(e-p) (build-port-output-index 'binary e-p)])) - (let () - (define (build-port-input-count port-type e-p) - (bind #t (e-p) - (translate - (%inline - - (immediate 0) - ,(%mref ,e-p ,(constant port-icount-disp))) - (if (eq? port-type 'textual) (constant string-char-offset) 0) - (constant fixnum-offset)))) - (define-inline 3 textual-port-input-count - [(e-p) (build-port-input-count 'textual e-p)]) - (define-inline 3 binary-port-input-count - [(e-p) (build-port-input-count 'binary e-p)])) - (let () - (define (build-port-output-count port-type e-p) - (bind #t (e-p) - (translate - (%inline - - (immediate 0) - ,(%mref ,e-p ,(constant port-ocount-disp))) - (if (eq? port-type 'textual) (constant string-char-offset) 0) - (constant fixnum-offset)))) - (define-inline 3 textual-port-output-count - [(e-p) (build-port-output-count 'textual e-p)]) - (define-inline 3 binary-port-output-count - [(e-p) (build-port-output-count 'binary e-p)])) - (let () - (define (build-set-port-input-size! port-type e-p e-x) - ; actually, set last to buffer[0] + size; count to size - (bind #t (e-p) - (bind #t ([e-x (translate e-x - (constant fixnum-offset) - (if (eq? port-type 'textual) (constant string-char-offset) 0))]) - `(seq - (set! ,(%mref ,e-p ,(constant port-icount-disp)) - ,(%inline - (immediate 0) ,e-x)) - (set! ,(%mref ,e-p ,(constant port-ilast-disp)) - ,(%inline + - ,(%inline + - ,(%mref ,e-p ,(constant port-ibuffer-disp)) - (immediate - ,(if (eq? port-type 'textual) - (constant string-data-disp) - (constant bytevector-data-disp)))) - ,e-x)))))) - (define-inline 3 set-textual-port-input-size! - [(e-p e-x) (build-set-port-input-size! 'textual e-p e-x)]) - (define-inline 3 set-binary-port-input-size! - [(e-p e-x) (build-set-port-input-size! 'binary e-p e-x)])) - (let () - (define (build-set-port-output-size! port-type e-p e-x) - ; actually, set last to buffer[0] + size; count to size - (bind #t (e-p) - (bind #t ([e-x (translate e-x - (constant fixnum-offset) - (if (eq? port-type 'textual) (constant string-char-offset) 0))]) - `(seq - (set! ,(%mref ,e-p ,(constant port-ocount-disp)) - ,(%inline - (immediate 0) ,e-x)) - (set! ,(%mref ,e-p ,(constant port-olast-disp)) - ,(%inline + - ,(%inline + - ,(%mref ,e-p ,(constant port-obuffer-disp)) - (immediate - ,(if (eq? port-type 'textual) - (constant string-data-disp) - (constant bytevector-data-disp)))) - ,e-x)))))) - (define-inline 3 set-textual-port-output-size! - [(e-p e-x) (build-set-port-output-size! 'textual e-p e-x)]) - (define-inline 3 set-binary-port-output-size! - [(e-p e-x) (build-set-port-output-size! 'binary e-p e-x)])) - (let () - (define (build-set-port-input-index! port-type e-p e-x) - ; actually, set count to index - size, where size = last - buffer[0] - (bind #t (e-p) - `(set! ,(%mref ,e-p ,(constant port-icount-disp)) - ,(%inline - - ,(translate e-x - (constant fixnum-offset) - (if (eq? port-type 'textual) (constant string-char-offset) 0)) - ,(%inline - - ,(%mref ,e-p ,(constant port-ilast-disp)) - ,(%inline + - ,(%mref ,e-p ,(constant port-ibuffer-disp)) - (immediate - ,(if (eq? port-type 'textual) - (constant string-data-disp) - (constant bytevector-data-disp))))))))) - (define-inline 3 set-textual-port-input-index! - [(e-p e-x) (build-set-port-input-index! 'textual e-p e-x)]) - (define-inline 3 set-binary-port-input-index! - [(e-p e-x) (build-set-port-input-index! 'binary e-p e-x)])) - (let () - (define (build-set-port-output-index! port-type e-p e-x) - ; actually, set count to index - size, where size = last - buffer[0] - (bind #t (e-p) - `(set! ,(%mref ,e-p ,(constant port-ocount-disp)) - ,(%inline - - ,(translate e-x - (constant fixnum-offset) - (if (eq? port-type 'textual) (constant string-char-offset) 0)) - ,(%inline - - ,(%mref ,e-p ,(constant port-olast-disp)) - ,(%inline + - ,(%mref ,e-p ,(constant port-obuffer-disp)) - (immediate - ,(if (eq? port-type 'textual) - (constant string-data-disp) - (constant bytevector-data-disp))))))))) - (define-inline 3 set-textual-port-output-index! - [(e-p e-x) (build-set-port-output-index! 'textual e-p e-x)]) - (define-inline 3 set-binary-port-output-index! - [(e-p e-x) (build-set-port-output-index! 'binary e-p e-x)])) - (let () - (define (make-build-set-port-buffer! port-type ibuffer-disp icount-disp ilast-disp) - (lambda (e-p e-b new?) - (bind #t (e-p e-b) - `(seq - ,(if new? - `(set! ,(%mref ,e-p ,ibuffer-disp) ,e-b) - (build-dirty-store e-p ibuffer-disp e-b)) - ,(bind #t ([e-length (if (eq? port-type 'textual) - (translate - (%inline logand - ,(%mref ,e-b ,(constant string-type-disp)) - (immediate ,(fx- (expt 2 (constant string-length-offset))))) - (constant string-length-offset) - (constant string-char-offset)) - (%inline srl - ,(%mref ,e-b ,(constant bytevector-type-disp)) - ,(%constant bytevector-length-offset)))]) - `(seq - (set! ,(%mref ,e-p ,icount-disp) - ,(%inline - (immediate 0) ,e-length)) - (set! ,(%mref ,e-p ,ilast-disp) - ,(%lea ,e-b ,e-length - (if (eq? port-type 'textual) - (constant string-data-disp) - (constant bytevector-data-disp)))))))))) - (define (make-port e-name e-handler e-ib e-ob e-info flags set-ibuf! set-obuf!) - (bind #f (e-name e-handler e-info e-ib e-ob) - (bind #t ([e-p (%constant-alloc type-typed-object (constant size-port))]) - (%seq - (set! ,(%mref ,e-p ,(constant port-type-disp)) (immediate ,flags)) - (set! ,(%mref ,e-p ,(constant port-handler-disp)) ,e-handler) - (set! ,(%mref ,e-p ,(constant port-name-disp)) ,e-name) - (set! ,(%mref ,e-p ,(constant port-info-disp)) ,e-info) - ,(set-ibuf! e-p e-ib #t) - ,(set-obuf! e-p e-ob #t) - ,e-p)))) - (define (make-build-clear-count count-disp) - (lambda (e-p e-b new?) - `(set! ,(%mref ,e-p ,count-disp) (immediate 0)))) - (let () - (define build-set-textual-port-input-buffer! - (make-build-set-port-buffer! 'textual - (constant port-ibuffer-disp) - (constant port-icount-disp) - (constant port-ilast-disp))) - (define build-set-textual-port-output-buffer! - (make-build-set-port-buffer! 'textual - (constant port-obuffer-disp) - (constant port-ocount-disp) - (constant port-olast-disp))) - (define-inline 3 set-textual-port-input-buffer! - [(e-p e-b) (build-set-textual-port-input-buffer! e-p e-b #f)]) - (define-inline 3 set-textual-port-output-buffer! - [(e-p e-b) (build-set-textual-port-output-buffer! e-p e-b #f)]) - (let () - (define (go e-name e-handler e-ib e-info) - (make-port e-name e-handler e-ib `(quote "") e-info - (fxlogor (constant type-input-port) (constant PORT-FLAG-INPUT-MODE)) - build-set-textual-port-input-buffer! - (make-build-clear-count (constant port-ocount-disp)))) - (define-inline 3 $make-textual-input-port - [(e-name e-handler e-ib) (go e-name e-handler e-ib `(quote #f))] - [(e-name e-handler e-ib e-info) (go e-name e-handler e-ib e-info)])) - (let () - (define (go e-name e-handler e-ob e-info) - (make-port e-name e-handler `(quote "") e-ob e-info - (constant type-output-port) - (make-build-clear-count (constant port-icount-disp)) - build-set-textual-port-output-buffer!)) - (define-inline 3 $make-textual-output-port - [(e-name e-handler e-ob) (go e-name e-handler e-ob `(quote #f))] - [(e-name e-handler e-ob e-info) (go e-name e-handler e-ob e-info)])) - (let () - (define (go e-name e-handler e-ib e-ob e-info) - (make-port e-name e-handler e-ib e-ob e-info - (constant type-io-port) - build-set-textual-port-input-buffer! - build-set-textual-port-output-buffer!)) - (define-inline 3 $make-textual-input/output-port - [(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-set-binary-port-input-buffer! - (make-build-set-port-buffer! 'binary - (constant port-ibuffer-disp) - (constant port-icount-disp) - (constant port-ilast-disp))) - (define build-set-binary-port-output-buffer! - (make-build-set-port-buffer! 'binary - (constant port-obuffer-disp) - (constant port-ocount-disp) - (constant port-olast-disp))) - (define-inline 3 set-binary-port-input-buffer! - [(e-p e-b) (build-set-binary-port-input-buffer! e-p e-b #f)]) - (define-inline 3 set-binary-port-output-buffer! - [(e-p e-b) (build-set-binary-port-output-buffer! e-p e-b #f)]) - (let () - (define (go e-name e-handler e-ib e-info) - (make-port e-name e-handler e-ib `(quote #vu8()) e-info - (fxlogor (constant type-input-port) (constant PORT-FLAG-INPUT-MODE) (constant PORT-FLAG-BINARY)) - build-set-binary-port-input-buffer! - (make-build-clear-count (constant port-ocount-disp)))) - (define-inline 3 $make-binary-input-port - [(e-name e-handler e-ib) (go e-name e-handler e-ib `(quote #f))] - [(e-name e-handler e-ib e-info) (go e-name e-handler e-ib e-info)])) - (let () - (define (go e-name e-handler e-ob e-info) - (make-port e-name e-handler `(quote #vu8()) e-ob e-info - (fxlogor (constant type-output-port) (constant PORT-FLAG-BINARY)) - (make-build-clear-count (constant port-icount-disp)) - build-set-binary-port-output-buffer!)) - (define-inline 3 $make-binary-output-port - [(e-name e-handler e-ob) (go e-name e-handler e-ob `(quote #f))] - [(e-name e-handler e-ob e-info) (go e-name e-handler e-ob e-info)])) - (let () - (define (go e-name e-handler e-ib e-ob e-info) - (make-port e-name e-handler e-ib e-ob e-info - (fxlogor (constant type-io-port) (constant PORT-FLAG-BINARY)) - build-set-binary-port-input-buffer! - build-set-binary-port-output-buffer!)) - (define-inline 3 $make-binary-input/output-port - [(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 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? - [(e-fv e-i) (bind #t (e-fv e-i) (build-fxvector-set!-check e-fv e-i #f))]) - (let () - (define (go e-fv e-i) - (cond - [(expr->index e-i 1 (constant maximum-fxvector-length)) => - (lambda (index) - (%mref ,e-fv - ,(+ (fix index) (constant fxvector-data-disp))))] - [else (%mref ,e-fv ,e-i ,(constant fxvector-data-disp))])) - (define-inline 3 fxvector-ref - [(e-fv e-i) (go e-fv e-i)]) - (define-inline 2 fxvector-ref - [(e-fv e-i) - (bind #t (e-fv e-i) - `(if ,(build-fxvector-ref-check e-fv e-i #f) - ,(go e-fv e-i) - ,(build-libcall #t src sexpr fxvector-ref e-fv e-i)))])) - (let () - (define (go e-fv e-i e-new) - `(set! - ,(cond - [(expr->index e-i 1 (constant maximum-fxvector-length)) => - (lambda (index) - (%mref ,e-fv - ,(+ (fix index) (constant fxvector-data-disp))))] - [else (%mref ,e-fv ,e-i ,(constant fxvector-data-disp))]) - ,e-new)) - (define-inline 3 fxvector-set! - [(e-fv e-i e-new) - (go e-fv e-i e-new)]) - (define-inline 2 fxvector-set! - [(e-fv e-i e-new) - (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)))]))) - (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) - ((build-ref-check string-type-disp maximum-string-length string-length-offset type-string mask-string string-immutable-flag) e-s e-i #f))) - (define build-string-set!-check - (lambda (e-s e-i) - ((build-ref-check string-type-disp maximum-string-length string-length-offset type-mutable-string mask-mutable-string string-immutable-flag) e-s e-i #f))) - (define-inline 2 $string-ref-check? - [(e-s e-i) (bind #t (e-s e-i) (build-string-ref-check e-s e-i))]) - (define-inline 2 $string-set!-check? - [(e-s e-i) (bind #t (e-s e-i) (build-string-set!-check e-s e-i))]) - (let () - (define (go e-s e-i) - (cond - [(expr->index e-i 1 (constant maximum-string-length)) => - (lambda (index) - `(inline ,(make-info-load (string-char-type) #f) ,%load ,e-s ,%zero - (immediate ,(+ (* (constant string-char-bytes) index) (constant string-data-disp)))))] - [else - `(inline ,(make-info-load (string-char-type) #f) ,%load ,e-s - ,(translate e-i - (constant fixnum-offset) - (constant string-char-offset)) - ,(%constant string-data-disp))])) - (define-inline 3 string-ref - [(e-s e-i) (go e-s e-i)]) - (define-inline 2 string-ref - [(e-s e-i) - (bind #t (e-s e-i) - `(if ,(build-string-ref-check e-s e-i) - ,(go e-s e-i) - ,(build-libcall #t src sexpr string-ref e-s e-i)))])) - (let () - (define (go e-s e-i e-new) - (cond - [(expr->index e-i 1 (constant maximum-string-length)) => - (lambda (index) - `(inline ,(make-info-load (string-char-type) #f) ,%store ,e-s ,%zero - (immediate ,(+ (* (constant string-char-bytes) index) (constant string-data-disp))) - ,e-new))] - [else - `(inline ,(make-info-load (string-char-type) #f) ,%store ,e-s - ,(translate e-i - (constant fixnum-offset) - (constant string-char-offset)) - ,(%constant string-data-disp) - ,e-new)])) - (define-inline 3 string-set! - [(e-s e-i e-new) (go e-s e-i e-new)]) - (define-inline 2 string-set! - [(e-s e-i e-new) - (bind #t (e-s e-i e-new) - `(if ,(let ([e-ref-check (build-string-set!-check e-s e-i)]) - (if (constant? char? e-new) - e-ref-check - (build-and e-ref-check (%type-check mask-char type-char ,e-new)))) - ,(go e-s e-i e-new) - ,(build-libcall #t src sexpr string-set! e-s e-i e-new)))]) - (define-inline 3 $string-set-immutable! - [(e-s) ((build-set-immutable! string-type-disp string-immutable-flag) e-s)]))) - (let () - (define build-vector-ref-check (build-ref-check vector-type-disp maximum-vector-length vector-length-offset type-vector mask-vector vector-immutable-flag)) - (define build-vector-set!-check (build-ref-check vector-type-disp maximum-vector-length vector-length-offset type-mutable-vector mask-mutable-vector vector-immutable-flag)) - (define-inline 2 $vector-ref-check? - [(e-v e-i) (bind #t (e-v e-i) (build-vector-ref-check e-v e-i #f))]) - (define-inline 2 $vector-set!-check? - [(e-v e-i) (bind #t (e-v e-i) (build-vector-set!-check e-v e-i #f))]) - (let () - (define (go e-v e-i) - (nanopass-case (L7 Expr) e-i - [(quote ,d) - (guard (target-fixnum? d)) - (%mref ,e-v ,(+ (fix d) (constant vector-data-disp)))] - [else (%mref ,e-v ,e-i ,(constant vector-data-disp))])) - (define-inline 3 vector-ref - [(e-v e-i) (go e-v e-i)]) - (define-inline 2 vector-ref - [(e-v e-i) - (bind #t (e-v e-i) - `(if ,(build-vector-ref-check e-v e-i #f) - ,(go e-v e-i) - ,(build-libcall #t src sexpr vector-ref e-v e-i)))])) - (let () - (define (go e-v e-i e-new) - (nanopass-case (L7 Expr) e-i - [(quote ,d) - (guard (target-fixnum? d)) - (build-dirty-store e-v (+ (fix d) (constant vector-data-disp)) e-new)] - [else (build-dirty-store e-v e-i (constant vector-data-disp) e-new)])) - (define-inline 3 vector-set! - [(e-v e-i e-new) (go e-v e-i e-new)]) - (define-inline 2 vector-set! - [(e-v e-i e-new) - (bind #t (e-v e-i e-new) - `(if ,(build-vector-set!-check e-v e-i #f) - ,(go e-v e-i e-new) - ,(build-libcall #t src sexpr vector-set! e-v e-i e-new)))]) - (define-inline 3 $vector-set-immutable! - [(e-fv) ((build-set-immutable! vector-type-disp vector-immutable-flag) e-fv)])) - (let () - (define (go e-v e-i e-old e-new) - (nanopass-case (L7 Expr) e-i - [(quote ,d) - (guard (target-fixnum? d)) - (build-dirty-store e-v %zero (+ (fix d) (constant vector-data-disp)) e-new (make-build-cas e-old) build-cas-seq)] - [else (build-dirty-store e-v e-i (constant vector-data-disp) e-new (make-build-cas e-old) build-cas-seq)])) - (define-inline 3 vector-cas! - [(e-v e-i e-old e-new) (go e-v e-i e-old e-new)]) - (define-inline 2 vector-cas! - [(e-v e-i e-old e-new) - (bind #t (e-v e-i e-old e-new) - `(if ,(build-vector-set!-check e-v e-i #f) - ,(go e-v e-i e-old e-new) - ,(build-libcall #t src sexpr vector-cas! e-v e-i e-old e-new)))])) - (let () - (define (go e-v e-i e-new) - `(set! - ,(nanopass-case (L7 Expr) e-i - [(quote ,d) - (guard (target-fixnum? d)) - (%mref ,e-v ,(+ (fix d) (constant vector-data-disp)))] - [else (%mref ,e-v ,e-i ,(constant vector-data-disp))]) - ,e-new)) - (define-inline 3 vector-set-fixnum! - [(e-v e-i e-new) (go e-v e-i e-new)]) - (define-inline 2 vector-set-fixnum! - [(e-v e-i e-new) - (bind #t (e-v e-i e-new) - `(if ,(build-vector-set!-check e-v e-i e-new) - ,(go e-v e-i e-new) - ,(build-libcall #t src sexpr vector-set-fixnum! e-v e-i e-new)))]))) - (let () - (define (go e-v e-i) - (nanopass-case (L7 Expr) e-i - [(quote ,d) - (guard (target-fixnum? d)) - (%mref ,e-v ,(+ (fix d) (constant stencil-vector-data-disp)))] - [else (%mref ,e-v ,e-i ,(constant stencil-vector-data-disp))])) - (define-inline 3 stencil-vector-ref - [(e-v e-i) (go e-v e-i)])) - (let () - (define (go e-v e-i e-new) - (nanopass-case (L7 Expr) e-i - [(quote ,d) - (guard (target-fixnum? d)) - (build-dirty-store e-v (+ (fix d) (constant stencil-vector-data-disp)) e-new)] - [else (build-dirty-store e-v e-i (constant stencil-vector-data-disp) e-new)])) - (define-inline 3 stencil-vector-set! - [(e-v e-i e-new) (go e-v e-i e-new)])) - (let () - (define (go e-v e-i e-new) - `(set! - ,(nanopass-case (L7 Expr) e-i - [(quote ,d) - (guard (target-fixnum? d)) - (%mref ,e-v ,(+ (fix d) (constant stencil-vector-data-disp)))] - [else (%mref ,e-v ,e-i ,(constant stencil-vector-data-disp))]) - ,e-new)) - (define-inline 3 $stencil-vector-set! - [(e-v e-i e-new) (go e-v e-i e-new)])) - (let () - (define (go e-v e-i) - (nanopass-case (L7 Expr) e-i - [(quote ,d) - (guard (target-fixnum? d)) - (%mref ,e-v ,(+ (fix d) (constant record-data-disp)))] - [else (%mref ,e-v ,e-i ,(constant record-data-disp))])) - (define-inline 3 $record-ref - [(e-v e-i) (go e-v e-i)])) - (let () - (define (go e-v e-i e-new) - (nanopass-case (L7 Expr) e-i - [(quote ,d) - (guard (target-fixnum? d)) - (build-dirty-store e-v (+ (fix d) (constant record-data-disp)) e-new)] - [else (build-dirty-store e-v e-i (constant record-data-disp) e-new)])) - (define-inline 3 $record-set! - [(e-v e-i e-new) (go e-v e-i e-new)])) - (let () - (define (go e-v e-i e-old e-new) - (nanopass-case (L7 Expr) e-i - [(quote ,d) - (guard (target-fixnum? d)) - (build-dirty-store e-v %zero (+ (fix d) (constant record-data-disp)) e-new (make-build-cas e-old) build-cas-seq)] - [else (build-dirty-store e-v e-i (constant record-data-disp) e-new (make-build-cas e-old) build-cas-seq)])) - (define-inline 3 $record-cas! - [(e-v e-i e-old e-new) (go e-v e-i e-old e-new)])) - (let () - (define build-bytevector-ref-check - (lambda (e-bits e-bv e-i check-mutable?) - (nanopass-case (L7 Expr) e-bits - [(quote ,d) - (guard (and (fixnum? d) (fx> d 0) (fx= (* (fxquotient d 8) 8) d))) - (let ([bits d] [bytes (fxquotient d 8)]) - (bind #t (e-bv e-i) - (build-and - (%type-check mask-typed-object type-typed-object ,e-bv) - (bind #t ([t (%mref ,e-bv ,(constant bytevector-type-disp))]) - (build-and - (if check-mutable? - (%type-check mask-mutable-bytevector type-mutable-bytevector ,t) - (%type-check mask-bytevector type-bytevector ,t)) - (cond - [(expr->index e-i bytes (constant maximum-bytevector-length)) => - (lambda (index) - (%inline u< - (immediate ,(logor (ash (+ index (fx- bytes 1)) (constant bytevector-length-offset)) - (constant type-bytevector) (constant bytevector-immutable-flag))) - ,t))] - [else - (build-and - ($type-check (fxlogor (fix (fx- bytes 1)) (constant mask-fixnum)) (constant type-fixnum) e-i) - (%inline u< - ; NB. add cannot overflow or change negative to positive when - ; low-order (log2 bytes) bits of fixnum value are zero, as - ; guaranteed by type-check above - ,(if (fx= bytes 1) - e-i - (%inline + ,e-i (immediate ,(fix (fx- bytes 1))))) - ,(%inline logand - ,(translate t - (constant bytevector-length-offset) - (constant fixnum-offset)) - (immediate ,(- (constant fixnum-factor))))))]))))))] - [(seq (profile ,src) ,[e]) (and e `(seq (profile ,src) ,e))] - [else #f]))) - (define-inline 2 $bytevector-ref-check? - [(e-bits e-bv e-i) (build-bytevector-ref-check e-bits e-bv e-i #f)]) - (define-inline 2 $bytevector-set!-check? - [(e-bits e-bv e-i) (build-bytevector-ref-check e-bits e-bv e-i #t)])) - (let () - (define build-bytevector-fill - (let ([filler (make-build-fill 1 (constant bytevector-data-disp))]) - (lambda (e-bv e-bytes e-fill) - (bind #t uptr ([e-fill (build-unfix e-fill)]) - (filler e-bv e-bytes e-fill))))) - (let () - (define do-make-bytevector - (lambda (e-length maybe-e-fill) - ; NB: caller must bind maybe-e-fill - (safe-assert (or (not maybe-e-fill) (no-need-to-bind? #f maybe-e-fill))) - (if (constant? (lambda (x) (and (fixnum? x) (fx<= 0 x 10000))) e-length) - (let ([n (constant-value e-length)]) - (if (fx= n 0) - `(quote ,(bytevector)) - (bind #t ([t (%constant-alloc type-typed-object - (fx+ (constant header-size-bytevector) n))]) - `(seq - (set! ,(%mref ,t ,(constant bytevector-type-disp)) - (immediate ,(fx+ (fx* n (constant bytevector-length-factor)) - (constant type-bytevector)))) - ,(if maybe-e-fill - (build-bytevector-fill t `(immediate ,n) maybe-e-fill) - t))))) - (bind #t (e-length) - (let ([t-bytes (make-tmp 'tbytes 'uptr)] [t-vec (make-tmp 'tvec)]) - `(if ,(%inline eq? ,e-length (immediate 0)) - (quote ,(bytevector)) - (let ([,t-bytes ,(build-unfix e-length)]) - (let ([,t-vec (alloc ,(make-info-alloc (constant type-typed-object) #f #f) - ,(%inline logand - ,(%inline + ,t-bytes - (immediate ,(fx+ (constant header-size-bytevector) - (fx- (constant byte-alignment) 1)))) - (immediate ,(- (constant byte-alignment)))))]) - (seq - (set! ,(%mref ,t-vec ,(constant bytevector-type-disp)) - ,(build-type/length t-bytes - (constant type-bytevector) - 0 - (constant bytevector-length-offset))) - ,(if maybe-e-fill - (build-bytevector-fill t-vec t-bytes maybe-e-fill) - t-vec)))))))))) - (let () - (define valid-length? - (lambda (e-length) - (constant? - (lambda (x) - (and (or (fixnum? x) (bignum? x)) - (<= 0 x (constant maximum-bytevector-length)))) - e-length))) - (define-inline 2 make-bytevector - [(e-length) (and (valid-length? e-length) (do-make-bytevector e-length #f))] - [(e-length e-fill) - (and (valid-length? e-length) - (constant? (lambda (x) (and (fixnum? x) (fx<= -128 x 255))) e-fill) - (do-make-bytevector e-length e-fill))])) - (define-inline 3 make-bytevector - [(e-length) (do-make-bytevector e-length #f)] - [(e-length e-fill) (bind #f (e-fill) (do-make-bytevector e-length e-fill))])) - (define-inline 3 bytevector-fill! - [(e-bv e-fill) - (bind #t (e-bv e-fill) - `(seq - ,(build-bytevector-fill e-bv - (%inline srl - ,(%mref ,e-bv ,(constant bytevector-type-disp)) - ,(%constant bytevector-length-offset)) - e-fill) - ,(%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 - (lambda (e*) - (define (find-k n) - (constant-case native-endianness - [(unknown) - (values 1 'unsigned-8)] - [else - (let loop ([bytes (constant-case ptr-bits [(32) 4] [(64) 8])] - [type* (constant-case ptr-bits - [(32) '(unsigned-32 unsigned-16 unsigned-8)] - [(64) '(unsigned-64 unsigned-32 unsigned-16 unsigned-8)])]) - (let ([bytes/2 (fxsrl bytes 1)]) - (if (fx<= n bytes/2) - (loop bytes/2 (cdr type*)) - (values bytes (car type*)))))])) - (define (build-chunk k n e*) - (define (build-shift e shift) - (if (fx= shift 0) e (%inline sll ,e (immediate ,shift)))) - (let loop ([k (constant-case native-endianness - [(little) (fxmin k n)] - [(big) k] - [(unknown) (safe-assert (= k 1)) 1])] - [e* (constant-case native-endianness - [(little) (reverse (if (fx<= n k) e* (list-head e* k)))] - [(big) e*] - [(unknown) e*])] - [constant-part 0] - [expression-part #f] - [expression-shift 0] - [mask? #f]) ; no need to mask the high-order byte - (if (fx= k 0) - (if expression-part - (let ([expression-part (build-shift expression-part expression-shift)]) - (if (= constant-part 0) - expression-part - (%inline logor ,expression-part (immediate ,constant-part)))) - `(immediate ,constant-part)) - (let ([k (fx- k 1)] - [constant-part (ash constant-part 8)] - [expression-shift (fx+ expression-shift 8)]) - (if (null? e*) - (loop k e* constant-part expression-part expression-shift #t) - (let ([e (car e*)] [e* (cdr e*)]) - (if (fixnum-constant? e) - (loop k e* (logor constant-part (logand (constant-value e) #xff)) expression-part expression-shift #t) - (loop k e* constant-part - (let* ([e (build-unfix e)] - [e (if mask? (%inline logand ,e (immediate #xff)) e)]) - (if expression-part - (%inline logor ,(build-shift expression-part expression-shift) ,e) - e)) - 0 #t)))))))) - (let ([len (length e*)]) - (if (fx= len 0) - `(quote ,(bytevector)) - (list-bind #f (e*) - (bind #t ([t (%constant-alloc type-typed-object - (fx+ (constant header-size-bytevector) len))]) - `(seq - (set! ,(%mref ,t ,(constant bytevector-type-disp)) - (immediate ,(+ (* len (constant bytevector-length-factor)) - (constant type-bytevector)))) - ; build and store k-octet (k = 4 on 32-bit machines, k = 8 on 64-bit - ; machines) chunks, taking endianness into account. for the last - ; chunk, set k = 1, 2, 4, or 8 depending on the number of octets - ; remaining, padding with zeros as necessary. - ,(let f ([e* e*] [n (length e*)] [offset (constant bytevector-data-disp)]) - (let-values ([(k type) (find-k n)]) - `(seq - (inline ,(make-info-load type #f) ,%store ,t ,%zero (immediate ,offset) - ,(build-chunk k n e*)) - ,(if (fx<= n k) - t - (f (list-tail e* k) (fx- n k) (fx+ offset k))))))))))))) - - (define-inline 2 bytevector - [e* (and (andmap - (lambda (x) - (constant? - (lambda (x) (and (fixnum? x) (fx<= -128 x 255))) - x)) - e*) - (build-bytevector e*))]) - - (define-inline 3 bytevector - [e* (build-bytevector e*)])) - - (let () - (define byte-offset - (lambda (off) - (cond - [(nanopass-case (L7 Expr) off - [(quote ,d) - (and (and (integer? d) (exact? d)) - (let ([n (+ d (constant bytevector-data-disp))]) - (and (target-fixnum? n) - `(quote ,n))))] - [else #f])] - [else (%inline + ,off - (quote ,(constant bytevector-data-disp)))]))) - - (define-inline 3 bytevector-copy! - [(bv1 off1 bv2 off2 n) - (%primcall src sexpr $byte-copy! ,bv1 ,(byte-offset off1) ,bv2 ,(byte-offset off2) ,n)])) - - (define-inline 3 bytevector-truncate! - [(bv len) - (if (fixnum-constant? len) - (let ([len (constant-value len)]) - (if (fx= len 0) - `(quote ,(bytevector)) - (bind #t (bv) - `(seq - (set! ,(%mref ,bv ,(constant bytevector-type-disp)) - (immediate ,(fx+ (fx* len (constant bytevector-length-factor)) - (constant type-bytevector)))) - ,bv)))) - (bind #t (bv len) - `(if ,(%inline eq? ,len (immediate 0)) - (quote ,(bytevector)) - (seq - (set! ,(%mref ,bv ,(constant bytevector-type-disp)) - ,(build-type/length len - (constant type-bytevector) - (constant fixnum-offset) - (constant bytevector-length-offset))) - ,bv))))]) - - (define-inline 3 $bytevector-set-immutable! - [(bv) ((build-set-immutable! bytevector-type-disp bytevector-immutable-flag) bv)]) - - (let () - (define bv-index-offset - (lambda (offset-expr) - (if (fixnum-constant? offset-expr) - (values %zero (+ (constant bytevector-data-disp) (constant-value offset-expr))) - (values (build-unfix offset-expr) (constant bytevector-data-disp))))) - - (define bv-offset-okay? - (lambda (x mask) - (constant? (lambda (x) (and (target-fixnum? x) (>= x 0) (eq? (logand x mask) 0))) x))) - - (let () - (define-syntax define-bv-8-inline - (syntax-rules () - [(_ name type) - (define-inline 2 name - [(e-bv e-offset) - (bind #t (e-bv e-offset) - `(if ,(handle-prim #f #f 3 '$bytevector-ref-check? (list `(quote 8) e-bv e-offset)) - ,(let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) - (build-object-ref #f 'type e-bv e-index imm-offset)) - ,(build-libcall #t src sexpr name e-bv e-offset)))])])) - - (define-bv-8-inline bytevector-s8-ref integer-8) - (define-bv-8-inline bytevector-u8-ref unsigned-8)) - - (let () - (define-syntax define-bv-native-ref-inline - (lambda (x) - (syntax-case x () - [(_ name type) - #'(define-inline 3 name - [(e-bv e-offset) - (let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) - (build-object-ref #f 'type e-bv e-index imm-offset))])]))) - - (define-bv-native-ref-inline bytevector-s8-ref integer-8) - (define-bv-native-ref-inline bytevector-u8-ref unsigned-8) - - (define-bv-native-ref-inline bytevector-s16-native-ref integer-16) - (define-bv-native-ref-inline bytevector-u16-native-ref unsigned-16) - - (define-bv-native-ref-inline bytevector-s32-native-ref integer-32) - (define-bv-native-ref-inline bytevector-u32-native-ref unsigned-32) - - (define-bv-native-ref-inline bytevector-s64-native-ref integer-64) - (define-bv-native-ref-inline bytevector-u64-native-ref unsigned-64) - - (define-bv-native-ref-inline bytevector-ieee-single-native-ref single-float) - (define-bv-native-ref-inline bytevector-ieee-double-native-ref double-float) - - ;; Inline to enable unboxing: - (define-inline 2 bytevector-ieee-double-native-ref - [(e-bv e-offset) - (bind #t (e-bv e-offset) - (let ([info (make-info-call #f #f #f #f #f)]) - `(if (call ,info ,#f ,(lookup-primref 3 '$bytevector-ref-check?) (quote 64) ,e-bv ,e-offset) - (call ,info ,#f ,(lookup-primref 3 'bytevector-ieee-double-native-ref) ,e-bv ,e-offset) - ,(build-libcall #t src sexpr bytevector-ieee-double-native-ref e-bv e-offset))))])) - - (let () - (define-syntax define-bv-native-int-set!-inline - (lambda (x) - (syntax-case x () - [(_ check-64? name type) - (with-syntax ([body #'(let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) - (build-object-set! 'type e-bv e-index imm-offset e-val))]) - (with-syntax ([body (if (datum check-64?) - #'(and (>= (constant ptr-bits) 64) body) - #'body)]) - #'(define-inline 3 name - [(e-bv e-offset e-val) body])))]))) - - (define-bv-native-int-set!-inline #f bytevector-s8-set! integer-8) - (define-bv-native-int-set!-inline #f bytevector-u8-set! unsigned-8) - (define-bv-native-int-set!-inline #f $bytevector-set! unsigned-8) - - (define-bv-native-int-set!-inline #f bytevector-s16-native-set! integer-16) - (define-bv-native-int-set!-inline #f bytevector-u16-native-set! unsigned-16) - - (define-bv-native-int-set!-inline #f bytevector-s32-native-set! integer-32) - (define-bv-native-int-set!-inline #f bytevector-u32-native-set! unsigned-32) - - (define-bv-native-int-set!-inline #t bytevector-s64-native-set! integer-64) - (define-bv-native-int-set!-inline #t bytevector-u64-native-set! unsigned-64)) - - (let () - (define-syntax define-bv-native-ieee-set!-inline - (lambda (x) - (syntax-case x () - [(_ name type) - #'(define-inline 3 name - [(e-bv e-offset e-val) - (let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) - (bind #f (e-bv e-index) - (build-object-set! 'type e-bv e-index imm-offset - (build-$real->flonum src sexpr e-val `(quote name)))))])]))) - - (define-bv-native-ieee-set!-inline bytevector-ieee-single-native-set! single-float) - (define-bv-native-ieee-set!-inline bytevector-ieee-double-native-set! double-float) - - ;; Inline to enable unboxing: - (define-inline 2 bytevector-ieee-double-native-set! - [(e-bv e-offset e-val) - (bind #t (e-bv e-offset) - (let ([info (make-info-call #f #f #f #f #f)]) - `(if (call ,info ,#f ,(lookup-primref 3 '$bytevector-set!-check?) (quote 64) ,e-bv ,e-offset) - ;; checks to make sure e-val produces a real number: - (call ,info ,#f ,(lookup-primref 3 'bytevector-ieee-double-native-set!) ,e-bv ,e-offset ,e-val) - ,(build-libcall #t src sexpr bytevector-ieee-double-native-set! e-bv e-offset))))])) - - (let () - (define-syntax define-bv-int-ref-inline - (lambda (x) - (define p2? - (lambda (n) - (let f ([i 1]) - (or (fx= i n) - (and (not (fx> i n)) (f (fxsll i 1))))))) - (syntax-case x () - [(_ name type mask) - #`(define-inline 3 name - [(e-bv e-offset e-eness) - (and (or (constant unaligned-integers) - (and #,(p2? (fx+ (datum mask) 1)) (bv-offset-okay? e-offset mask))) - (constant? (lambda (x) (memq x '(big little))) e-eness) - (let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) - (build-object-ref (not (eq? (constant-value e-eness) (constant native-endianness))) - 'type e-bv e-index imm-offset)))])]))) - - (define-bv-int-ref-inline bytevector-s16-ref integer-16 1) - (define-bv-int-ref-inline bytevector-u16-ref unsigned-16 1) - - (when-known-endianness - (define-bv-int-ref-inline bytevector-s24-ref integer-24 1) - (define-bv-int-ref-inline bytevector-u24-ref unsigned-24 1)) - - (define-bv-int-ref-inline bytevector-s32-ref integer-32 3) - (define-bv-int-ref-inline bytevector-u32-ref unsigned-32 3) - - (when-known-endianness - (define-bv-int-ref-inline bytevector-s40-ref integer-40 3) - (define-bv-int-ref-inline bytevector-u40-ref unsigned-40 3) - - (define-bv-int-ref-inline bytevector-s48-ref integer-48 3) - (define-bv-int-ref-inline bytevector-u48-ref unsigned-48 3) - - (define-bv-int-ref-inline bytevector-s56-ref integer-56 7) - (define-bv-int-ref-inline bytevector-u56-ref unsigned-56 7)) - - (define-bv-int-ref-inline bytevector-s64-ref integer-64 7) - (define-bv-int-ref-inline bytevector-u64-ref unsigned-64 7)) - - (let () - (define-syntax define-bv-ieee-ref-inline - (lambda (x) - (syntax-case x () - [(_ name type mask) - #'(define-inline 3 name - [(e-bv e-offset e-eness) - (and (or (constant unaligned-floats) - (bv-offset-okay? e-offset mask)) - (safe-assert (not (eq? (constant native-endianness) 'unknown))) - (constant? (lambda (x) (eq? x (constant native-endianness))) e-eness) - (let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) - (build-object-ref #f 'type e-bv e-index imm-offset)))])]))) - - (define-bv-ieee-ref-inline bytevector-ieee-single-ref single-float 3) - (define-bv-ieee-ref-inline bytevector-ieee-double-ref double-float 7)) - - (let () - (define-syntax define-bv-int-set!-inline - (lambda (x) - (syntax-case x () - [(_ check-64? name type mask) - (with-syntax ([body #'(and (or (constant unaligned-integers) - (and mask (bv-offset-okay? e-offset mask))) - (safe-assert (not (eq? (constant native-endianness) 'unknown))) - (constant? (lambda (x) (memq x '(big little))) e-eness) - (let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) - (if (eq? (constant-value e-eness) (constant native-endianness)) - (build-object-set! 'type e-bv e-index imm-offset e-value) - (build-swap-object-set! 'type e-bv e-index imm-offset e-value))))]) - (with-syntax ([body (if (datum check-64?) - #'(and (>= (constant ptr-bits) 64) body) - #'body)]) - #'(define-inline 3 name - [(e-bv e-offset e-value e-eness) body])))]))) - - (define-bv-int-set!-inline #f bytevector-s16-set! integer-16 1) - (define-bv-int-set!-inline #f bytevector-u16-set! unsigned-16 1) - - (define-bv-int-set!-inline #f bytevector-s24-set! integer-24 #f) - (define-bv-int-set!-inline #f bytevector-u24-set! unsigned-24 #f) - - (define-bv-int-set!-inline #f bytevector-s32-set! integer-32 3) - (define-bv-int-set!-inline #f bytevector-u32-set! unsigned-32 3) - - (define-bv-int-set!-inline #t bytevector-s40-set! integer-40 #f) - (define-bv-int-set!-inline #t bytevector-u40-set! unsigned-40 #f) - - (define-bv-int-set!-inline #t bytevector-s48-set! integer-48 #f) - (define-bv-int-set!-inline #t bytevector-u48-set! unsigned-48 #f) - - (define-bv-int-set!-inline #t bytevector-s56-set! integer-56 #f) - (define-bv-int-set!-inline #t bytevector-u56-set! unsigned-56 #f) - - (define-bv-int-set!-inline #t bytevector-s64-set! integer-64 7) - (define-bv-int-set!-inline #t bytevector-u64-set! unsigned-64 7)) - - (let () - (define-syntax define-bv-ieee-set!-inline - (lambda (x) - (syntax-case x () - [(_ name type mask) - #'(define-inline 3 name - [(e-bv e-offset e-value e-eness) - (and (or (constant unaligned-floats) (bv-offset-okay? e-offset mask)) - (safe-assert (not (eq? (constant native-endianness) 'unknown))) - (constant? (lambda (x) (eq? x (constant native-endianness))) e-eness) - (let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) - (bind #f (e-bv e-index) - (build-object-set! 'type e-bv e-index imm-offset - (build-$real->flonum src sexpr e-value - `(quote name))))))])]))) - - (define-bv-ieee-set!-inline bytevector-ieee-single-set! single-float 3) - (define-bv-ieee-set!-inline bytevector-ieee-double-set! double-float 7)) - - (let () - (define anyint-ref-helper - (lambda (type mask e-bv e-offset e-eness) - (and (or (constant unaligned-integers) (bv-offset-okay? e-offset mask)) - (constant? (lambda (x) (memq x '(big little))) e-eness) - (safe-assert (not (eq? (constant native-endianness) 'unknown))) - (let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) - (build-object-ref (not (eq? (constant-value e-eness) (constant native-endianness))) - type e-bv e-index imm-offset))))) - (define-syntax define-bv-anyint-ref-inline - (syntax-rules () - [(_ name type8 type16 type32 type64) - (define-inline 3 name - [(e-bv e-offset e-eness e-size) - (and (fixnum-constant? e-size) - (case (constant-value e-size) - [(1) (let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) - `(seq - ,e-eness - ,(build-object-ref #f 'type8 e-bv e-index imm-offset)))] - [(2) (anyint-ref-helper 'type16 #b1 e-bv e-offset e-eness)] - [(4) (anyint-ref-helper 'type32 #b11 e-bv e-offset e-eness)] - [(8) (anyint-ref-helper 'type64 #b111 e-bv e-offset e-eness)] - [else #f]))])])) - - (define-bv-anyint-ref-inline bytevector-sint-ref - integer-8 integer-16 integer-32 integer-64) - (define-bv-anyint-ref-inline bytevector-uint-ref - unsigned-8 unsigned-16 unsigned-32 unsigned-64)) - - (let () - (define anyint-set!-helper - (lambda (type mask e-bv e-offset e-value e-eness) - (and (or (constant unaligned-integers) (bv-offset-okay? e-offset mask)) - (safe-assert (not (eq? (constant native-endianness) 'unknown))) - (constant? (lambda (x) (memq x '(big little))) e-eness) - (let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) - (if (eq? (constant-value e-eness) (constant native-endianness)) - (build-object-set! type e-bv e-index imm-offset e-value) - (build-swap-object-set! type e-bv e-index imm-offset e-value)))))) - (define-syntax define-bv-anyint-set!-inline - (syntax-rules () - [(_ name type8 type16 type32 type64) - (define-inline 3 name - [(e-bv e-offset e-value e-eness e-size) - (and (fixnum-constant? e-size) - (case (constant-value e-size) - [(1) (let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) - `(seq - ,e-eness - ,(build-object-set! 'type8 e-bv e-index imm-offset e-value)))] - [(2) (anyint-set!-helper 'type16 1 e-bv e-offset e-value e-eness)] - [(4) (anyint-set!-helper 'type32 3 e-bv e-offset e-value e-eness)] - [(8) (and (>= (constant ptr-bits) 64) - (anyint-set!-helper 'type64 7 e-bv e-offset e-value e-eness))] - [else #f]))])])) - - (define-bv-anyint-set!-inline bytevector-sint-set! - integer-8 integer-16 integer-32 integer-64) - (define-bv-anyint-set!-inline bytevector-uint-set! - unsigned-8 unsigned-16 unsigned-32 unsigned-64))) - - (let () - (define (byte-count e-n) - (or (nanopass-case (L7 Expr) e-n - [(quote ,d) - (and (and (integer? d) (exact? d)) - (let ([n (* d (constant string-char-bytes))]) - (and (target-fixnum? n) - `(immediate ,(fix n)))))] - [else #f]) - (%inline sll ,e-n ,(%constant string-char-offset)))) - (define byte-offset - (lambda (e-off) - (or (nanopass-case (L7 Expr) e-off - [(quote ,d) - (and (and (integer? d) (exact? d)) - (let ([n (+ (* d (constant string-char-bytes)) - (constant string-data-disp))]) - (and (target-fixnum? n) - `(immediate ,(fix n)))))] - [else #f]) - (%inline + - ,(%inline sll ,e-off ,(%constant string-char-offset)) - (immediate ,(fix (constant string-data-disp))))))) - (define-inline 3 string-copy! - [(e-bv1 e-off1 e-bv2 e-off2 e-n) - (%primcall src sexpr $byte-copy! ,e-bv1 ,(byte-offset e-off1) ,e-bv2 ,(byte-offset e-off2) ,(byte-count e-n))])) - - (define-inline 3 string-truncate! - [(e-str e-len) - (if (fixnum-constant? e-len) - (let ([len (constant-value e-len)]) - (if (fx= len 0) - `(quote ,(string)) - (bind #t (e-str) - `(seq - (set! ,(%mref ,e-str ,(constant string-type-disp)) - (immediate ,(fx+ (fx* len (constant string-length-factor)) - (constant type-string)))) - ,e-str)))) - (bind #t (e-str e-len) - `(if ,(%inline eq? ,e-len (immediate 0)) - (quote ,(string)) - (seq - (set! ,(%mref ,e-str ,(constant string-type-disp)) - ,(build-type/length e-len - (constant type-string) - (constant fixnum-offset) - (constant string-length-offset))) - ,e-str))))]) - - (let () - (define build-string-fill - (make-build-fill (constant string-char-bytes) (constant string-data-disp))) - (let () - (define do-make-string - (lambda (e-length e-fill) - ; NB: caller must bind e-fill - (safe-assert (no-need-to-bind? #f e-fill)) - (if (constant? (lambda (x) (and (fixnum? x) (fx<= 0 x 10000))) e-length) - (let ([n (constant-value e-length)]) - (if (fx= n 0) - `(quote ,(string)) - (let ([bytes (fx* n (constant string-char-bytes))]) - (bind #t ([t (%constant-alloc type-typed-object - (fx+ (constant header-size-string) bytes))]) - `(seq - (set! ,(%mref ,t ,(constant string-type-disp)) - (immediate ,(fx+ (fx* n (constant string-length-factor)) - (constant type-string)))) - ,(build-string-fill t `(immediate ,bytes) e-fill)))))) - (bind #t (e-length) - (let ([t-bytes (make-tmp 'tsize 'uptr)] [t-str (make-tmp 'tstr)]) - `(if ,(%inline eq? ,e-length (immediate 0)) - (quote ,(string)) - (let ([,t-bytes ,(translate e-length - (constant fixnum-offset) - (constant string-char-offset))]) - (let ([,t-str (alloc ,(make-info-alloc (constant type-typed-object) #f #f) - ,(%inline logand - ,(%inline + ,t-bytes - (immediate ,(fx+ (constant header-size-string) - (fx- (constant byte-alignment) 1)))) - (immediate ,(- (constant byte-alignment)))))]) - (seq - (set! ,(%mref ,t-str ,(constant string-type-disp)) - ,(build-type/length t-bytes - (constant type-string) - (constant string-char-offset) - (constant string-length-offset))) - ,(build-string-fill t-str t-bytes e-fill)))))))))) - (define default-fill `(immediate ,(ptr->imm #\nul))) - (define-inline 3 make-string - [(e-length) (do-make-string e-length default-fill)] - [(e-length e-fill) (bind #t (e-fill) (do-make-string e-length e-fill))]) - (let () - (define (valid-length? e-length) - (constant? - (lambda (x) - (and (or (fixnum? x) (bignum? x)) - (<= 0 x (constant maximum-string-length)))) - e-length)) - (define-inline 2 make-string - [(e-length) - (and (valid-length? e-length) - (do-make-string e-length default-fill))] - [(e-length e-fill) - (and (valid-length? e-length) - (constant? char? e-fill) - (do-make-string e-length e-fill))]))) - (define-inline 3 string-fill! - [(e-str e-fill) - `(seq - ,(bind #t (e-str e-fill) - (build-string-fill e-str - (translate - (%inline logxor - ,(%mref ,e-str ,(constant string-type-disp)) - ,(%constant type-string)) - (constant string-length-offset) - (constant string-char-offset)) - e-fill)) - ,(%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 - (make-build-fill (constant ptr-bytes) (constant fxvector-data-disp))) - (meta-assert (= (constant log2-ptr-bytes) (constant fixnum-offset))) - (let () - (define do-make-fxvector - (lambda (e-length e-fill) - ; NB: caller must bind e-fill - (safe-assert (no-need-to-bind? #f e-fill)) - (if (constant? (lambda (x) (and (fixnum? x) (fx<= 0 x 10000))) e-length) - (let ([n (constant-value e-length)]) - (if (fx= n 0) - `(quote ,(fxvector)) - (let ([bytes (fx* n (constant ptr-bytes))]) - (bind #t ([t (%constant-alloc type-typed-object - (fx+ (constant header-size-fxvector) bytes))]) - `(seq - (set! ,(%mref ,t ,(constant fxvector-type-disp)) - (immediate ,(fx+ (fx* n (constant fxvector-length-factor)) - (constant type-fxvector)))) - ,(build-fxvector-fill t `(immediate ,bytes) e-fill)))))) - (bind #t (e-length) ; fixnum length doubles as byte count - (let ([t-fxv (make-tmp 'tfxv)]) - `(if ,(%inline eq? ,e-length (immediate 0)) - (quote ,(fxvector)) - (let ([,t-fxv (alloc ,(make-info-alloc (constant type-typed-object) #f #f) - ,(%inline logand - ,(%inline + ,e-length - (immediate ,(fx+ (constant header-size-fxvector) - (fx- (constant byte-alignment) 1)))) - (immediate ,(- (constant byte-alignment)))))]) - (seq - (set! ,(%mref ,t-fxv ,(constant fxvector-type-disp)) - ,(build-type/length e-length - (constant type-fxvector) - (constant fixnum-offset) - (constant fxvector-length-offset))) - ,(build-fxvector-fill t-fxv e-length e-fill))))))))) - (define default-fill `(immediate ,(fix 0))) - (define-inline 3 make-fxvector - [(e-length) (do-make-fxvector e-length default-fill)] - [(e-length e-fill) (bind #t (e-fill) (do-make-fxvector e-length e-fill))]) - (let () - (define (valid-length? e-length) - (constant? - (lambda (x) - (and (or (fixnum? x) (bignum? x)) - (<= 0 x (constant maximum-fxvector-length)))) - e-length)) - (define-inline 2 make-fxvector - [(e-length) - (and (valid-length? e-length) - (do-make-fxvector e-length default-fill))] - [(e-length e-fill) - (and (valid-length? e-length) - (constant? fixnum? e-fill) - (do-make-fxvector e-length e-fill))]))) - (define-inline 3 fxvector-fill! - [(e-fxv e-fill) - `(seq - ,(bind #t (e-fxv e-fill) - (build-fxvector-fill e-fxv - (translate - (%inline logxor - ,(%mref ,e-fxv ,(constant fxvector-type-disp)) - ,(%constant type-fxvector)) - (constant fxvector-length-offset) - (constant fixnum-offset)) - e-fill)) - ,(%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))) - (let () - (define do-make-vector - (lambda (e-length e-fill) - ; NB: caller must bind e-fill - (safe-assert (no-need-to-bind? #f e-fill)) - (if (constant? (lambda (x) (and (fixnum? x) (fx<= 0 x 10000))) e-length) - (let ([n (constant-value e-length)]) - (if (fx= n 0) - `(quote ,(vector)) - (let ([bytes (fx* n (constant ptr-bytes))]) - (bind #t ([t (%constant-alloc type-typed-object - (fx+ (constant header-size-vector) bytes))]) - `(seq - (set! ,(%mref ,t ,(constant vector-type-disp)) - (immediate ,(+ (fx* n (constant vector-length-factor)) - (constant type-vector)))) - ,(build-vector-fill t `(immediate ,bytes) e-fill)))))) - (bind #t (e-length) ; fixnum length doubles as byte count - (let ([t-vec (make-tmp 'tvec)]) - `(if ,(%inline eq? ,e-length (immediate 0)) - (quote ,(vector)) - (let ([,t-vec (alloc ,(make-info-alloc (constant type-typed-object) #f #f) - ,(%inline logand - ,(%inline + ,e-length - (immediate ,(fx+ (constant header-size-vector) - (fx- (constant byte-alignment) 1)))) - (immediate ,(- (constant byte-alignment)))))]) - (seq - (set! ,(%mref ,t-vec ,(constant vector-type-disp)) - ,(build-type/length e-length - (constant type-vector) - (constant fixnum-offset) - (constant vector-length-offset))) - ,(build-vector-fill t-vec e-length e-fill))))))))) - (define default-fill `(immediate ,(fix 0))) - (define-inline 3 make-vector - [(e-length) (do-make-vector e-length default-fill)] - [(e-length e-fill) (bind #t (e-fill) (do-make-vector e-length e-fill))]) - (let () - (define (valid-length? e-length) - (constant? - (lambda (x) (and (target-fixnum? x) (>= x 0))) - e-length)) - (define-inline 2 make-vector - [(e-length) - (and (valid-length? e-length) - (do-make-vector e-length default-fill))] - [(e-length e-fill) - (and (valid-length? e-length) - (constant? fixnum? 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))) - (let () - (define build-stencil-vector-type - (lambda (e-mask) ; e-mask is used only once - (%inline logor - (immediate ,(constant type-stencil-vector)) - ,(%inline sll ,e-mask (immediate ,(fx- (constant stencil-vector-mask-offset) - (constant fixnum-offset))))))) - (define do-stencil-vector - (lambda (e-mask e-val*) - (list-bind #f (e-val*) - (bind #f (e-mask) - (let ([t-vec (make-tmp 'tvec)]) - `(let ([,t-vec ,(%constant-alloc type-typed-object - (fx+ (constant header-size-stencil-vector) - (fx* (length e-val*) (constant ptr-bytes))))]) - ,(let loop ([e-val* e-val*] [i 0]) - (if (null? e-val*) - `(seq - (set! ,(%mref ,t-vec ,(constant stencil-vector-type-disp)) - ,(build-stencil-vector-type e-mask)) - ,t-vec) - `(seq - (set! ,(%mref ,t-vec ,(fx+ i (constant stencil-vector-data-disp))) ,(car e-val*)) - ,(loop (cdr e-val*) (fx+ i (constant ptr-bytes)))))))))))) - (define do-make-stencil-vector - (lambda (e-length e-mask) - (bind #t (e-length) - (bind #f (e-mask) - (let ([t-vec (make-tmp 'tvec)]) - `(let ([,t-vec (alloc ,(make-info-alloc (constant type-typed-object) #f #f) - ,(%inline logand - ,(%inline + ,e-length - (immediate ,(fx+ (constant header-size-stencil-vector) - (fx- (constant byte-alignment) 1)))) - (immediate ,(- (constant byte-alignment)))))]) - ,(%seq - (set! ,(%mref ,t-vec ,(constant stencil-vector-type-disp)) - ,(build-stencil-vector-type e-mask)) - ;; Content not filled! This function is meant to be called by - ;; `$stencil-vector-update`, which has GC disabled between - ;; allocation and filling in the data - ,t-vec))))))) - (define-inline 3 stencil-vector - [(e-mask . e-val*) - (do-stencil-vector e-mask e-val*)]) - (define-inline 2 $make-stencil-vector - [(e-length e-mask) (do-make-stencil-vector e-length e-mask)]) - (define-inline 3 $make-stencil-vector - [(e-length e-mask) (do-make-stencil-vector e-length e-mask)]) - (define-inline 3 stencil-vector-update - [(e-vec e-sub-mask e-add-mask . e-val*) - `(call ,(make-info-call src sexpr #f #f #f) #f - ,(lookup-primref 3 '$stencil-vector-update) - ,e-vec ,e-sub-mask ,e-add-mask ,e-val* ...)]) - (define-inline 3 stencil-vector-truncate! - [(e-vec e-mask) - (bind #f (e-vec e-mask) - `(seq - (set! ,(%mref ,e-vec ,(constant stencil-vector-type-disp)) - ,(build-stencil-vector-type e-mask)) - ,(%constant svoid)))]))) - (let () - (meta-assert (= (constant log2-ptr-bytes) (constant fixnum-offset))) - (define-inline 3 $make-eqhash-vector - [(e-length) - (let ([t-vec (make-tmp 'tvec)] - [t-idx (make-assigned-tmp 't-idx)] - [Ltop (make-local-label 'Ltop)]) - `(let ([,t-idx ,e-length]) - (if ,(%inline eq? ,t-idx (immediate 0)) - (quote ,(vector)) - (let ([,t-vec (alloc ,(make-info-alloc (constant type-typed-object) #f #f) - ,(%inline logand - ,(%inline + ,t-idx - (immediate ,(fx+ (constant header-size-vector) - (fx- (constant byte-alignment) 1)))) - (immediate ,(- (constant byte-alignment)))))]) - (seq - (set! ,(%mref ,t-vec ,(constant vector-type-disp)) - ,(build-type/length t-idx - (constant type-vector) - (constant fixnum-offset) - (constant vector-length-offset))) - (label ,Ltop - ,(%seq - (set! ,t-idx ,(%inline - ,t-idx (immediate ,(fix 1)))) - (set! ,(%mref ,t-vec ,t-idx ,(constant vector-data-disp)) ,t-idx) - (if ,(%inline eq? ,t-idx (immediate 0)) - ,t-vec - (goto ,Ltop)))))))))])) - - (let () - (define build-continuation?-test - (lambda (e) ; e must be bound - (build-and - (%type-check mask-closure type-closure ,e) - (%type-check mask-continuation-code type-continuation-code - ,(%mref - ,(%inline - - ,(%mref ,e ,(constant closure-code-disp)) - ,(%constant code-data-disp)) - ,(constant code-type-disp)))))) - (define-inline 2 $continuation? - [(e) (bind #t (e) - (build-continuation?-test e))]) - (define-inline 2 $assert-continuation - [(e) (bind #t (e) - `(if ,(build-and - (build-continuation?-test e) - (%inline eq? ,(%mref ,e ,(constant continuation-winders-disp)) ,(%tc-ref winders))) - ,(%constant svoid) - ,(build-libcall #t src sexpr $check-continuation e (%constant sfalse) (%constant sfalse))))] - [(e1 e2) (bind #t (e1 e2) - `(if ,(build-and - (build-continuation?-test e1) - (build-and - (%inline eq? ,(%mref ,e1 ,(constant continuation-winders-disp)) ,(%tc-ref winders)) - (build-simple-or - (%inline eq? ,e2 ,(%mref ,e1 ,(constant continuation-attachments-disp))) - (build-and - (%type-check mask-pair type-pair ,e2) - (%inline eq? ,(%mref ,e2 ,(constant pair-cdr-disp)) ,(%mref ,e1 ,(constant continuation-attachments-disp))))))) - ,(%constant svoid) - ,(build-libcall #t src sexpr $check-continuation e1 (%constant strue) e2)))]) - (define-inline 3 $assert-continuation - [(e) (bind #t (e) - `(if ,(%inline eq? ,(%mref ,e ,(constant continuation-winders-disp)) ,(%tc-ref winders)) - ,(%constant svoid) - ,(build-libcall #t src sexpr $check-continuation e (%constant sfalse) (%constant sfalse))))] - [(e1 e2) #f])) - - (define-inline 3 $continuation-stack-length - [(e) - (translate (%mref ,e ,(constant continuation-stack-length-disp)) - (constant fixnum-offset) - (constant log2-ptr-bytes))]) - (define-inline 3 $continuation-stack-clength - [(e) - (translate (%mref ,e ,(constant continuation-stack-clength-disp)) - (constant fixnum-offset) - (constant log2-ptr-bytes))]) - (let () - (define (build-ra e) - (%mref ,e ,(constant continuation-return-address-disp))) - (define (build-stack-ra e-k e-i) - (%mref ,(%mref ,e-k ,(constant continuation-stack-disp)) - ,(translate e-i (constant fixnum-offset) (constant log2-ptr-bytes)) - 0)) - - (define build-return-code - (lambda (e-ra) - (bind #t ([ra e-ra]) - (bind #t ([t `(if ,(%inline logtest ,(%mref ,ra ,(constant compact-return-address-mask+size+mode-disp)) - ,(%constant compact-header-mask)) - ,(%inline + ,ra ,(%constant compact-return-address-toplink-disp)) - ,(%inline + ,ra ,(%constant return-address-toplink-disp)))]) - (%inline - ,t ,(%mref ,t 0)))))) - (define build-return-offset - (lambda (e-ra) - (bind #t ([ra e-ra]) - (build-fix - `(if ,(%inline logtest ,(%mref ,ra ,(constant compact-return-address-mask+size+mode-disp)) - ,(%constant compact-header-mask)) - ,(%inline - ,(%mref ,ra ,(constant compact-return-address-toplink-disp)) - ,(%constant compact-return-address-toplink-disp)) - ,(%inline - ,(%mref ,ra ,(constant return-address-toplink-disp)) - ,(%constant return-address-toplink-disp))))))) - (define build-return-livemask - (lambda (e-ra) - (bind #t ([ra e-ra]) - (bind #t ([mask+size+mode (%mref ,ra ,(constant compact-return-address-mask+size+mode-disp))]) - `(if ,(%inline logtest ,mask+size+mode ,(%constant compact-header-mask)) - ,(%inline sll ,(%inline srl ,mask+size+mode ,(%constant compact-frame-mask-offset)) - ,(%constant fixnum-offset)) - ,(%mref ,ra ,(constant return-address-livemask-disp))))))) - (define build-return-frame-words - (lambda (e-ra) - (bind #t ([ra e-ra]) - (bind #t ([mask+size+mode (%mref ,ra ,(constant compact-return-address-mask+size+mode-disp))]) - `(if ,(%inline logtest ,mask+size+mode ,(%constant compact-header-mask)) - ,(%inline sll ,(%inline logand ,(%inline srl ,mask+size+mode ,(%constant compact-frame-words-offset)) - ,(%constant compact-frame-words-mask)) - ,(%constant fixnum-offset)) - ,(%mref ,ra ,(constant return-address-frame-size-disp))))))) - - (define-inline 3 $continuation-return-code - [(e) (build-return-code (build-ra e))]) - (define-inline 3 $continuation-return-offset - [(e) (build-return-offset (build-ra e))]) - (define-inline 3 $continuation-return-livemask - [(e) (build-return-livemask (build-ra e))]) - (define-inline 3 $continuation-return-frame-words - [(e) (build-return-frame-words (build-ra e))]) - (define-inline 3 $continuation-stack-ref - [(e-k e-i) - (%mref - ,(%mref ,e-k ,(constant continuation-stack-disp)) - ,(translate e-i (constant fixnum-offset) (constant log2-ptr-bytes)) - 0)]) - (define-inline 3 $continuation-stack-return-code - [(e-k e-i) (build-return-code (build-stack-ra e-k e-i))]) - (define-inline 3 $continuation-stack-return-offset - [(e-k e-i) (build-return-offset (build-stack-ra e-k e-i))]) - (define-inline 3 $continuation-stack-return-frame-words - [(e-k e-i) (build-return-frame-words (build-stack-ra e-k e-i))])) - - (define-inline 2 $foreign-char? - [(e) - (bind #t (e) - (build-and - (%type-check mask-char type-char ,e) - (%inline < ,e (immediate ,(ptr->imm (integer->char #x100))))))]) - (define-inline 2 $foreign-wchar? - [(e) - (constant-case wchar-bits - [(16) - (bind #t (e) - (build-and - (%type-check mask-char type-char ,e) - (%inline < ,e (immediate ,(ptr->imm (integer->char #x10000))))))] - [(32) (%type-check mask-char type-char ,e)])]) - (define-inline 2 $integer-8? - [(e) - (unless (fx>= (constant fixnum-bits) 8) ($oops '$integer-8? "unexpected fixnum-bits")) - (bind #t (e) - (build-and - (%type-check mask-fixnum type-fixnum ,e) - (%inline u< - ,(%inline + ,e (immediate ,(fix #x80))) - (immediate ,(fix #x180)))))]) - (define-inline 2 $integer-16? - [(e) - (unless (fx>= (constant fixnum-bits) 16) ($oops '$integer-16? "unexpected fixnum-bits")) - (bind #t (e) - (build-and - (%type-check mask-fixnum type-fixnum ,e) - (%inline u< - ,(%inline + ,e (immediate ,(fix #x8000))) - (immediate ,(fix #x18000)))))]) - (define-inline 2 $integer-24? - [(e) - (unless (fx>= (constant fixnum-bits) 24) ($oops '$integer-24? "unexpected fixnum-bits")) - (bind #t (e) - (build-and - (%type-check mask-fixnum type-fixnum ,e) - (%inline u< - ,(%inline + ,e (immediate ,(fix #x800000))) - (immediate ,(fix #x1800000)))))]) - (define-inline 2 $integer-32? - [(e) - (bind #t (e) - (if (fx>= (constant fixnum-bits) 32) - (build-and - (%type-check mask-fixnum type-fixnum ,e) - (%inline u< - ,(%inline + ,e (immediate ,(fix #x80000000))) - (immediate ,(fix #x180000000)))) - (build-simple-or - (%type-check mask-fixnum type-fixnum ,e) - (build-and - (%type-check mask-typed-object type-typed-object ,e) - (bind #t ([t (%mref ,e ,(constant bignum-type-disp))]) - `(if ,(%type-check mask-signed-bignum type-positive-bignum ,t) - ,(build-libcall #f #f sexpr <= e `(quote #xffffffff)) - ,(build-and - (%type-check mask-signed-bignum type-negative-bignum ,t) - (build-libcall #f #f sexpr >= e `(quote #x-80000000)))))))))]) - (define-inline 2 $integer-40? - [(e) - (bind #t (e) - (if (fx>= (constant fixnum-bits) 32) - (build-and - (%type-check mask-fixnum type-fixnum ,e) - (%inline u< - ,(%inline + ,e (immediate ,(fix #x8000000000))) - (immediate ,(fix #x18000000000)))) - (build-simple-or - (%type-check mask-fixnum type-fixnum ,e) - (build-and - (%type-check mask-typed-object type-typed-object ,e) - (bind #t ([t (%mref ,e ,(constant bignum-type-disp))]) - `(if ,(%type-check mask-signed-bignum type-positive-bignum ,t) - ,(build-libcall #f #f sexpr <= e `(quote #xffffffffff)) - ,(build-and - (%type-check mask-signed-bignum type-negative-bignum ,t) - (build-libcall #f #f sexpr >= e `(quote #x-8000000000)))))))))]) - (define-inline 2 $integer-48? - [(e) - (bind #t (e) - (if (fx>= (constant fixnum-bits) 32) - (build-and - (%type-check mask-fixnum type-fixnum ,e) - (%inline u< - ,(%inline + ,e (immediate ,(fix #x800000000000))) - (immediate ,(fix #x1800000000000)))) - (build-simple-or - (%type-check mask-fixnum type-fixnum ,e) - (build-and - (%type-check mask-typed-object type-typed-object ,e) - (bind #t ([t (%mref ,e ,(constant bignum-type-disp))]) - `(if ,(%type-check mask-signed-bignum type-positive-bignum ,t) - ,(build-libcall #f #f sexpr <= e `(quote #xffffffffffff)) - ,(build-and - (%type-check mask-signed-bignum type-negative-bignum ,t) - (build-libcall #f #f sexpr >= e `(quote #x-800000000000)))))))))]) - (define-inline 2 $integer-56? - [(e) - (bind #t (e) - (if (fx>= (constant fixnum-bits) 32) - (build-and - (%type-check mask-fixnum type-fixnum ,e) - (%inline u< - ,(%inline + ,e (immediate ,(fix #x80000000000000))) - (immediate ,(fix #x180000000000000)))) - (build-simple-or - (%type-check mask-fixnum type-fixnum ,e) - (build-and - (%type-check mask-typed-object type-typed-object ,e) - (bind #t ([t (%mref ,e ,(constant bignum-type-disp))]) - `(if ,(%type-check mask-signed-bignum type-positive-bignum ,t) - ,(build-libcall #f #f sexpr <= e `(quote #xffffffffffffff)) - ,(build-and - (%type-check mask-signed-bignum type-negative-bignum ,t) - (build-libcall #f #f sexpr >= e `(quote #x-80000000000000)))))))))]) - (define-inline 2 $integer-64? - [(e) - (when (fx>= (constant fixnum-bits) 64) ($oops '$integer-64? "unexpected fixnum-bits")) - (bind #t (e) - (build-simple-or - (%type-check mask-fixnum type-fixnum ,e) - (build-and - (%type-check mask-typed-object type-typed-object ,e) - (bind #t ([t (%mref ,e ,(constant bignum-type-disp))]) - `(if ,(%type-check mask-signed-bignum type-positive-bignum ,t) - ,(build-libcall #f #f sexpr <= e `(quote #xffffffffffffffff)) - ,(build-and - (%type-check mask-signed-bignum type-negative-bignum ,t) - (build-libcall #f #f sexpr >= e `(quote #x-8000000000000000))))))))]) - (define-inline 3 char->integer - ; assumes types are set up so that fixnum tag will be right after the shift - [(e-char) (build-char->integer e-char)]) - (define-inline 2 char->integer - ; assumes types are set up so that fixnum tag will be right after the shift - [(e-char) - (bind #t (e-char) - `(if ,(%type-check mask-char type-char ,e-char) - ,(%inline srl ,e-char - (immediate ,(fx- (constant char-data-offset) (constant fixnum-offset)))) - ,(build-libcall #t src sexpr char->integer e-char)))]) - (define-inline 3 char- - ; assumes fixnum is zero - [(e1 e2) - (%inline srl - ,(%inline - ,e1 ,e2) - (immediate ,(fx- (constant char-data-offset) (constant fixnum-offset))))]) - (define-inline 3 integer->char - [(e-int) (build-integer->char e-int)]) - (define-inline 3 boolean=? - [(e1 e2) (%inline eq? ,e1 ,e2)] - [(e1 e2 . e*) (reduce-equality src sexpr moi e1 e2 e*)]) - (define-inline 3 symbol=? - [(e1 e2) (%inline eq? ,e1 ,e2)] - [(e1 e2 . e*) (reduce-equality src sexpr moi e1 e2 e*)]) - (let () - (define (go e flag) - (%inline logtest - ,(%mref ,e ,(constant record-type-flags-disp)) - (immediate ,(fix flag)))) - (define-inline 3 record-type-opaque? - [(e) (go e (constant rtd-opaque))]) - (define-inline 3 record-type-sealed? - [(e) (go e (constant rtd-sealed))]) - (define-inline 3 record-type-generative? - [(e) (go e (constant rtd-generative))])) - (let () - (define build-record? - (lambda (e) - (bind #t (e) - (build-and - (%type-check mask-typed-object type-typed-object ,e) - (bind #t ([t (%mref ,e ,(constant typed-object-type-disp))]) - (build-and - (%type-check mask-record type-record ,t) - (build-not - (%inline logtest - ,(%mref ,t ,(constant record-type-flags-disp)) - (immediate ,(fix (constant rtd-opaque))))))))))) - (define build-sealed-isa? - (lambda (e e-rtd) - (bind #t (e) - (bind #f (e-rtd) - (build-and - (%type-check mask-typed-object type-typed-object ,e) - (%inline eq? - ,(%mref ,e ,(constant typed-object-type-disp)) - ,e-rtd)))))) - (define build-unsealed-isa? - (lambda (e e-rtd) - (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) - `(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) - (if (constant? (lambda (x) - (and (record-type-descriptor? x) - (record-type-sealed? x))) - e-rtd) - (build-sealed-isa? e e-rtd) - (build-unsealed-isa? e e-rtd))]) - (define-inline 2 r6rs:record? - [(e) (build-record? e)]) - (define-inline 2 record? - [(e) (build-record? e)] - [(e e-rtd) - (nanopass-case (L7 Expr) e-rtd - [(quote ,d) - (and (record-type-descriptor? d) - (if (record-type-sealed? d) - (build-sealed-isa? e e-rtd) - (build-unsealed-isa? e e-rtd)))] - [else #f])]) - (define-inline 2 $sealed-record? - [(e e-rtd) (build-sealed-isa? e e-rtd)]) - (define-inline 3 $record-type-field-count - [(e) (%inline srl ,(%inline - ,(%mref ,e ,(constant record-type-size-disp)) - (immediate ,(fxsll (fx- (constant record-data-disp) (constant record-type-disp)) - (constant fixnum-offset)))) - ,(%constant log2-ptr-bytes))]) - (define-inline 2 eq-hashtable? - [(e) (let ([rtd (let () (include "hashtable-types.ss") (record-type-descriptor eq-ht))]) - (let ([e-rtd `(quote ,rtd)]) - (if (record-type-sealed? rtd) - (build-sealed-isa? e e-rtd) - (build-unsealed-isa? e e-rtd))))])) - (define-inline 2 gensym? - [(e) - (bind #t (e) - (build-and - (%type-check mask-symbol type-symbol ,e) - (bind #t ([t (%mref ,e ,(constant symbol-name-disp))]) - `(if ,t - ,(build-and (%type-check mask-pair type-pair ,t) - (build-and (%mref ,t ,(constant pair-cdr-disp)) - (%constant strue))) - ,(%constant strue)))))]) - (define-inline 2 uninterned-symbol? - [(e) - (bind #t (e) - (build-and - (%type-check mask-symbol type-symbol ,e) - (bind #t ([t (%mref ,e ,(constant symbol-name-disp))]) - (build-and (%type-check mask-pair type-pair ,t) - (build-not (%mref ,t ,(constant pair-cdr-disp)))))))]) - (let () - (define build-make-symbol - (lambda (e-name) - (bind #t ([t (%constant-alloc type-symbol (constant size-symbol))]) - (%seq - (set! ,(%mref ,t ,(constant symbol-name-disp)) ,e-name) - (set! ,(%mref ,t ,(constant symbol-value-disp)) ,(%constant sunbound)) - (set! ,(%mref ,t ,(constant symbol-pvalue-disp)) - (literal - ,(make-info-literal #f 'library - (lookup-libspec nonprocedure-code) - (constant code-data-disp)))) - (set! ,(%mref ,t ,(constant symbol-plist-disp)) ,(%constant snil)) - (set! ,(%mref ,t ,(constant symbol-splist-disp)) ,(%constant snil)) - (set! ,(%mref ,t ,(constant symbol-hash-disp)) ,(%constant sfalse)) - ,t)))) - (define (go e-pname) - (bind #t ([t (%constant-alloc type-pair (constant size-pair))]) - (%seq - (set! ,(%mref ,t ,(constant pair-cdr-disp)) ,e-pname) - (set! ,(%mref ,t ,(constant pair-car-disp)) ,(%constant sfalse)) - ,(build-make-symbol t)))) - (define-inline 3 $gensym - [() (build-make-symbol (%constant sfalse))] - [(e-pname) (bind #f (e-pname) (go e-pname))] - [(e-pname e-uname) #f]) - (define-inline 3 gensym - [() (build-make-symbol (%constant sfalse))] - [(e-pname) (and (constant? immutable-string? e-pname) (go e-pname))] - [(e-pname e-uname) #f]) - (define-inline 2 gensym - [() (build-make-symbol (%constant sfalse))] - [(e-pname) (and (constant? immutable-string? e-pname) (go e-pname))] - [(e-pname e-uname) #f])) - (define-inline 3 symbol->string - [(e-sym) - (bind #t (e-sym) - (bind #t ([e-name (%mref ,e-sym ,(constant symbol-name-disp))]) - `(if ,e-name - (if ,(%type-check mask-pair type-pair ,e-name) - ,(bind #t ([e-cdr (%mref ,e-name ,(constant pair-cdr-disp))]) - `(if ,e-cdr - ,e-cdr - ,(%mref ,e-name ,(constant pair-car-disp)))) - ,e-name) - ,(%primcall #f sexpr $gensym->pretty-name ,e-sym))))]) - (define-inline 3 $fxaddress - [(e) (%inline logand - ,(let ([n (- (log2 (constant typemod)) (constant fixnum-offset))]) - (if (> n 0) (%inline sra ,e (immediate ,n)) e)) - (immediate ,(- (constant fixnum-factor))))]) - (define-inline 3 $set-timer - [(e) (bind #f (e) - (bind #t ([t (build-fix (ref-reg %trap))]) - `(seq - (set! ,(ref-reg %trap) ,(build-unfix e)) - ,t)))]) - (define-inline 3 $get-timer - [() (build-fix (ref-reg %trap))]) - (define-inline 3 directory-separator? - [(e) (if-feature windows - (bind #t (e) - (build-simple-or - (%inline eq? ,e (immediate ,(ptr->imm #\/))) - (%inline eq? ,e (immediate ,(ptr->imm #\\))))) - (%inline eq? ,e (immediate ,(ptr->imm #\/))))]) - (let () - (define add-cdrs - (lambda (n e) - (if (fx= n 0) - e - (add-cdrs (fx- n 1) (%mref ,e ,(constant pair-cdr-disp)))))) - (define-inline 3 list-ref - [(e-ls e-n) - (nanopass-case (L7 Expr) e-n - [(quote ,d) - (and (and (fixnum? d) (fx< d 4)) - (%mref ,(add-cdrs d e-ls) ,(constant pair-car-disp)))] - [else #f])]) - (define-inline 3 list-tail - [(e-ls e-n) - (nanopass-case (L7 Expr) e-n - [(quote ,d) (and (and (fixnum? d) (fx<= d 4)) (add-cdrs d e-ls))] - [else #f])])) - (let () - (define (go0 src sexpr subtype) - (%primcall src sexpr $make-eq-hashtable - (immediate ,(fix (constant hashtable-default-size))) - (immediate ,(fix subtype)))) - (define (go1 src sexpr e-size subtype) - (nanopass-case (L7 Expr) e-size - [(quote ,d) - ; d must be a fixnum? for $hashtable-size-minlen and a - ; target-machine fixnum for cross compiling - (and (and (fixnum? d) (target-fixnum? d) (fx>= d 0)) - (%primcall src sexpr $make-eq-hashtable - (immediate ,(fix ($hashtable-size->minlen d))) - (immediate ,(fix subtype))))] - [else #f])) - (define-inline 3 make-eq-hashtable - [() (go0 src sexpr (constant eq-hashtable-subtype-normal))] - [(e-size) (go1 src sexpr e-size (constant eq-hashtable-subtype-normal))]) - (define-inline 3 make-weak-eq-hashtable - [() (go0 src sexpr (constant eq-hashtable-subtype-weak))] - [(e-size) (go1 src sexpr e-size (constant eq-hashtable-subtype-weak))]) - (define-inline 3 make-ephemeron-eq-hashtable - [() (go0 src sexpr (constant eq-hashtable-subtype-ephemeron))] - [(e-size) (go1 src sexpr e-size (constant eq-hashtable-subtype-ephemeron))])) - (let () - (define-syntax def-put-x - (syntax-rules () - [(_ name x-length) - (define-inline 3 name - [(e-bop e-x) - (bind #t (e-x) - (build-libcall #f src sexpr name e-bop e-x `(immediate 0) - (handle-prim #f #f 3 'x-length (list e-x))))] - [(e-bop e-x e-start) - (bind #t (e-x e-start) - (build-libcall #f src sexpr name e-bop e-x e-start - (%inline - - ,(handle-prim #f #f 3 'x-length (list e-x)) - ,e-start)))] - [(e-bop e-x e-start e-count) - (build-libcall #f src sexpr name e-bop e-x e-start e-count)])])) - (def-put-x put-bytevector bytevector-length) - (def-put-x put-bytevector-some bytevector-length) - (def-put-x put-string string-length) - (def-put-x put-string-some string-length)) - - (define-inline 3 $read-time-stamp-counter - [() - (constant-case architecture - [(x86) - (%seq - ; returns low-order 32 bits in eax, high-order in edx - (set! ,%eax (inline ,(make-info-kill* (reg-list %edx)) ,%read-time-stamp-counter)) - ,(u32xu32->ptr %edx %eax))] - [(x86_64) - (%seq - ; returns low-order 32 bits in rax, high-order in rdx - (set! ,%rax (inline ,(make-info-kill* (reg-list %rdx)) ,%read-time-stamp-counter)) - ,(unsigned->ptr - (%inline logor ,(%inline sll ,%rdx (immediate 32)) ,%rax) - 64))] - [(arm32 pb) (unsigned->ptr (%inline read-time-stamp-counter) 32)] - [(arm64) (unsigned->ptr (%inline read-time-stamp-counter) 64)] - [(ppc32) - (let ([t-hi (make-tmp 't-hi)]) - `(let ([,t-hi (inline ,(make-info-kill* (reg-list %real-zero)) - ,%read-time-stamp-counter)]) - ,(u32xu32->ptr t-hi %real-zero)))])]) - - (define-inline 3 $read-performance-monitoring-counter - [(e) - (constant-case architecture - [(x86) - (%seq - (set! ,%eax (inline ,(make-info-kill* (reg-list %edx)) ,%read-performance-monitoring-counter ,(build-unfix e))) - ,(u32xu32->ptr %edx %eax))] - [(x86_64) - (%seq - (set! ,%rax (inline ,(make-info-kill* (reg-list %rdx)) ,%read-performance-monitoring-counter ,(build-unfix e))) - ,(unsigned->ptr - (%inline logor ,(%inline sll ,%rdx (immediate 32)) ,%rax) - 64))] - [(arm32 ppc32 pb) (unsigned->ptr (%inline read-performance-monitoring-counter ,(build-unfix e)) 32)] - [(arm64) (unsigned->ptr (%inline read-performance-monitoring-counter ,(build-unfix e)) 64)])]) - - )) ; expand-primitives module - (define-pass np-place-overflow-and-trap : L9 (ir) -> L9.5 () (definitions (define repeat? #f) @@ -12459,17 +4017,27 @@ ;; Save and restore any live registers that may be used by the `reify-1cc` instrinsic. ;; Since we can't use temporaries at this point --- %sfp is already moved --- manually ;; allocate a few registers (that may not be real registers) and hope that we - ;; have enough. + ;; have enough. On a platform that may need an extra register, define `%save1`. (let* ([reify-cc-modify-reg* (intrinsic-modify-reg* reify-1cc)] - [tmp-reg* (reg-list %ac1 %yp)] + [tmp-reg* (reg-list %ac1 %yp %save1)] + [ref-tmpreg* (with-output-language (L13 Lvalue) + ;; Does not have to be in the same order as `tmp-reg*`, + ;; but everything here must be in `tmp-reg*` + (list (ref-reg %ac1) (ref-reg %yp) (ref-reg %save1)))] [save-reg* (fold-left (lambda (reg* r) (cond [(memq r reg*) reg*] [(memq r reify-cc-modify-reg*) (cons r reg*)] [(memq r tmp-reg*) - ($oops who "reify-cc-save live register conflicts ~s" reg*)] + ($oops who "reify-cc-save live register conflicts ~s ~s" r tmp-reg*)] [else reg*])) '() live-reg*)]) + (define (ref-tmp-reg i) + (let loop ([i i] [ref-tmpreg* ref-tmpreg*]) + (cond + [(null? ref-tmpreg*) ($oops who "reify-cc-save too many live registers ~s" save-reg*)] + [(fx= i 0) (car ref-tmpreg*)] + [else (loop (fx- i 1) (cdr ref-tmpreg*))]))) (safe-assert (andmap (lambda (tmp-reg) (not (memq tmp-reg reify-cc-modify-reg*))) tmp-reg*)) (with-output-language (L13 Effect) (let loop ([save-reg* save-reg*] [i 0]) @@ -12477,14 +4045,9 @@ [(null? save-reg*) (with-saved-ret-reg e)] [else (%seq - ,(case i - [(0) `(set! ,(ref-reg %ac1) ,(car save-reg*))] - [(1) `(set! ,(ref-reg %yp) ,(car save-reg*))] - [else ($oops who "reify-cc-save too many live reigsters ~s" save-reg*)]) + (set! ,(ref-tmp-reg i) ,(car save-reg*)) ,(loop (cdr save-reg*) (fx+ i 1)) - ,(case i - [(0) `(set! ,(car save-reg*) ,(ref-reg %ac1))] - [(1) `(set! ,(car save-reg*) ,(ref-reg %yp))]))])))))) + (set! ,(car save-reg*) ,(ref-tmp-reg i)))])))))) (define build-call (with-output-language (L13 Tail) (case-lambda @@ -13749,7 +5312,7 @@ (if ,(%inline eq? ,%sfp ,(%constant snil)) ,(%seq (set! ,%ac0 ,%xp) - (set! ,%xp ,(%constant-alloc typemod (constant default-stack-size))) + (set! ,%xp ,(%constant-alloc type-untyped (constant default-stack-size))) (set! ,%sfp ,%xp) (set! ,(%tc-ref scheme-stack) ,%sfp) (set! ,(%tc-ref scheme-stack-size) ,(%constant default-stack-size)) @@ -16910,6 +8473,7 @@ (define-threaded max-fv) (define-threaded max-fs@call) (define-threaded poison-cset) + (define-threaded current-reg-spillinfo) (define no-live* empty-tree) @@ -16923,18 +8487,18 @@ (tree-same? live1 live2))) (define live? - (lambda (live* live-size x) - (tree-bit-set? live* live-size (var-index x)))) + (lambda (live* live-size x reg-spillinfo) + (tree-bit-set? live* live-size (var-index x reg-spillinfo)))) (define get-live-vars (lambda (live* live-size v) (tree-extract live* live-size v))) (define make-add-var - (lambda (live-size) + (lambda (live-size reg-spillinfo) ; add x to live*. result is eq? to live* if x is already in live*. (lambda (live* x) - (let ([index (var-index x)]) + (let ([index (var-index x reg-spillinfo)]) (if index (let ([new (tree-bit-set live* live-size index)]) (safe-assert (or (eq? new live*) (not (tree-same? new live*)))) @@ -16943,11 +8507,11 @@ (define make-remove-var ; remove x from live*. result is eq? to live* if x is not in live*. - (lambda (live-size) + (lambda (live-size reg-spillinfo) (lambda (live* x) - (let ([index (var-index x)]) + (let ([index (var-index x reg-spillinfo)]) (if index - (let ([new (tree-bit-unset live* live-size (var-index x))]) + (let ([new (tree-bit-unset live* live-size (var-index x reg-spillinfo))]) (safe-assert (or (eq? new live*) (not (tree-same? new live*)))) new) live*))))) @@ -17017,9 +8581,9 @@ [(1) #t]))) (define do-live-analysis! - (lambda (live-size entry-block*) - (define add-var (make-add-var live-size)) - (define remove-var (make-remove-var live-size)) + (lambda (live-size entry-block* reg-spillinfo) + (define add-var (make-add-var live-size reg-spillinfo)) + (define remove-var (make-remove-var live-size reg-spillinfo)) (define-who scan-block ; if we maintain a list of kills and a list of useless variables for ; each block, and we discover on entry to scan-block that the useless @@ -17075,7 +8639,7 @@ (lambda (out instr) (nanopass-case (L15a Effect) instr [(set! ,live-info ,x ,rhs) - (if (var-index x) + (if (var-index x reg-spillinfo) (let ([new-out (remove-var out x)]) (if (and (eq? new-out out) (nanopass-case (L15a Rhs) rhs @@ -17325,11 +8889,11 @@ (refine (fxsrl skip 1) skip))))))) (define-who do-spillable-conflict! - (lambda (kspillable kfv varvec live-size block*) - (define remove-var (make-remove-var live-size)) + (lambda (kspillable reg-spillinfo kfv varvec live-size block*) + (define remove-var (make-remove-var live-size reg-spillinfo)) (define add-move! (lambda (x1 x2) - (when (var-index x2) + (when (var-index x2 reg-spillinfo) ($add-move! x1 x2 2) ($add-move! x2 x1 2)))) (define add-conflict! @@ -17337,14 +8901,14 @@ ; invariants: ; all poison spillables explicitly point to all spillables ; all non-poison spillables implicitly point to all poison spillables via poison-cset - (let ([x-offset (var-index x)]) + (let ([x-offset (var-index x reg-spillinfo)]) (when x-offset (if (and (fx< x-offset kspillable) (uvar-poison? x)) (tree-for-each out live-size kspillable (fx+ kspillable kfv) (lambda (y-offset) ; frame y -> poison spillable x - (conflict-bit-set! (var-spillable-conflict* (vector-ref varvec y-offset)) x-offset))) - (let ([cset (var-spillable-conflict* x)]) + (conflict-bit-set! (var-spillable-conflict* (vector-ref varvec y-offset) reg-spillinfo) x-offset))) + (let ([cset (var-spillable-conflict* x reg-spillinfo)]) (if (fx< x-offset kspillable) (begin (tree-for-each out live-size 0 kspillable @@ -17354,12 +8918,12 @@ ; non-poison spillable x -> non-poison spillable y (conflict-bit-set! cset y-offset) ; and vice versa - (conflict-bit-set! (var-spillable-conflict* y) x-offset))))) + (conflict-bit-set! (var-spillable-conflict* y reg-spillinfo) x-offset))))) (tree-for-each out live-size kspillable live-size (lambda (y-offset) (let ([y (vector-ref varvec y-offset)]) ; frame or register y -> non-poison spillable x - (conflict-bit-set! (var-spillable-conflict* y) x-offset))))) + (conflict-bit-set! (var-spillable-conflict* y reg-spillinfo) x-offset))))) (if (fx< x-offset (fx+ kspillable kfv)) (tree-for-each out live-size 0 kspillable (lambda (y-offset) @@ -17384,8 +8948,8 @@ (if (live-info-useless live-info) new-effect* (let ([live (live-info-live live-info)]) - (when (var-index x) - (if (and (var? rhs) (var-index rhs)) + (when (var-index x reg-spillinfo) + (if (and (var? rhs) (var-index rhs reg-spillinfo)) (begin (add-conflict! x (remove-var live rhs)) (add-move! x rhs)) @@ -17407,11 +8971,11 @@ (conflict-bit-set! poison-cset i) ; leaving each poison spillable in conflict with itself, but this shouldn't matter ; since we never ask for the degree of a poison spillable - (var-spillable-conflict*-set! x (make-full-cset kspillable))) - (var-spillable-conflict*-set! x (make-empty-cset kspillable))))) + (var-spillable-conflict*-set! x reg-spillinfo (make-full-cset kspillable))) + (var-spillable-conflict*-set! x reg-spillinfo (make-empty-cset kspillable))))) (do ([i kspillable (fx+ i 1)]) ((fx= i live-size)) - (var-spillable-conflict*-set! (vector-ref varvec i) (make-empty-cset kspillable))) + (var-spillable-conflict*-set! (vector-ref varvec i) reg-spillinfo (make-empty-cset kspillable))) (for-each (lambda (block) (block-effect*-set! block @@ -17419,15 +8983,15 @@ block*))) (define-who show-conflicts - (lambda (name varvec unvarvec) + (lambda (name varvec unvarvec reg-spillinfo) (define any? #f) (printf "\n~s conflicts:" name) (for-each (lambda (x) (let ([ls (append - (let ([cset (var-spillable-conflict* x)]) + (let ([cset (var-spillable-conflict* x reg-spillinfo)]) (if cset (extract-conflicts cset varvec) '())) - (let ([cset (var-unspillable-conflict* x)]) + (let ([cset (var-unspillable-conflict* x reg-spillinfo)]) (if cset (extract-conflicts cset unvarvec) '())))]) (unless (null? ls) (set! any? #t) (printf "\n~s:~{ ~s~}" x ls)))) (append spillable* unspillable* (vector->list regvec) (map get-fv (iota (fx+ max-fv 1))))) @@ -17436,19 +9000,19 @@ (module (assign-frame! assign-new-frame!) (define update-conflict! - (lambda (fv spill) - (let ([cset1 (var-spillable-conflict* fv)] - [cset2 (var-spillable-conflict* spill)]) + (lambda (fv spill reg-spillinfo) + (let ([cset1 (var-spillable-conflict* fv reg-spillinfo)] + [cset2 (var-spillable-conflict* spill reg-spillinfo)]) (if cset1 (cset-merge! cset1 cset2) ; tempting to set to cset2 rather than (cset-copy cset2), but this would not be ; correct for local saves, which need their unaltered sets for later, and copying ; is cheap anyway. - (var-spillable-conflict*-set! fv (cset-copy cset2)))) - (unless (uvar-poison? spill) (cset-merge! (var-spillable-conflict* fv) poison-cset)))) + (var-spillable-conflict*-set! fv reg-spillinfo (cset-copy cset2)))) + (unless (uvar-poison? spill) (cset-merge! (var-spillable-conflict* fv reg-spillinfo) poison-cset)))) (define assign-frame! - (lambda (spill*) + (lambda (spill* reg-spillinfo) (define sort-spill* ; NB: sorts based on likelihood of successfully assigning move-related vars to the same location ; NB: probably should sort based on value of assigning move-related vars to the same location, @@ -17472,8 +9036,8 @@ (lambda (x0 succ fail) (define conflict-fv? (lambda (x fv) - (let ([cset (var-spillable-conflict* fv)]) - (and cset (conflict-bit-set? cset (var-index x)))))) + (let ([cset (var-spillable-conflict* fv reg-spillinfo)]) + (and cset (conflict-bit-set? cset (var-index x reg-spillinfo)))))) (let f ([x x0] [work* '()] [clear-seen! void]) (if (uvar-seen? x) (if (null? work*) (begin (clear-seen!) (fail)) (f (car work*) (cdr work*) clear-seen!)) @@ -17504,7 +9068,7 @@ (lambda (home max-fv first-open) (safe-assert (compatible-fv? home (uvar-type spill))) (uvar-location-set! spill home) - (update-conflict! home spill) + (update-conflict! home spill reg-spillinfo) (let ([max-fv (constant-case ptr-bits [(32) @@ -17521,14 +9085,14 @@ (lambda (home) (return home max-fv first-open)) (lambda () (let f ([first-open first-open]) - (let* ([fv (get-fv first-open (uvar-type spill))] [cset (var-spillable-conflict* fv)]) + (let* ([fv (get-fv first-open (uvar-type spill))] [cset (var-spillable-conflict* fv reg-spillinfo)]) (if (and cset (cset-full? cset)) (f (fx+ first-open 1)) - (let ([spill-offset (var-index spill)]) + (let ([spill-offset (var-index spill reg-spillinfo)]) (let f ([fv-offset first-open] [fv fv] [cset cset]) (if (or (and cset (conflict-bit-set? cset spill-offset)) (not (compatible-fv? fv (uvar-type spill)))) - (let* ([fv-offset (fx+ fv-offset 1)] [fv (get-fv fv-offset (uvar-type spill))] [cset (var-spillable-conflict* fv)]) + (let* ([fv-offset (fx+ fv-offset 1)] [fv (get-fv fv-offset (uvar-type spill))] [cset (var-spillable-conflict* fv reg-spillinfo)]) (f fv-offset fv cset)) (return fv (fxmax fv-offset max-fv) first-open))))))))))) (define find-homes! @@ -17543,9 +9107,9 @@ ; live across only a few (only when setup-nfv?) (set! max-fv (find-homes! (sort-spill* spill*) max-fv 1)))) - (define-pass assign-new-frame! : (L15a Dummy) (ir lambda-info live-size varvec block*) -> (L15b Dummy) () + (define-pass assign-new-frame! : (L15a Dummy) (ir lambda-info live-size varvec reg-spillinfo block*) -> (L15b Dummy) () (definitions - (define remove-var (make-remove-var live-size)) + (define remove-var (make-remove-var live-size reg-spillinfo)) (define find-max-fv (lambda (call-live*) (fold-left @@ -17559,8 +9123,8 @@ (and (or (not (car nfv*)) (let ([fv (get-fv offset)]) (and (compatible-fv? fv 'ptr) - (let ([cset (var-spillable-conflict* fv)]) - (not (and cset (conflict-bit-set? cset (var-index (car nfv*))))))))) + (let ([cset (var-spillable-conflict* fv reg-spillinfo)]) + (not (and cset (conflict-bit-set? cset (var-index (car nfv*) reg-spillinfo)))))))) (loop (cdr nfv*) (fx+ offset 1))))))) (define assign-new-frame! (lambda (cnfv* nfv** call-live*) @@ -17571,7 +9135,7 @@ (let* ([nfv (car nfv*)] [home (get-fv offset (uvar-type nfv))]) (safe-assert (compatible-fv? home (uvar-type nfv))) (uvar-location-set! nfv home) - (update-conflict! home nfv) + (update-conflict! home nfv reg-spillinfo) (set-offsets! (cdr nfv*) (fx+ offset 1)))))) (let ([arg-offset (fx+ (length cnfv*) 1)]) ; +1 for return address slot (let loop ([base (fx+ (find-max-fv call-live*) 1)]) @@ -17683,7 +9247,7 @@ [(restore-local-saves ,live-info ,info) (with-output-language (L15b Effect) (let ([live (live-info-live live-info)]) - (let loop ([x* (filter (lambda (x) (live? live live-size x)) (info-newframe-local-save* info))] + (let loop ([x* (filter (lambda (x) (live? live live-size x reg-spillinfo)) (info-newframe-local-save* info))] [live live] [new-effect* new-effect*]) (if (null? x*) @@ -17729,7 +9293,8 @@ [(newframe-block? block) (let ([info (newframe-block-info block)]) (process-info-newframe! info) - (safe-assert (andmap (lambda (x) (live? (newframe-block-live-call block) live-size x)) (info-newframe-local-save* info))) + (safe-assert (andmap (lambda (x) (live? (newframe-block-live-call block) live-size x reg-spillinfo)) + (info-newframe-local-save* info))) (with-output-language (L15b Effect) (let ([live (newframe-block-live-out block)]) (fold-left @@ -17852,7 +9417,8 @@ (define make-restricted-unspillable (lambda (x reg*) (import (only np-languages make-restricted-unspillable)) - (safe-assert (andmap reg? reg*) (andmap var-index reg*)) + (safe-assert (andmap reg? reg*) + (andmap (lambda (r) (var-index r current-reg-spillinfo)) reg*)) (let ([tmp (make-restricted-unspillable x reg*)]) (set! unspillable* (cons tmp unspillable*)) tmp))) @@ -17862,11 +9428,12 @@ ; for correct code but causes a spilled unspillable error if we try to use the same ; machine register for two conflicting variables (lambda (name reg) - (or (reg-precolored reg) - (let ([tmp (make-restricted-unspillable name (remq reg (vector->list regvec)))]) - (safe-assert (memq reg (vector->list regvec))) - (reg-precolored-set! reg tmp) - tmp)))) + (let ([reg-spillinfo current-reg-spillinfo]) + (or (reg-precolored reg reg-spillinfo) + (let ([tmp (make-restricted-unspillable name (remq reg (vector->list regvec)))]) + (safe-assert (memq reg (vector->list regvec))) + (reg-precolored-set! reg reg-spillinfo tmp) + tmp))))) (define-syntax build-set! (lambda (x) @@ -18174,10 +9741,10 @@ [(k context (sym ...) cl ...) #'(k context (sym ...) (definitions) cl ...)] [(k context sym cl ...) (identifier? #'sym) #'(k context (sym) (definitions) cl ...)]))) - (define-pass select-instructions! : (L15c Dummy) (ir block* live-size force-overflow?) -> (L15d Dummy) () + (define-pass select-instructions! : (L15c Dummy) (ir block* live-size reg-spillinfo force-overflow?) -> (L15d Dummy) () (definitions (module (handle-jump handle-effect-inline handle-pred-inline handle-value-inline) - (define add-var (make-add-var live-size)) + (define add-var (make-add-var live-size reg-spillinfo)) (define Triv (lambda (out t) (nanopass-case (L15d Triv) t @@ -18364,8 +9931,8 @@ ) (define-who do-unspillable-conflict! - (lambda (kfv kspillable varvec live-size kunspillable unvarvec block*) - (define remove-var (make-remove-var live-size)) + (lambda (kfv kspillable reg-spillinfo varvec live-size kunspillable unvarvec block*) + (define remove-var (make-remove-var live-size reg-spillinfo)) (define unspillable? (lambda (x) (and (uvar? x) (uvar-unspillable? x)))) @@ -18378,26 +9945,26 @@ unspillable*))) (define add-move! (lambda (x1 x2) - (when (var-index x2) + (when (var-index x2 reg-spillinfo) ($add-move! x1 x2 2) ($add-move! x2 x1 2)))) (define add-move-hint! (lambda (x1 x2) - (when (var-index x2) + (when (var-index x2 reg-spillinfo) ($add-move! x1 x2 1) ($add-move! x2 x1 1)))) (define add-static-conflict! (lambda (u reg*) - (let ([u-offset (var-index u)]) + (let ([u-offset (var-index u reg-spillinfo)]) (for-each - (lambda (reg) (conflict-bit-set! (var-unspillable-conflict* reg) u-offset)) + (lambda (reg) (conflict-bit-set! (var-unspillable-conflict* reg reg-spillinfo) u-offset)) reg*)))) (define add-us->s-conflicts! (lambda (x out) ; x is an unspillable - (let ([x-offset (var-index x)] [cset (var-spillable-conflict* x)]) + (let ([x-offset (var-index x reg-spillinfo)] [cset (var-spillable-conflict* x reg-spillinfo)]) (tree-for-each out live-size 0 live-size (lambda (y-offset) - (let* ([y (vector-ref varvec y-offset)] [y-cset (var-unspillable-conflict* y)]) + (let* ([y (vector-ref varvec y-offset)] [y-cset (var-unspillable-conflict* y reg-spillinfo)]) (when y-cset ; if y is a spillable, point the unspillable x at y (when (fx< y-offset kspillable) (conflict-bit-set! cset y-offset)) @@ -18405,23 +9972,23 @@ (conflict-bit-set! y-cset x-offset)))))))) (define add-us->us-conflicts! (lambda (x unspillable*) ; x is a unspillable - (let ([x-offset (var-index x)] [cset (var-unspillable-conflict* x)]) + (let ([x-offset (var-index x reg-spillinfo)] [cset (var-unspillable-conflict* x reg-spillinfo)]) (for-each (lambda (y) - (let ([y-offset (var-index y)]) + (let ([y-offset (var-index y reg-spillinfo)]) (conflict-bit-set! cset y-offset) - (conflict-bit-set! (var-unspillable-conflict* y) x-offset))) + (conflict-bit-set! (var-unspillable-conflict* y reg-spillinfo) x-offset))) unspillable*)))) (define add-s->us-conflicts! (lambda (x unspillable*) ; x is a spillable or register - (let ([x-offset (var-index x)] [cset (var-unspillable-conflict* x)]) + (let ([x-offset (var-index x reg-spillinfo)] [cset (var-unspillable-conflict* x reg-spillinfo)]) (for-each (lambda (y) - (let ([y-offset (var-index y)]) + (let ([y-offset (var-index y reg-spillinfo)]) ; point x at unspillable y (conflict-bit-set! cset y-offset) ; if x is a spillable, point unspillable y at x - (when (fx< x-offset kspillable) (conflict-bit-set! (var-spillable-conflict* y) x-offset)))) + (when (fx< x-offset kspillable) (conflict-bit-set! (var-spillable-conflict* y reg-spillinfo) x-offset)))) unspillable*)))) (define Triv (lambda (unspillable* t) @@ -18458,7 +10025,7 @@ (let ([unspillable* (remq x unspillable*)]) (safe-assert (uvar-seen? x)) (uvar-seen! x #f) - (if (and (var? rhs) (var-index rhs)) + (if (and (var? rhs) (var-index rhs reg-spillinfo)) (begin (if (unspillable? rhs) (begin @@ -18473,7 +10040,7 @@ (add-us->s-conflicts! x spillable-live))) (Rhs unspillable* rhs)) (begin - (when (var-unspillable-conflict* x) + (when (var-unspillable-conflict* x reg-spillinfo) (if (unspillable? rhs) (begin (add-s->us-conflicts! x (remq rhs unspillable*)) @@ -18485,8 +10052,8 @@ [(move-related ,x1 ,x2) (add-move-hint! x1 x2) unspillable*] [(overflow-check ,p ,e* ...) (Effect* (reverse e*) '()) (Pred p)] [else unspillable*]))))) - (for-each (lambda (x) (var-spillable-conflict*-set! x (make-empty-cset kspillable))) unspillable*) - (let ([f (lambda (x) (var-unspillable-conflict*-set! x (make-empty-cset kunspillable)))]) + (for-each (lambda (x) (var-spillable-conflict*-set! x reg-spillinfo (make-empty-cset kspillable))) unspillable*) + (let ([f (lambda (x) (var-unspillable-conflict*-set! x reg-spillinfo (make-empty-cset kunspillable)))]) (vector-for-each f regvec) (for-each f spillable*) (vector-for-each f unvarvec)) @@ -18502,7 +10069,7 @@ block*))) (define-who assign-registers! - (lambda (lambda-info varvec unvarvec) + (lambda (lambda-info varvec unvarvec reg-spillinfo) (define total-k (vector-length regvec)) (define fp-k (length extra-fpregisters)) (define ptr-k (- total-k fp-k)) @@ -18526,18 +10093,18 @@ (uvar-degree-set! x (fx+ ; spills have been trimmed from the var-spillable-conflict* sets - (conflict-bit-count (var-spillable-conflict* x)) - (conflict-bit-count (var-unspillable-conflict* x))))) + (conflict-bit-count (var-spillable-conflict* x reg-spillinfo)) + (conflict-bit-count (var-unspillable-conflict* x reg-spillinfo))))) x*) ; account for reg -> uvar conflicts (vector-for-each (lambda (reg) - (cset-for-each (var-spillable-conflict* reg) + (cset-for-each (var-spillable-conflict* reg reg-spillinfo) (lambda (x-offset) (let ([x (vector-ref varvec x-offset)]) (unless (uvar-location x) (uvar-degree-set! x (fx+ (uvar-degree x) 1)))))) - (cset-for-each (var-unspillable-conflict* reg) + (cset-for-each (var-unspillable-conflict* reg reg-spillinfo) (lambda (x-offset) (let ([x (vector-ref unvarvec x-offset)]) (uvar-degree-set! x (fx+ (uvar-degree x) 1)))))) @@ -18547,8 +10114,8 @@ (define conflict? (lambda (reg x) (or (not (compatible-var-types? (reg-type reg) (uvar-type x))) - (let ([cset (if (uvar-unspillable? x) (var-unspillable-conflict* reg) (var-spillable-conflict* reg))]) - (conflict-bit-set? cset (var-index x)))))) + (let ([cset (if (uvar-unspillable? x) (var-unspillable-conflict* reg reg-spillinfo) (var-spillable-conflict* reg reg-spillinfo))]) + (conflict-bit-set? cset (var-index x reg-spillinfo)))))) (define find-move-related-home (lambda (x0 succ fail) (let f ([x x0] [work* '()] [clear-seen! void]) @@ -18577,8 +10144,8 @@ (lambda (home) (define update-conflict! (lambda (reg x) - (cset-merge! (var-spillable-conflict* reg) (var-spillable-conflict* x)) - (cset-merge! (var-unspillable-conflict* reg) (var-unspillable-conflict* x)))) + (cset-merge! (var-spillable-conflict* reg reg-spillinfo) (var-spillable-conflict* x reg-spillinfo)) + (cset-merge! (var-unspillable-conflict* reg reg-spillinfo) (var-unspillable-conflict* x reg-spillinfo)))) (uvar-location-set! x home) (update-conflict! home x))) (find-move-related-home x @@ -18614,11 +10181,11 @@ (values x (remq x x*))))) (define remove-victim! (lambda (victim) - (cset-for-each (var-spillable-conflict* victim) + (cset-for-each (var-spillable-conflict* victim reg-spillinfo) (lambda (offset) (let ([x (vector-ref varvec offset)]) (uvar-degree-set! x (fx- (uvar-degree x) 1))))) - (cset-for-each (var-unspillable-conflict* victim) + (cset-for-each (var-unspillable-conflict* victim reg-spillinfo) (lambda (offset) (let ([x (vector-ref unvarvec offset)]) (uvar-degree-set! x (fx- (uvar-degree x) 1))))))) @@ -18875,16 +10442,17 @@ [(_ ?unparser pass-name ?arg ...) #'(xpass pass-name (RAprinter ?unparser) (list ?arg ...))])))) (safe-assert (andmap (lambda (x) (eq? (uvar-location x) #f)) local*)) - (let ([kspillable (length local*)] [kfv (fx+ max-fv0 1)] [kreg (vector-length regvec)]) - (fluid-let ([spillable* local*] [unspillable* '()] [max-fv max-fv0] [max-fs@call 0] [poison-cset (make-empty-cset kspillable)]) + (let ([kspillable (length local*)] [kfv (fx+ max-fv0 1)] [kreg (vector-length regvec)] [reg-spillinfo (make-reg-spillinfo)]) + (fluid-let ([spillable* local*] [unspillable* '()] [max-fv max-fv0] [max-fs@call 0] + [poison-cset (make-empty-cset kspillable)] [current-reg-spillinfo reg-spillinfo]) (let* ([live-size (fx+ kfv kreg kspillable)] [varvec (make-vector live-size)]) ; set up var indices & varvec mapping from indices to vars (fold-left (lambda (i x) (var-index-set! x i) (vector-set! varvec i x) (fx+ i 1)) 0 spillable*) (do ([i 0 (fx+ i 1)]) ((fx= i kfv)) (let ([fv (get-fv i)] [i (fx+ i kspillable)]) (var-index-set! fv i) (vector-set! varvec i fv))) - (do ([i 0 (fx+ i 1)]) ((fx= i kreg)) (let ([reg (vector-ref regvec i)] [i (fx+ i kspillable kfv)]) (var-index-set! reg i) (vector-set! varvec i reg))) + (do ([i 0 (fx+ i 1)]) ((fx= i kreg)) (let ([reg (vector-ref regvec i)] [i (fx+ i kspillable kfv)]) (var-index-set! reg reg-spillinfo i) (vector-set! varvec i reg))) (with-live-info-record-writer live-size varvec ; run intra/inter-block live analysis - (RApass unparse-L15a do-live-analysis! live-size entry-block*) + (RApass unparse-L15a do-live-analysis! live-size entry-block* reg-spillinfo) ; this is worth enabling from time to time... #;(check-entry-live! (info-lambda-name info) live-size varvec entry-block*) ; rerun intra-block live analysis and record (fv v reg v spillable) x spillable conflicts @@ -18892,64 +10460,64 @@ ;; NB: we could just use (vector-length varvec) to get live-size (when (fx> kspillable 1000) ; NB: parameter? (RApass unparse-L15a identify-poison! kspillable varvec live-size block*)) - (RApass unparse-L15a do-spillable-conflict! kspillable kfv varvec live-size block*) - #;(show-conflicts (info-lambda-name info) varvec '#()) + (RApass unparse-L15a do-spillable-conflict! kspillable reg-spillinfo kfv varvec live-size block*) + #;(show-conflicts (info-lambda-name info) varvec '#() reg-spillinfo) ; find frame homes for call-live variables; adds new fv x spillable conflicts - (RApass unparse-L15a assign-frame! (filter uvar-spilled? spillable*)) + (RApass unparse-L15a assign-frame! (filter uvar-spilled? spillable*) reg-spillinfo) #;(show-homes) (RApass unparse-L15a record-inspector-information! info) ; determine frame sizes at nontail-call sites and assign homes to new-frame variables ; adds new fv x spillable conflicts - (let ([dummy (RApass unparse-L15b assign-new-frame! (with-output-language (L15a Dummy) `(dummy)) info live-size varvec block*)]) + (let ([dummy (RApass unparse-L15b assign-new-frame! (with-output-language (L15a Dummy) `(dummy)) info live-size varvec reg-spillinfo block*)]) ; record fp offset on entry to each block (RApass unparse-L15b record-fp-offsets! entry-block*) ; assign frame homes to poison variables (let ([spill* (filter (lambda (x) (and (not (uvar-location x)) (uvar-poison? x))) spillable*)]) (unless (null? spill*) (for-each (lambda (x) (uvar-spilled! x #t)) spill*) - (RApass unparse-L15b assign-frame! spill*))) + (RApass unparse-L15b assign-frame! spill* reg-spillinfo))) ; on entry to loop, have assigned call-live and new-frame variables to frame homes, determined frame sizes, and computed block-entry fp offsets - (let ([saved-reg-csets (vector-map (lambda (reg) (cset-copy (var-spillable-conflict* reg))) regvec)] + (let ([saved-reg-csets (vector-map (lambda (reg) (cset-copy (var-spillable-conflict* reg reg-spillinfo))) regvec)] [bcache* (map cache-block-info block*)]) (let loop () (for-each (lambda (spill) ; remove each spill from each other spillable's spillable conflict set (unless (uvar-poison? spill) - (let ([spill-index (var-index spill)]) - (cset-for-each (var-spillable-conflict* spill) + (let ([spill-index (var-index spill reg-spillinfo)]) + (cset-for-each (var-spillable-conflict* spill reg-spillinfo) (lambda (i) (let ([x (vector-ref varvec i)]) (unless (uvar-location x) - (conflict-bit-unset! (var-spillable-conflict* x) spill-index))))))) + (conflict-bit-unset! (var-spillable-conflict* x reg-spillinfo) spill-index))))))) ; release the spill's conflict* set - (var-spillable-conflict*-set! spill #f)) + (var-spillable-conflict*-set! spill reg-spillinfo #f)) (filter uvar-location spillable*)) (set! spillable* (remp uvar-location spillable*)) (let ([saved-move* (map uvar-move* spillable*)]) #;(show-homes) (let ([dummy (RApass unparse-L15c finalize-frame-locations! dummy block*)]) - (let ([dummy (RApass unparse-L15d select-instructions! dummy block* live-size + (let ([dummy (RApass unparse-L15d select-instructions! dummy block* live-size reg-spillinfo (let ([libspec (info-lambda-libspec info)]) (and libspec (libspec-does-not-expect-headroom? libspec))))]) - (vector-for-each (lambda (reg) (reg-precolored-set! reg #f)) regvec) + (vector-for-each (lambda (reg) (reg-precolored-set! reg reg-spillinfo #f)) regvec) (let* ([kunspillable (length unspillable*)] [unvarvec (make-vector kunspillable)]) ; set up var indices & unvarvec mapping from indices to unspillables - (fold-left (lambda (i x) (var-index-set! x i) (vector-set! unvarvec i x) (fx+ i 1)) 0 unspillable*) + (fold-left (lambda (i x) (var-index-set! x reg-spillinfo i) (vector-set! unvarvec i x) (fx+ i 1)) 0 unspillable*) ; select-instrcutions! kept intra-block live analysis up-to-date, so now ; record (reg v spillable v unspillable) x unspillable conflicts - (RApass unparse-L15d do-unspillable-conflict! kfv kspillable varvec live-size kunspillable unvarvec block*) - #;(show-conflicts (info-lambda-name info) varvec unvarvec) - (RApass unparse-L15d assign-registers! info varvec unvarvec) + (RApass unparse-L15d do-unspillable-conflict! kfv kspillable reg-spillinfo varvec live-size kunspillable unvarvec block*) + #;(show-conflicts (info-lambda-name info) varvec unvarvec reg-spillinfo) + (RApass unparse-L15d assign-registers! info varvec unvarvec reg-spillinfo) ; release the unspillable conflict sets - (for-each (lambda (x) (var-unspillable-conflict*-set! x #f)) spillable*) - (vector-for-each (lambda (x) (var-unspillable-conflict*-set! x #f)) regvec) + (for-each (lambda (x) (var-unspillable-conflict*-set! x reg-spillinfo #f)) spillable*) + (vector-for-each (lambda (x) (var-unspillable-conflict*-set! x reg-spillinfo #f)) regvec) #;(show-homes unspillable*) (if (everybody-home?) (let ([dummy (RApass unparse-L15e finalize-register-locations! dummy block*)]) ; release the spillable conflict sets - (vector-for-each (lambda (reg) (var-spillable-conflict*-set! reg #f)) regvec) - (do ([i max-fv (fx- i 1)]) ((fx< i 0)) (var-spillable-conflict*-set! (get-fv i) #f)) + (vector-for-each (lambda (reg) (var-spillable-conflict*-set! reg reg-spillinfo #f)) regvec) + (do ([i max-fv (fx- i 1)]) ((fx< i 0)) (var-spillable-conflict*-set! (get-fv i) reg-spillinfo #f)) (let-values ([(dummy entry-block* block*) (xpass expose-overflow-check-blocks! (lambda (val*) @@ -18962,11 +10530,12 @@ `(lambda ,info (,entry-block* ...) (,block* ...)))) (begin (for-each restore-block-info! block* bcache*) - (vector-for-each var-spillable-conflict*-set! regvec saved-reg-csets) + (vector-for-each (lambda (r c*) (var-spillable-conflict*-set! r reg-spillinfo c*)) + regvec saved-reg-csets) (for-each (lambda (x) (uvar-location-set! x #f)) spillable*) (for-each uvar-move*-set! spillable* saved-move*) (set! unspillable* '()) - (RApass unparse-L15b assign-frame! (filter uvar-spilled? spillable*)) + (RApass unparse-L15b assign-frame! (filter uvar-spilled? spillable*) reg-spillinfo) (loop)))))))))))))))]))) ; NB: commonize with earlier @@ -19116,7 +10685,6 @@ (set! $np-compile (lambda (original-input-expression pt?) - (with-initialized-registers (fluid-let ([frame-vars (make-vector 8 #f)] [next-lambda-seqno 0] [pass-time? pass-time?]) @@ -19148,7 +10716,7 @@ ((pass np-profile-unroll-loops unparse-L7) ir))) (pass np-simplify-if unparse-L7) (pass np-unbox-fp-vars! unparse-L7) - (pass np-expand-primitives unparse-L9) + (pass $np-expand-primitives unparse-L9) (pass np-place-overflow-and-trap unparse-L9.5) (pass np-rebind-on-ruined-path unparse-L9.5) (pass np-finalize-loops unparse-L9.75) @@ -19159,11 +10727,10 @@ (pass np-flatten-case-lambda unparse-L12) (pass np-insert-trap-check unparse-L12.5) (pass np-impose-calling-conventions unparse-L13) - np-after-calling-conventions))))) + np-after-calling-conventions)))) (set! $np-boot-code (lambda (which) - (with-initialized-registers ($c-func-code-record (fluid-let ([frame-vars (make-vector 8 #f)] [next-lambda-seqno 0] @@ -19172,7 +10739,7 @@ (np-after-calling-conventions (with-output-language (L13 Program) (let ([l (make-local-label 'Linvoke)]) - `(labels ([,l (hand-coded ,which)]) ,l)))))))))) + `(labels ([,l (hand-coded ,which)]) ,l))))))))) ) (set! $np-tracer tracer) diff --git a/src/ChezScheme/s/cpprim.ss b/src/ChezScheme/s/cpprim.ss new file mode 100644 index 0000000000..adfc4d1cc4 --- /dev/null +++ b/src/ChezScheme/s/cpprim.ss @@ -0,0 +1,8002 @@ +;; The `$np-expand-primitives` pass is used only by "cpnanopass.ss". +;; This pass is in its own file just to break up the compiler itself +;; into smaller compilation units. + +(let () +(define-syntax define-once + (syntax-rules () + [(_ id rhs) (define-once id (id) rhs)] + [(_ id (name . _) rhs) (define id ($sgetprop 'name 'once #f))])) + +(include "np-languages.ss") +(import (nanopass) np-languages) + +(include "np-register.ss") +(include "np-info.ss") +(include "np-help.ss") + +;; -------------------------------------------------------------------------------- + +(define (known-flonum-result? e) + (let flonum-result? ([e e] [fuel 10]) + (and + (fx> fuel 0) + (nanopass-case (L7 Expr) e + [,x (and (uvar? x) (eq? (uvar-type x) 'fp))] + [(quote ,d) (flonum? d)] + [(call ,info ,mdcl ,pr ,e* ...) + (or (eq? 'flonum ($sgetprop (primref-name pr) '*result-type* #f)) + (and (eq? '$object-ref (primref-name pr)) + (pair? e*) + (nanopass-case (L7 Expr) (car e*) + [(quote ,d) (eq? d 'double)])))] + [(seq ,e0 ,e1) (flonum-result? e1 (fx- fuel 1))] + [(let ([,x* ,e*] ...) ,body) (flonum-result? body (fx- fuel 1))] + [(if ,e1 ,e2 ,e3) (and (flonum-result? e2 (fxsrl fuel 1)) + (flonum-result? e3 (fxsrl fuel 1)))] + [else #f])))) + +(define rtd-ancestors (csv7:record-field-accessor #!base-rtd 'ancestors)) + +;; After the `np-expand-primitives` pass, some expression produce +;; double (i.e., floating-point) values instead of pointer values. +;; Those expression results always flow to an `inline` primitive +;; that expects double values. The main consequence is that a later +;; pass must only put such returns in a temporary with type 'fp. + +; TODO: recognize a direct call when it is at the end of a sequence, closures, or let form +; TODO: push call into if? (would need to pull arguments into temporaries to ensure order of evaluation +; TODO: how does this interact with mvcall? +(module (np-expand-primitives) + (define-threaded new-l*) + (define-threaded new-le*) + (define ht2 (make-hashtable symbol-hash eq?)) + (define ht3 (make-hashtable symbol-hash eq?)) + (define handle-prim + (lambda (src sexpr level name e*) + (let ([handler (or (and (fx= level 3) (symbol-hashtable-ref ht3 name #f)) + (symbol-hashtable-ref ht2 name #f))]) + (and handler (handler src sexpr e*))))) + (define-syntax Symref + (lambda (x) + (syntax-case x () + [(k ?sym) + (with-implicit (k quasiquote) + #'`(literal ,(make-info-literal #t 'object ?sym (constant symbol-value-disp))))]))) + (define single-valued? + (case-lambda + [(e) (single-valued? e 5)] + [(e fuel) + (and (not (zero? fuel)) + (nanopass-case (L7 Expr) e + [,x #t] + [(immediate ,imm) #t] + [(literal ,info) #t] + [(label-ref ,l ,offset) #t] + [(mref ,e1 ,e2 ,imm ,type) #t] + [(quote ,d) #t] + [,pr #t] + [(call ,info ,mdcl ,pr ,e* ...) + (all-set? (prim-mask single-valued) (primref-flags pr))] + [(foreign-call ,info ,e, e* ...) #t] + [(alloc ,info ,e) #t] + [(set! ,lvalue ,e) #t] + [(profile ,src) #t] + [(pariah) #t] + [(let ([,x* ,e*] ...) ,body) + (single-valued? body (fx- fuel 1))] + [(if ,e0 ,e1 ,e2) + (and (single-valued? e1 (fx- fuel 1)) + (single-valued? e2 (fx- fuel 1)))] + [(seq ,e0 ,e1) + (single-valued? e1 (fx- fuel 1))] + [(unboxed-fp ,e) #t] + [else #f]))])) + (define ensure-single-valued + (case-lambda + [(e unsafe-omit?) + (if (or unsafe-omit? + (single-valued? e)) + e + (with-output-language (L7 Expr) + (let ([t (make-tmp 'v)]) + `(values ,(make-info-call #f #f #f #f #f) ,e))))] + [(e) (ensure-single-valued e (fx= (optimize-level) 3))])) + (define-pass np-expand-primitives : L7 (ir) -> L9 () + (definitions + (define Expr1 + (lambda (e) + (let-values ([(e unboxed-fp?) (Expr e #f)]) + e))) + (define Expr* + (lambda (e*) + (map Expr1 e*))) + (define unboxed-fp->boxed + (lambda (e) + (let ([t (make-tmp 't)]) + (with-output-language (L9 Expr) + `(let ([,t ,(%constant-alloc type-flonum (constant size-flonum))]) + (seq + (set! ,(%mref ,t ,%zero ,(constant flonum-data-disp) fp) ,e) + ,t)))))) + (define (fp-lvalue? lvalue) + (nanopass-case (L9 Lvalue) lvalue + [,x (and (uvar? x) (eq? (uvar-type x) 'fp))] + [(mref ,e1 ,e2 ,imm ,type) (eq? type 'fp)]))) + (Program : Program (ir) -> Program () + [(labels ([,l* ,le*] ...) ,l) + (fluid-let ([new-l* '()] [new-le* '()]) + (let ([le* (map CaseLambdaExpr le*)]) + `(labels ([,l* ,le*] ... [,new-l* ,new-le*] ...) ,l)))]) + (CaseLambdaExpr : CaseLambdaExpr (ir) -> CaseLambdaExpr ()) + (CaseLambdaClause : CaseLambdaClause (ir) -> CaseLambdaClause () + [(clause (,x* ...) ,mcp ,interface ,[body #f -> body unboxed-fp?]) + `(clause (,x* ...) ,mcp ,interface ,body)]) + ;; The result of `Expr` can be unboxed (second result is #t) only + ;; if the `can-unbox-fp?` argument is #t, but the result can always + ;; be a boxed expression (even if `can-unbox-fp?` is #t) + (Expr : Expr (ir [can-unbox-fp? #f]) -> Expr (#f) + [(quote ,d) + (values (cond + [(ptr->imm d) => (lambda (i) `(immediate ,i))] + [else `(literal ,(make-info-literal #f 'object d 0))]) + #f)] + [,pr (values (Symref (primref-name pr)) #f)] + [(unboxed-fp ,[e #t -> e unboxed-fp?]) + (if can-unbox-fp? + (values e #t) + (values (unboxed-fp->boxed e) #f))] + [(call ,info0 ,mdcl0 + (call ,info1 ,mdcl1 ,pr (quote ,d)) + ,[e* #f -> e* unboxed-fp?*] ...) + (guard (and (eq? (primref-name pr) '$top-level-value) (symbol? d))) + (values `(call ,info0 ,mdcl0 ,(Symref d) ,e* ...) #f)] + [(call ,info ,mdcl ,pr ,e* ...) + (cond + [(and + (or (not (info-call-shift-attachment? info)) + ;; Note: single-valued also implies that the primitive doesn't + ;; tail-call an arbitary function (which might inspect attachments): + (all-set? (prim-mask single-valued) (primref-flags pr))) + (handle-prim (info-call-src info) (info-call-sexpr info) (primref-level pr) (primref-name pr) e*)) + => (lambda (e) + (let-values ([(e unboxed-fp?) (Expr e can-unbox-fp?)]) + (values + (cond + [(info-call-shift-attachment? info) + (let ([t (make-tmp 't (if unboxed-fp? 'fp 'ptr))]) + `(let ([,t ,e]) + (seq + (attachment-set pop #f) + ,t)))] + [else e]) + unboxed-fp?)))] + [else + (let ([e* (Expr* e*)]) + ; NB: expand calls through symbol top-level values similarly + (let ([info (if (any-set? (prim-mask abort-op) (primref-flags pr)) + (make-info-call (info-call-src info) (info-call-sexpr info) + (info-call-check? info) #t #t + (info-call-shift-attachment? info) + (info-call-shift-consumer-attachment?* info)) + info)]) + (values `(call ,info ,mdcl ,(Symref (primref-name pr)) ,e* ...) + ;; an error can be treated as unboxed if the context wants that: + (and can-unbox-fp? (info-call-error? info)))))])] + [(call ,info ,mdcl ,x ,e* ...) + (guard (uvar-loop? x)) + (let ([e* (map (lambda (x1 e) + (let ([unbox? (eq? (uvar-type x1) 'fp)]) + (let-values ([(e unboxed-fp?) (Expr e unbox?)]) + (cond + [(and unbox? (not unboxed-fp?)) + (%mref ,e ,%zero ,(constant flonum-data-disp) fp)] + [else e])))) + (uvar-location x) e*)]) + (values `(call ,info ,mdcl ,x ,e* ...) #f))] + [(call ,info ,mdcl ,e ,e* ...) + (let ([e (and e (Expr1 e))] + [e* (Expr* e*)]) + (values `(call ,info ,mdcl ,e ,e* ...) #f))] + [(inline ,info ,prim ,e* ...) + (cond + [(info-unboxed-args? info) + (let ([e* (map (lambda (e unbox-arg?) + (let-values ([(e unboxed-arg?) (Expr e unbox-arg?)]) + (if (and unbox-arg? (not unboxed-arg?)) + (%mref ,e ,%zero ,(constant flonum-data-disp) fp) + e))) + e* + (info-unboxed-args-unboxed?* info))]) + (values `(inline ,info ,prim ,e* ...) + ;; Especially likely to be replaced by enclosing `unboxed-fp` wrapper: + #f))] + [else + (let ([e* (Expr* e*)]) + (values `(inline ,info ,prim ,e* ...) #f))])] + [(set! ,[lvalue #t -> lvalue fp-unboxed?l] ,e) + (let ([fp? (fp-lvalue? lvalue)]) + (let-values ([(e unboxed?) (Expr e fp?)]) + (let ([e (if (and fp? (not unboxed?)) + (%mref ,e ,%zero ,(constant flonum-data-disp) fp) + e)]) + (values `(set! ,lvalue ,e) #f))))] + [(values ,info ,[e* #f -> e* unboxed-fp?*] ...) (values `(values ,info ,e* ...) #f)] + [(alloc ,info ,e) (values `(alloc ,info ,(Expr1 e)) #f)] + [(if ,[e0 #f -> e0 unboxed-fp?0] ,[e1 can-unbox-fp? -> e1 unboxed-fp?1] ,[e2 can-unbox-fp? -> e2 unboxed-fp?2]) + (let* ([unboxed-fp? (or unboxed-fp?1 unboxed-fp?2)] + [e1 (if (and unboxed-fp? (not unboxed-fp?1)) + (%mref ,e1 ,%zero ,(constant flonum-data-disp) fp) + e1)] + [e2 (if (and unboxed-fp? (not unboxed-fp?2)) + (%mref ,e2 ,%zero ,(constant flonum-data-disp) fp) + e2)]) + (values `(if ,e0 ,e1 ,e2) unboxed-fp?))] + [(seq ,[e0 #f -> e0 unboxed-fp?0] ,[e1 can-unbox-fp? -> e1 unboxed-fp?]) + (values `(seq ,e0 ,e1) unboxed-fp?)] + [(let ([,x* ,e*] ...) ,body) + (let ([e* (map (lambda (x e) + (if (eq? (uvar-type x) 'fp) + (let-values ([(e unboxed?) (Expr e #t)]) + (if (not unboxed?) + (%mref ,e ,%zero ,(constant flonum-data-disp) fp) + e)) + (Expr1 e))) + x* e*)]) + (let-values ([(body unboxed-fp?) (Expr body can-unbox-fp?)]) + (values `(let ([,x* ,e*] ...) ,body) unboxed-fp?)))] + [(loop ,x (,x* ...) ,body) + (uvar-location-set! x x*) + (let-values ([(body unboxed-fp?) (Expr body can-unbox-fp?)]) + (uvar-location-set! x #f) + (values `(loop ,x (,x* ...) ,body) unboxed-fp?))] + [(attachment-set ,aop ,e) (values `(attachment-set ,aop ,(and e (Expr1 e))) #f)] + [(attachment-get ,reified ,e) (values `(attachment-get ,reified ,(and e (Expr1 e))) #f)] + [(attachment-consume ,reified ,e) (values `(attachment-consume ,reified ,(and e (Expr1 e))) #f)] + [(continuation-set ,cop ,e1 ,e2) (values `(continuation-set ,cop ,(Expr1 e1) ,(Expr1 e2)) #f)] + [(label ,l ,[body can-unbox-fp? -> body unboxed-fp?]) (values `(label ,l ,body) unboxed-fp?)] + [(foreign-call ,info ,e ,e* ...) + (let ([e (Expr1 e)] + [e* (if (info-foreign-unboxed? info) + (map (lambda (e type) + (let ([unbox-arg? (fp-type? type)]) + (let-values ([(e unboxed-fp?) (Expr e unbox-arg?)]) + (if (and unbox-arg? (not unboxed-fp?)) + (%mref ,e ,%zero ,(constant flonum-data-disp) fp) + e)))) + e* + (info-foreign-arg-type* info)) + (map Expr1 e*))]) + (let ([new-e `(foreign-call ,info ,e ,e* ...)] + [unboxed? (and (info-foreign-unboxed? info) + (fp-type? (info-foreign-result-type info)))]) + (if (and unboxed? (not can-unbox-fp?)) + (values (unboxed-fp->boxed new-e) #f) + (values new-e unboxed?))))] + [(mvcall ,info ,e1 ,e2) (values `(mvcall ,info ,(Expr1 e1) ,(Expr1 e2)) #f)] + [(mvlet ,e ((,x** ...) ,interface* ,body*) ...) + (values `(mvlet ,(Expr1 e) ((,x** ...) ,interface* ,(map Expr1 body*)) ...) #f)] + [,lvalue (Lvalue lvalue can-unbox-fp?)]) + (Lvalue : Lvalue (ir [unboxed-fp? #f]) -> Lvalue (#f) + [(mref ,e1 ,e2 ,imm ,type) + (let ([e `(mref ,(Expr1 e1) ,(Expr1 e2) ,imm ,type)]) + (if (and (eq? type 'fp) (not unboxed-fp?)) + (values (unboxed-fp->boxed e) #f) + (values e (eq? type 'fp))))] + [,x + (let ([fp? (and (uvar? x) (eq? (uvar-type x) 'fp))]) + (if (and fp? (not unboxed-fp?)) + (values (unboxed-fp->boxed x) #f) + (values x fp?)))])) + (define-who unhandled-arity + (lambda (name args) + (sorry! who "unhandled argument count ~s for ~s" (length args) 'name))) + (with-output-language (L7 Expr) + (define-$type-check (L7 Expr)) + (define-syntax define-inline + (let () + (define ctht2 (make-hashtable symbol-hash eq?)) + (define ctht3 (make-hashtable symbol-hash eq?)) + (define check-and-record + (lambda (level name) + (let ([a (symbol-hashtable-cell (if (fx= level 2) ctht2 ctht3) (syntax->datum name) #f)]) + (when (cdr a) (syntax-error name "duplicate inline")) + (set-cdr! a #t)))) + (lambda (x) + (define compute-interface + (lambda (clause) + (syntax-case clause () + [(x e1 e2 ...) (identifier? #'x) -1] + [((x ...) e1 e2 ...) (length #'(x ...))] + [((x ... . r) e1 e2 ...) (fxlognot (length #'(x ...)))]))) + (define bitmaskify + (lambda (i*) + (fold-left (lambda (mask i) + (logor mask (if (fx< i 0) (ash -1 (fxlognot i)) (ash 1 i)))) + 0 i*))) + (syntax-case x () + [(k level id clause ...) + (identifier? #'id) + (let ([level (datum level)] [name (datum id)]) + (unless (memv level '(2 3)) + (syntax-error x (format "invalid level ~s in inline definition" level))) + (let ([pr ($sgetprop name (if (eqv? level 2) '*prim2* '*prim3*) #f)]) + (include "primref.ss") + (unless pr + (syntax-error x (format "unrecognized primitive name ~s in inline definition" name))) + (let ([arity (primref-arity pr)]) + (when arity + (unless (= (bitmaskify arity) (bitmaskify (map compute-interface #'(clause ...)))) + (syntax-error x (format "arity mismatch for ~s" name)))))) + (check-and-record level #'id) + (with-implicit (k src sexpr moi) + #`(symbol-hashtable-set! #,(if (eqv? level 2) #'ht2 #'ht3) 'id + (rec moi + (lambda (src sexpr args) + (apply (case-lambda clause ... [rest #f]) args))))))])))) + (define no-need-to-bind? + (lambda (multiple-ref? e) + (nanopass-case (L7 Expr) e + [,x (if (uvar? x) (not (uvar-assigned? x)) (eq? x %zero))] + [(immediate ,imm) #t] ; might should produce binding if imm is large + [(quote ,d) (or (not multiple-ref?) (ptr->imm d))] + [,pr (not multiple-ref?)] + [(literal ,info) (and (not multiple-ref?) (not (info-literal-indirect? info)))] + [(profile ,src) #t] + [(pariah) #t] + [else #f]))) + (define binder + (lambda (multiple-ref? type e) + (if (no-need-to-bind? multiple-ref? e) + (values e values) + (let ([t (make-tmp 't type)]) + (values t (lift-fp-unboxed + (lambda (body) + `(let ([,t ,e]) ,body)))))))) + (define list-binder + (lambda (multiple-ref? type e*) + (if (null? e*) + (values '() values) + (let-values ([(e dobind) (binder multiple-ref? type (car e*))] + [(e* dobind*) (list-binder multiple-ref? type (cdr e*))]) + (values (cons e e*) + (lambda (body) + (dobind (dobind* body)))))))) + (define dirty-store-binder + (lambda (multiple-ref? type e) + (nanopass-case (L7 Expr) e + [(call ,info ,mdcl ,pr ,e) + (guard (eq? (primref-name pr) '$fixmediate)) + (let-values ([(t dobind) (binder multiple-ref? type e)]) + (values `(call ,info ,mdcl ,pr ,t) dobind))] + [else + (binder multiple-ref? type e)]))) + (define-syntax $bind + (lambda (x) + (syntax-case x () + [(_ binder multiple-ref? type (b ...) e) + (let ([t0* (generate-temporaries #'(b ...))]) + (let f ([b* #'(b ...)] [t* t0*] [x* '()]) + (if (null? b*) + (with-syntax ([(x ...) (reverse x*)] [(t ...) t0*]) + #`(let ([x t] ...) e)) + (syntax-case (car b*) () + [x (identifier? #'x) + #`(let-values ([(#,(car t*) dobind) (binder multiple-ref? 'type x)]) + (dobind #,(f (cdr b*) (cdr t*) (cons #'x x*))))] + [(x e) (identifier? #'x) + #`(let-values ([(#,(car t*) dobind) (binder multiple-ref? 'type e)]) + (dobind #,(f (cdr b*) (cdr t*) (cons #'x x*))))]))))]))) + (define-syntax bind + (syntax-rules () + [(_ multiple-ref? type (b ...) e) + (identifier? #'type) + ($bind binder multiple-ref? type (b ...) e)] + [(_ multiple-ref? (b ...) e) + ($bind binder multiple-ref? ptr (b ...) e)])) + (define-syntax list-bind + (syntax-rules () + [(_ multiple-ref? type (b ...) e) + (identifier? #'type) + ($bind list-binder multiple-ref? type (b ...) e)] + [(_ multiple-ref? (b ...) e) + ($bind list-binder multiple-ref? ptr (b ...) e)])) + (define-syntax dirty-store-bind + (syntax-rules () + [(_ multiple-ref? (b ...) e) + ($bind dirty-store-binder multiple-ref? ptr (b ...) e)])) + (define lift-fp-unboxed + (lambda (k) + (lambda (e) + ;; Propagate unboxing information: + (nanopass-case (L7 Expr) e + [(unboxed-fp ,e) `(unboxed-fp ,(k e))] + [else + (let ([new-e (k e)]) + (nanopass-case (L7 Expr) e + [(mref ,e0 ,e1 ,imm ,type) + (if (eq? type 'fp) + `(unboxed-fp ,new-e) + new-e)] + [,x (if (and (uvar? x) (eq? (uvar-type x) 'fp)) + `(unboxed-fp ,new-e) + new-e)] + [else new-e]))])))) + (define-syntax build-libcall + (lambda (x) + (syntax-case x () + [(k pariah? src sexpr name e ...) + (let ([libspec ($sgetprop (datum name) '*libspec* #f)]) + (define interface-okay? + (lambda (interface* cnt) + (ormap + (lambda (interface) + (if (fx< interface 0) + (fx>= cnt (lognot interface)) + (fx= cnt interface))) + interface*))) + (unless libspec (syntax-error x "unrecognized library routine")) + (unless (eqv? (length #'(e ...)) (libspec-interface libspec)) + (syntax-error x "invalid number of arguments")) + (let ([is-pariah? (datum pariah?)]) + (unless (boolean? is-pariah?) + (syntax-error x "pariah indicator must be a boolean literal")) + (when (and (libspec-error? libspec) (not is-pariah?)) + (syntax-error x "pariah indicator is inconsistent with libspec-error indicator")) + (with-implicit (k quasiquote) + (with-syntax ([body #`(call ,(make-info-call src sexpr #f pariah? #,(libspec-error? libspec)) #f + (literal ,(make-info-literal #f 'library '#,(datum->syntax #'* libspec) 0)) + ,e ...)]) + (if is-pariah? + #'`(seq (pariah) body) + #'`body)))))]))) + (define-syntax when-known-endianness + (lambda (stx) + (syntax-case stx () + [(_ e ...) + #'(constant-case native-endianness + [(unknown) (void)] + [else e ...])]))) + (define constant? + (case-lambda + [(x) + (nanopass-case (L7 Expr) x + [(quote ,d) #t] + ; TODO: handle immediate? + [else #f])] + [(pred? x) + (nanopass-case (L7 Expr) x + [(quote ,d) (pred? d)] + ; TODO: handle immediate? + [else #f])])) + (define constant-value + (lambda (x) + (nanopass-case (L7 Expr) x + [(quote ,d) d] + ; TODO: handle immediate if constant? does + [else #f]))) + (define maybe-add-label + (lambda (Llib body) + (if Llib + `(label ,Llib ,body) + body))) + (define build-and + (lambda (e1 e2) + `(if ,e1 ,e2 ,(%constant sfalse)))) + (define maybe-build-and + (lambda (e1 e2) + (if e1 + (build-and e1 e2) + e2))) + (define build-simple-or + (lambda (e1 e2) + `(if ,e1 ,(%constant strue) ,e2))) + (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 + [(quote ,d) (guard (target-fixnum? d)) `(immediate ,d)] + [else (%inline sra ,e ,(%constant fixnum-offset))]))) + (define build-not + (lambda (e) + `(if ,e ,(%constant sfalse) ,(%constant strue)))) + (define build-null? + (lambda (e) + (%type-check mask-nil snil ,e))) + (define build-eq? + (lambda (e1 e2) + (%inline eq? ,e1 ,e2))) + (define build-eqv? + (lambda (src sexpr e1 e2) + (bind #t (e1 e2) + (build-simple-or + (build-eq? e1 e2) + (build-and + ;; checking just one argument is good enough for typical + ;; uses, where `eqv?` almost always receives two fixnums + ;; or two characters; checking both arguments appears to + ;; by counter-productive by introducing too many branches + (build-simple-or + (%type-check mask-flonum type-flonum ,e1) + (build-and + (%type-check mask-typed-object type-typed-object ,e1) + (%type-check mask-other-number type-other-number + ,(%mref ,e1 ,(constant bignum-type-disp))))) + (build-libcall #f src sexpr eqv? e1 e2)))))) + (define make-build-eqv? + (lambda (src sexpr) + (lambda (e1 e2) + (build-eqv? src sexpr e1 e2)))) + (define fixnum-constant? + (lambda (e) + (constant? target-fixnum? e))) + (define expr->index + (lambda (e alignment limit) + (nanopass-case (L7 Expr) e + [(quote ,d) + (and (target-fixnum? d) + (>= d 0) + (< d limit) + (fxzero? (logand d (fx- alignment 1))) + d)] + [else #f]))) + (define build-fixnums? + (lambda (e*) + (let ([e* (remp fixnum-constant? e*)]) + (if (null? e*) + `(quote #t) + (%type-check mask-fixnum type-fixnum + ,(fold-left (lambda (e1 e2) (%inline logor ,e1 ,e2)) + (car e*) (cdr e*))))))) + (define build-flonums? + (lambda (e*) + (let ([e* (remp (lambda (e) (constant? flonum? e)) e*)]) + (if (null? e*) + `(quote #t) + (let f ([e* e*]) + (let ([e (car e*)] [e* (cdr e*)]) + (let ([check (%type-check mask-flonum type-flonum ,e)]) + (if (null? e*) + check + (build-and check (f e*)))))))))) + (define build-fl= + (lambda (e1 e2) ; must be bound + `(inline ,(make-info-unboxed-args '(#t #t)) ,%fp= ,e1 ,e2))) + (define build-chars? + (lambda (e1 e2) + (define char-constant? + (lambda (e) + (constant? char? e))) + (if (char-constant? e1) + (if (char-constant? e2) + (%constant strue) + (%type-check mask-char type-char ,e2)) + (if (char-constant? e2) + (%type-check mask-char type-char ,e1) + (build-and + (%type-check mask-char type-char ,e1) + (%type-check mask-char type-char ,e2)))))) + (define build-list + (lambda (e*) + (if (null? e*) + (%constant snil) + (list-bind #f (e*) + (bind #t ([t (%constant-alloc type-pair (fx* (constant size-pair) (length e*)))]) + (let loop ([e* e*] [i 0]) + (let ([e (car e*)] [e* (cdr e*)]) + `(seq + (set! ,(%mref ,t ,(fx+ i (constant pair-car-disp))) ,e) + ,(if (null? e*) + `(seq + (set! ,(%mref ,t ,(fx+ i (constant pair-cdr-disp))) ,(%constant snil)) + ,t) + (let ([next-i (fx+ i (constant size-pair))]) + `(seq + (set! ,(%mref ,t ,(fx+ i (constant pair-cdr-disp))) + ,(%inline + ,t (immediate ,next-i))) + ,(loop e* next-i)))))))))))) + (define build-pair? + (lambda (e) + (%type-check mask-pair type-pair ,e))) + (define build-car + (lambda (e) + (%mref ,e ,(constant pair-car-disp)))) + (define build-cdr + (lambda (e) + (%mref ,e ,(constant pair-cdr-disp)))) + (define build-char->integer + (lambda (e) + (%inline srl ,e + (immediate ,(fx- (constant char-data-offset) (constant fixnum-offset)))))) + (define build-integer->char + (lambda (e) + (%inline + + ,(%inline sll ,e + (immediate ,(fx- (constant char-data-offset) (constant fixnum-offset)))) + ,(%constant type-char)))) + (define need-store-fence? + (if-feature pthreads + (constant-case architecture + [(arm32 arm64) #t] + [else #f]) + #f)) + (define add-store-fence + ;; A store--store fence should be good enough for safety on a platform that + ;; orders load dependencies (which is anything except Alpha) + (lambda (e) + (if need-store-fence? + `(seq ,(%inline store-store-fence) ,e) + e))) + (define build-dirty-store + (case-lambda + [(base offset e) (build-dirty-store base %zero offset e)] + [(base index offset e) (build-dirty-store base index offset e + (lambda (base index offset e) `(set! ,(%mref ,base ,index ,offset) ,e)) + (lambda (s r) `(seq ,s ,r)))] + [(base index offset e build-assign build-remember-seq) + (nanopass-case (L7 Expr) e + [(call ,info ,mdcl ,pr ,e) + (guard (eq? (primref-name pr) '$fixmediate)) + (build-assign base index offset e)] + [else + (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) + (%lea ,base offset) + (%lea ,base ,index offset))]) + ; NB: should work harder to determine cases where x can't be a fixnum + (if (nanopass-case (L7 Expr) e + [(quote ,d) #t] + [(literal ,info) #t] + [else #f]) + (bind #f ([e e]) + ; eval a second so the address is not live across any calls + (bind #t ([a a]) + (add-store-fence + (build-remember-seq + (build-assign a %zero 0 e) + (%inline remember ,a))))) + (bind #t ([e e]) + ; eval a second so the address is not live across any calls + (bind #t ([a a]) + (if need-store-fence? + ;; Fence needs to be before store, so duplicate + ;; store instruction to lift out fixnum check; this + ;; appears to be worthwhile on the Apple M1 to avoid + ;; tighly interleaved writes and fences + `(if ,(%type-check mask-fixnum type-fixnum ,e) + ,(build-assign a %zero 0 e) + ,(add-store-fence + (build-remember-seq + (build-assign a %zero 0 e) + (%inline remember ,a)))) + ;; Generate one copy of store instruction + (build-remember-seq + (build-assign a %zero 0 e) + `(if ,(%type-check mask-fixnum type-fixnum ,e) + ,(%constant svoid) + ,(%inline remember ,a)))))))))])])) + (define make-build-cas + (lambda (old-v) + (lambda (base index offset v) + `(seq + ,(%inline cas ,base ,index (immediate ,offset) ,old-v ,v) + (inline ,(make-info-condition-code 'eq? #f #t) ,%condition-code))))) + (define build-cas-seq + (lambda (cas remember) + `(if ,cas + (seq ,remember ,(%constant strue)) + ,(%constant sfalse)))) + (define build-$record + (lambda (tag args) + (bind #f (tag) + (list-bind #f (args) + (let ([n (fx+ (length args) 1)]) + (bind #t ([t (%constant-alloc type-typed-object (fx* n (constant ptr-bytes)))]) + `(seq + (set! ,(%mref ,t ,(constant record-type-disp)) ,tag) + ,(let f ([args args] [offset (constant record-data-disp)]) + (if (null? args) + t + `(seq + (set! ,(%mref ,t ,offset) ,(car args)) + ,(f (cdr args) (fx+ offset (constant ptr-bytes))))))))))))) + (define build-$real->flonum + (lambda (src sexpr x who) + (if (known-flonum-result? x) + x + (bind #t (x) + (bind #f (who) + `(if ,(%type-check mask-flonum type-flonum ,x) + ,x + ,(build-libcall #t src sexpr real->flonum x who))))))) + (define build-$inexactnum-real-part + (lambda (e) + (%lea ,e (fx+ (constant inexactnum-real-disp) + (fx- (constant type-flonum) (constant typemod)))))) + (define build-$inexactnum-imag-part + (lambda (e) + (%lea ,e (fx+ (constant inexactnum-imag-disp) + (fx- (constant type-flonum) (constant typemod)))))) + (define make-build-fill + (lambda (elt-bytes data-disp) + (define ptr-bytes (constant ptr-bytes)) + (define super-size + (lambda (e-fill) + (define-who super-size-imm + (lambda (imm) + `(immediate + ,(constant-case ptr-bytes + [(4) + (case elt-bytes + [(1) (let ([imm (logand imm #xff)])< + (let ([imm (logor (ash imm 8) imm)]) + (logor (ash imm 16) imm)))] + [(2) (let ([imm (logand imm #xffff)]) + (logor (ash imm 16) imm))] + [else (sorry! who "unexpected elt-bytes ~s" elt-bytes)])] + [(8) + (case elt-bytes + [(1) (let ([imm (logand imm #xff)]) + (let ([imm (logor (ash imm 8) imm)]) + (let ([imm (logor (ash imm 16) imm)]) + (logor (ash imm 32) imm))))] + [(2) (let ([imm (logand imm #xffff)]) + (let ([imm (logor (ash imm 16) imm)]) + (logor (ash imm 32) imm)))] + [(4) (let ([imm (logand imm #xffffffff)]) + (logor (ash imm 32) imm))] + [else (sorry! who "unexpected elt-bytes ~s" elt-bytes)])])))) + (define-who super-size-expr + (lambda (e-fill) + (define (double e-fill k) + (%inline logor + ,(%inline sll ,e-fill (immediate ,k)) + ,e-fill)) + (define (mask e-fill k) + (%inline logand ,e-fill (immediate ,k))) + (constant-case ptr-bytes + [(4) + (case elt-bytes + [(1) (bind #t ([e-fill (mask e-fill #xff)]) + (bind #t ([e-fill (double e-fill 8)]) + (double e-fill 16)))] + [(2) (bind #t ([e-fill (mask e-fill #xffff)]) + (double e-fill 16))] + [else (sorry! who "unexpected elt-bytes ~s" elt-bytes)])] + [(8) + (case elt-bytes + [(1) (bind #t ([e-fill (mask e-fill #xff)]) + (bind #t ([e-fill (double e-fill 8)]) + (bind #t ([e-fill (double e-fill 16)]) + (double e-fill 32))))] + [(2) (bind #t ([e-fill (mask e-fill #xffff)]) + (bind #t ([e-fill (double e-fill 16)]) + (double e-fill 32)))] + [(4) (bind #t ([e-fill (mask e-fill #xffffffff)]) + (double e-fill 32))] + [else (sorry! who "unexpected elt-bytes ~s" elt-bytes)])]))) + (if (fx= elt-bytes ptr-bytes) + e-fill + (nanopass-case (L7 Expr) e-fill + [(quote ,d) + (cond + [(ptr->imm d) => super-size-imm] + [else (super-size-expr e-fill)])] + [(immediate ,imm) (super-size-imm imm)] + [else (super-size-expr e-fill)])))) + (lambda (e-vec e-bytes e-fill) + ; NB: caller must bind e-vec and e-fill + (safe-assert (no-need-to-bind? #t e-vec)) + (safe-assert (no-need-to-bind? #f e-fill)) + (nanopass-case (L7 Expr) e-bytes + [(immediate ,imm) + (guard (fixnum? imm) (fx<= 0 imm (fx* 4 ptr-bytes))) + (if (fx= imm 0) + e-vec + (bind #t ([e-fill (super-size e-fill)]) + (let f ([n (if (fx>= elt-bytes ptr-bytes) + imm + (fxlogand (fx+ imm (fx- ptr-bytes 1)) (fx- ptr-bytes)))]) + (let ([n (fx- n ptr-bytes)]) + `(seq + (set! ,(%mref ,e-vec ,(fx+ data-disp n)) ,e-fill) + ,(if (fx= n 0) e-vec (f n)))))))] + [else + (let ([Ltop (make-local-label 'Ltop)] [t (make-assigned-tmp 't 'uptr)]) + (bind #t ([e-fill (super-size e-fill)]) + `(let ([,t ,(if (fx>= elt-bytes ptr-bytes) + e-bytes + (nanopass-case (L7 Expr) e-bytes + [(immediate ,imm) + `(immediate ,(logand (+ imm (fx- ptr-bytes 1)) (fx- ptr-bytes)))] + [else + (%inline logand + ,(%inline + + ,e-bytes + (immediate ,(fx- ptr-bytes 1))) + (immediate ,(fx- ptr-bytes)))]))]) + (label ,Ltop + (if ,(%inline eq? ,t (immediate 0)) + ,e-vec + ,(%seq + (set! ,t ,(%inline - ,t (immediate ,ptr-bytes))) + (set! ,(%mref ,e-vec ,t ,data-disp) ,e-fill) + (goto ,Ltop)))))))])))) + + ;; NOTE: integer->ptr and unsigned->ptr DO NOT handle 64-bit integers on a 32-bit machine. + ;; this is okay for $object-ref and $object-set!, which do not support moving 64-bit values + ;; as single entities on a 32-bit machine, but care should be taken if these are used with + ;; other primitives. + (define-who integer->ptr + (lambda (x width) + (if (fx>= (constant fixnum-bits) width) + (build-fix x) + (%seq + (set! ,%ac0 ,x) + (set! ,%xp ,(build-fix %ac0)) + (set! ,%xp ,(build-unfix %xp)) + (if ,(%inline eq? ,%ac0 ,%xp) + ,(build-fix %ac0) + (seq + (set! ,%ac0 + (inline + ,(case width + [(32) (intrinsic-info-asmlib dofretint32 #f)] + [(64) (intrinsic-info-asmlib dofretint64 #f)] + [else ($oops who "can't handle width ~s" width)]) + ,%asmlibcall)) + ,%ac0)))))) + (define-who unsigned->ptr + (lambda (x width) + (if (fx>= (constant fixnum-bits) width) + (build-fix x) + `(seq + (set! ,%ac0 ,x) + (if ,(%inline u< ,(%constant most-positive-fixnum) ,%ac0) + (seq + (set! ,%ac0 + (inline + ,(case width + [(32) (intrinsic-info-asmlib dofretuns32 #f)] + [(64) (intrinsic-info-asmlib dofretuns64 #f)] + [else ($oops who "can't handle width ~s" width)]) + ,%asmlibcall)) + ,%ac0) + ,(build-fix %ac0)))))) + (define-who i32xu32->ptr + (lambda (hi lo) + (safe-assert (eqv? (constant ptr-bits) 32)) + (let ([Lbig (make-local-label 'Lbig)]) + (bind #t (lo hi) + `(if ,(%inline eq? ,hi ,(%inline sra ,lo (immediate 31))) + ,(bind #t ([fxlo (build-fix lo)]) + `(if ,(%inline eq? ,(build-unfix fxlo) ,lo) + ,fxlo + (goto ,Lbig))) + (label ,Lbig + ,(%seq + (set! ,%ac0 ,lo) + (set! ,(ref-reg %ac1) ,hi) + (set! ,%ac0 (inline ,(intrinsic-info-asmlib dofretint64 #f) ,%asmlibcall)) + ,%ac0))))))) + (define-who u32xu32->ptr + (lambda (hi lo) + (safe-assert (eqv? (constant ptr-bits) 32)) + (let ([Lbig (make-local-label 'Lbig)]) + (bind #t (lo hi) + `(if ,(%inline eq? ,hi (immediate 0)) + (if ,(%inline u< ,(%constant most-positive-fixnum) ,lo) + (goto ,Lbig) + ,(build-fix lo)) + (label ,Lbig + ,(%seq + (set! ,%ac0 ,lo) + (set! ,(ref-reg %ac1) ,hi) + (set! ,%ac0 (inline ,(intrinsic-info-asmlib dofretuns64 #f) ,%asmlibcall)) + ,%ac0))))))) + + (define-who ptr->integer + (lambda (value width) + (if (fx> (constant fixnum-bits) width) + (build-unfix value) + `(seq + (set! ,%ac0 ,value) + (if ,(%type-check mask-fixnum type-fixnum ,%ac0) + ,(build-unfix %ac0) + (seq + (set! ,%ac0 + (inline + ,(cond + [(fx<= width 32) (intrinsic-info-asmlib dofargint32 #f)] + [(fx<= width 64) (intrinsic-info-asmlib dofargint64 #f)] + [else ($oops who "can't handle width ~s" width)]) + ,%asmlibcall)) + ,%ac0)))))) + (define ptr-type (constant-case ptr-bits + [(32) 'unsigned-32] + [(64) 'unsigned-64] + [else ($oops 'ptr-type "unknown ptr-bit size ~s" (constant ptr-bits))])) + (define-who type->width + (lambda (x) + (case x + [(integer-8 unsigned-8 char) 8] + [(integer-16 unsigned-16) 16] + [(integer-24 unsigned-24) 24] + [(integer-32 unsigned-32 single-float) 32] + [(integer-40 unsigned-40) 40] + [(integer-48 unsigned-48) 48] + [(integer-56 unsigned-56) 56] + [(integer-64 unsigned-64 double-float) 64] + [(scheme-object fixnum) (constant ptr-bits)] + [(wchar) (constant wchar-bits)] + [else ($oops who "unknown type ~s" x)]))) + (define offset-expr->index+offset + (lambda (offset) + (if (fixnum-constant? offset) + (values %zero (constant-value offset)) + (values (build-unfix offset) 0)))) + (define-who build-int-load + ;; assumes aligned (if required) offset + (lambda (swapped? type base index offset build-int) + (case type + [(integer-8 unsigned-8) + (build-int `(inline ,(make-info-load type #f) ,%load ,base ,index (immediate ,offset)))] + [(integer-16 integer-32 unsigned-16 unsigned-32) + (build-int `(inline ,(make-info-load type swapped?) ,%load ,base ,index (immediate ,offset)))] + [(integer-64 unsigned-64) + ;; NB: doesn't handle unknown endiannesss for 32-bit machines + (constant-case ptr-bits + [(32) + (let-values ([(lo hi) (if (constant-case native-endianness [(little) swapped?] [(big) (not swapped?)]) + (values (+ offset 4) offset) + (values offset (+ offset 4)))]) + (bind #t (base index) + (build-int + `(inline ,(make-info-load 'integer-32 swapped?) ,%load ,base ,index (immediate ,hi)) + `(inline ,(make-info-load 'unsigned-32 swapped?) ,%load ,base ,index (immediate ,lo)))))] + [(64) + (build-int `(inline ,(make-info-load type swapped?) ,%load ,base ,index (immediate ,offset)))])] + [(integer-24 unsigned-24) + (constant-case native-endianness + [(unknown) #f] + [else + (let-values ([(lo hi) (if (constant-case native-endianness [(little) swapped?] [(big) (not swapped?)]) + (values (+ offset 1) offset) + (values offset (+ offset 2)))]) + (define hi-type (if (eq? type 'integer-24) 'integer-8 'unsigned-8)) + (bind #t (base index) + (build-int + (%inline logor + ,(%inline sll + (inline ,(make-info-load hi-type #f) ,%load ,base ,index (immediate ,hi)) + (immediate 16)) + (inline ,(make-info-load 'unsigned-16 swapped?) ,%load ,base ,index (immediate ,lo))))))])] + [(integer-40 unsigned-40) + (constant-case native-endianness + [(unknown) #f] + [else + (let-values ([(lo hi) (if (constant-case native-endianness [(little) swapped?] [(big) (not swapped?)]) + (values (+ offset 1) offset) + (values offset (+ offset 4)))]) + (define hi-type (if (eq? type 'integer-40) 'integer-8 'unsigned-8)) + (bind #t (base index) + (constant-case ptr-bits + [(32) + (build-int + `(inline ,(make-info-load hi-type #f) ,%load ,base ,index (immediate ,hi)) + `(inline ,(make-info-load 'unsigned-32 swapped?) ,%load ,base ,index (immediate ,lo)))] + [(64) + (build-int + (%inline logor + ,(%inline sll + (inline ,(make-info-load hi-type #f) ,%load ,base ,index (immediate ,hi)) + (immediate 32)) + (inline ,(make-info-load 'unsigned-32 swapped?) ,%load ,base ,index (immediate ,lo))))])))])] + [(integer-48 unsigned-48) + (constant-case native-endianness + [(unknown) #f] + [else + (let-values ([(lo hi) (if (constant-case native-endianness [(little) swapped?] [(big) (not swapped?)]) + (values (+ offset 2) offset) + (values offset (+ offset 4)))]) + (define hi-type (if (eq? type 'integer-48) 'integer-16 'unsigned-16)) + (bind #t (base index) + (constant-case ptr-bits + [(32) + (build-int + `(inline ,(make-info-load hi-type swapped?) ,%load ,base ,index (immediate ,hi)) + `(inline ,(make-info-load 'unsigned-32 swapped?) ,%load ,base ,index (immediate ,lo)))] + [(64) + (build-int + (%inline logor + ,(%inline sll + (inline ,(make-info-load hi-type swapped?) ,%load ,base ,index (immediate ,hi)) + (immediate 32)) + (inline ,(make-info-load 'unsigned-32 swapped?) ,%load ,base ,index (immediate ,lo))))])))])] + [(integer-56 unsigned-56) + (constant-case native-endianness + [(unknown) #f] + [else + (safe-assert (not (eq? (constant native-endianness) 'unknown))) + (let-values ([(lo mi hi) (if (constant-case native-endianness [(little) swapped?] [(big) (not swapped?)]) + (values (+ offset 3) (+ offset 1) offset) + (values offset (+ offset 4) (+ offset 6)))]) + (define hi-type (if (eq? type 'integer-56) 'integer-8 'unsigned-8)) + (bind #t (base index) + (constant-case ptr-bits + [(32) + (build-int + (%inline logor + ,(%inline sll + (inline ,(make-info-load hi-type #f) ,%load ,base ,index (immediate ,hi)) + (immediate 16)) + (inline ,(make-info-load 'unsigned-16 swapped?) ,%load ,base ,index (immediate ,mi))) + `(inline ,(make-info-load 'unsigned-32 swapped?) ,%load ,base ,index (immediate ,lo)))] + [(64) + (build-int + (%inline logor + ,(%inline sll + ,(%inline logor + ,(%inline sll + (inline ,(make-info-load hi-type #f) ,%load ,base ,index (immediate ,hi)) + (immediate 16)) + (inline ,(make-info-load 'unsigned-16 swapped?) ,%load ,base ,index (immediate ,mi))) + (immediate 32)) + (inline ,(make-info-load 'unsigned-32 swapped?) ,%load ,base ,index (immediate ,lo))))])))])] + [else (sorry! who "unsupported type ~s" type)]))) + (define-who build-object-ref + ;; assumes aligned (if required) offset + (case-lambda + [(swapped? type base offset-expr) + (let-values ([(index offset) (offset-expr->index+offset offset-expr)]) + (build-object-ref swapped? type base index offset))] + [(swapped? type base index offset) + (case type + [(scheme-object) `(inline ,(make-info-load ptr-type swapped?) ,%load ,base ,index (immediate ,offset))] + [(double-float) + (if swapped? + (constant-case ptr-bits + [(32) + (bind #t (base index) + (bind #t ([t (%constant-alloc type-flonum (constant size-flonum))]) + (%seq + (set! ,(%mref ,t ,(constant flonum-data-disp)) + (inline ,(make-info-load 'unsigned-32 #t) ,%load ,base ,index + (immediate ,(+ offset 4)))) + (set! ,(%mref ,t ,(+ (constant flonum-data-disp) 4)) + (inline ,(make-info-load 'unsigned-32 #t) ,%load ,base ,index + (immediate ,offset))) + ,t)))] + [(64) + (bind #f (base index) + (bind #t ([t (%constant-alloc type-flonum (constant size-flonum))]) + `(seq + (set! ,(%mref ,t ,(constant flonum-data-disp)) + (inline ,(make-info-load 'unsigned-64 #t) ,%load ,base ,index + (immediate ,offset))) + ,t)))]) + (bind #f (base index) + (%mref ,base ,index ,offset fp)))] + [(single-float) + (if swapped? + (bind #f (base index) + (bind #t ([t (%constant-alloc type-flonum (constant size-flonum))]) + (%seq + (inline ,(make-info-load 'unsigned-32 #f) ,%store ,t ,%zero ,(%constant flonum-data-disp) + (inline ,(make-info-load 'unsigned-32 #t) ,%load ,base ,index + (immediate ,offset))) + (set! ,(%mref ,t ,%zero ,(constant flonum-data-disp) fp) + (unboxed-fp (inline ,(make-info-unboxed-args '(#t)) + ,%load-single->double + ;; slight abuse to call this "unboxed", but `load-single->double` + ;; wants an FP-flavored address + ,(%mref ,t ,%zero ,(constant flonum-data-disp) fp)))) + ,t))) + (bind #f (base index) + (bind #t ([t (%constant-alloc type-flonum (constant size-flonum))]) + (%seq + (set! ,(%mref ,t ,%zero ,(constant flonum-data-disp) fp) + (unboxed-fp (inline ,(make-info-unboxed-args '(#t)) + ,%load-single->double + ;; slight abuse to call this "unboxed", but `load-single->double` + ;; wants an FP-flavored address + ,(%mref ,base ,index ,offset fp)))) + ,t))))] + [(integer-8 integer-16 integer-24 integer-32 integer-40 integer-48 integer-56 integer-64) + (build-int-load swapped? type base index offset + (if (and (eqv? (constant ptr-bits) 32) (memq type '(integer-40 integer-48 integer-56 integer-64))) + i32xu32->ptr + (lambda (x) (integer->ptr x (type->width type)))))] + [(unsigned-8 unsigned-16 unsigned-24 unsigned-32 unsigned-40 unsigned-48 unsigned-56 unsigned-64) + (build-int-load swapped? type base index offset + (if (and (eqv? (constant ptr-bits) 32) (memq type '(unsigned-40 unsigned-48 unsigned-56 unsigned-64))) + u32xu32->ptr + (lambda (x) (unsigned->ptr x (type->width type)))))] + [(fixnum) (build-fix `(inline ,(make-info-load ptr-type swapped?) ,%load ,base ,index (immediate ,offset)))] + [else (sorry! who "unsupported type ~s" type)])])) + (define-who build-int-store + ;; assumes aligned (if required) offset + (lambda (swapped? type base index offset value) + (case type + [(integer-8 unsigned-8) + `(inline ,(make-info-load type #f) ,%store ,base ,index (immediate ,offset) ,value)] + [(integer-16 integer-32 integer-64 unsigned-16 unsigned-32 unsigned-64) + `(inline ,(make-info-load type swapped?) ,%store ,base ,index (immediate ,offset) ,value)] + [(integer-24 unsigned-24) + (constant-case native-endianness + [(unknown) #f] + [else + (let-values ([(lo hi) (if (constant-case native-endianness [(little) swapped?] [(big) (not swapped?)]) + (values (+ offset 1) offset) + (values offset (+ offset 2)))]) + (bind #t (base index value) + (%seq + (inline ,(make-info-load 'unsigned-16 swapped?) ,%store ,base ,index (immediate ,lo) ,value) + (inline ,(make-info-load 'unsigned-8 #f) ,%store ,base ,index (immediate ,hi) + ,(%inline srl ,value (immediate 16))))))])] + [(integer-40 unsigned-40) + (constant-case native-endianness + [(unknown) #f] + [else + (let-values ([(lo hi) (if (constant-case native-endianness [(little) swapped?] [(big) (not swapped?)]) + (values (+ offset 1) offset) + (values offset (+ offset 4)))]) + (bind #t (base index value) + (%seq + (inline ,(make-info-load 'unsigned-32 swapped?) ,%store ,base ,index (immediate ,lo) ,value) + (inline ,(make-info-load 'unsigned-8 #f) ,%store ,base ,index (immediate ,hi) + ,(%inline srl ,value (immediate 32))))))])] + [(integer-48 unsigned-48) + (constant-case native-endianness + [(unknown) #f] + [else + (let-values ([(lo hi) (if (constant-case native-endianness [(little) swapped?] [(big) (not swapped?)]) + (values (+ offset 2) offset) + (values offset (+ offset 4)))]) + (bind #t (base index value) + (%seq + (inline ,(make-info-load 'unsigned-32 swapped?) ,%store ,base ,index (immediate ,lo) ,value) + (inline ,(make-info-load 'unsigned-16 swapped?) ,%store ,base ,index (immediate ,hi) + ,(%inline srl ,value (immediate 32))))))])] + [(integer-56 unsigned-56) + (constant-case native-endianness + [(unknown) #f] + [else + (let-values ([(lo mi hi) (if (constant-case native-endianness [(little) swapped?] [(big) (not swapped?)]) + (values (+ offset 3) (+ offset 1) offset) + (values offset (+ offset 4) (+ offset 6)))]) + (bind #t (base index value) + (%seq + (inline ,(make-info-load 'unsigned-32 swapped?) ,%store ,base ,index (immediate ,lo) ,value) + (inline ,(make-info-load 'unsigned-16 swapped?) ,%store ,base ,index (immediate ,mi) + ,(%inline srl ,value (immediate 32))) + (inline ,(make-info-load 'unsigned-8 #f) ,%store ,base ,index (immediate ,hi) + ,(%inline srl ,value (immediate 48))))))])] + [else (sorry! who "unsupported type ~s" type)]))) + (define-who build-object-set! + ;; assumes aligned (if required) offset + (case-lambda + [(type base offset-expr value) + (let-values ([(index offset) (offset-expr->index+offset offset-expr)]) + (build-object-set! type base index offset value))] + [(type base index offset value) + (case type + [(scheme-object) (build-dirty-store base index offset value)] + [(double-float) + (bind #f (base index) + `(set! ,(%mref ,base ,index ,offset fp) ,value))] + [(single-float) + (bind #f (base index) + `(inline ,(make-info-unboxed-args '(#t #t)) ,%store-double->single + ;; slight abuse to call this "unboxed", but `store-double->single` + ;; wants an FP-flavored address + ,(%mref ,base ,index ,offset fp) + ,(%mref ,value ,%zero ,(constant flonum-data-disp) fp)))] + ; 40-bit+ only on 64-bit machines + [(integer-8 integer-16 integer-24 integer-32 integer-40 integer-48 integer-56 integer-64 + unsigned-8 unsigned-16 unsigned-24 unsigned-32 unsigned-40 unsigned-48 unsigned-56 unsigned-64) + (build-int-store #f type base index offset (ptr->integer value (type->width type)))] + [(fixnum) + `(inline ,(make-info-load ptr-type #f) ,%store + ,base ,index (immediate ,offset) ,(build-unfix value))] + [else (sorry! who "unrecognized type ~s" type)])])) + (define-who build-swap-object-set! + (case-lambda + [(type base offset-expr value) + (let-values ([(index offset) (offset-expr->index+offset offset-expr)]) + (build-swap-object-set! type base index offset value))] + [(type base index offset value) + (case type + ; only on 64-bit machines + [(double-float) + `(inline ,(make-info-load 'unsigned-64 #t) ,%store + ,base ,index (immediate ,offset) + ,(%mref ,value ,(constant flonum-data-disp)))] + ; 40-bit+ only on 64-bit machines + [(integer-8 integer-16 integer-24 integer-32 integer-40 integer-48 integer-56 integer-64 + unsigned-8 unsigned-16 unsigned-24 unsigned-32 unsigned-40 unsigned-48 unsigned-56 unsigned-64) + (build-int-store #t type base index offset (ptr->integer value (type->width type)))] + [(fixnum) + `(inline ,(make-info-load ptr-type #t) ,%store ,base ,index (immediate ,offset) + ,(build-unfix value))] + [else (sorry! who "unrecognized type ~s" type)])])) + (define extract-unsigned-bitfield + (lambda (raw? start end arg) + (let* ([left (fx- (if raw? (constant ptr-bits) (constant fixnum-bits)) end)] + [right (if raw? (fx- (fx+ left start) (constant fixnum-offset)) (fx+ left start))] + [body (%inline srl + ,(if (fx= left 0) + arg + (%inline sll ,arg (immediate ,left))) + (immediate ,right))]) + (if (fx= start 0) + body + (%inline logand ,body (immediate ,(- (constant fixnum-factor)))))))) + (define extract-signed-bitfield + (lambda (raw? start end arg) + (let* ([left (fx- (if raw? (constant ptr-bits) (constant fixnum-bits)) end)] + [right (if raw? (fx- (fx+ left start) (constant fixnum-offset)) (fx+ left start))]) + (let ([body (if (fx= left 0) arg (%inline sll ,arg (immediate ,left)))]) + (let ([body (if (fx= right 0) body (%inline sra ,body (immediate ,right)))]) + (if (fx= start 0) + body + (%inline logand ,body (immediate ,(- (constant fixnum-factor)))))))))) + (define insert-bitfield + (lambda (raw? start end bf-width arg val) + (if raw? + (cond + [(fx= start 0) + (%inline logor + ,(%inline sll + ,(%inline srl ,arg (immediate ,end)) + (immediate ,end)) + ,(%inline srl + ,(%inline sll ,val (immediate ,(fx- (constant fixnum-bits) end))) + (immediate ,(fx- (constant ptr-bits) end))))] + [(fx= end bf-width) + (%inline logor + ,(%inline srl + ,(%inline sll ,arg + (immediate ,(fx- (constant ptr-bits) start))) + (immediate ,(fx- (constant ptr-bits) start))) + ,(cond + [(fx< start (constant fixnum-offset)) + (%inline srl ,val + (immediate ,(fx- (constant fixnum-offset) start)))] + [(fx> start (constant fixnum-offset)) + (%inline sll ,val + (immediate ,(fx- start (constant fixnum-offset))))] + [else val]))] + [else + (%inline logor + ,(%inline logand ,arg + (immediate ,(lognot (ash (- (expt 2 (fx- end start)) 1) start)))) + ,(%inline srl + ,(if (fx= (fx- end start) (constant fixnum-bits)) + val + (%inline sll ,val + (immediate ,(fx- (constant fixnum-bits) (fx- end start))))) + (immediate ,(fx- (constant ptr-bits) end))))]) + (cond + [(fx= start 0) + (%inline logor + ,(%inline sll + ,(%inline srl ,arg (immediate ,(fx+ end (constant fixnum-offset)))) + (immediate ,(fx+ end (constant fixnum-offset)))) + ,(%inline srl + ,(%inline sll ,val (immediate ,(fx- (constant fixnum-bits) end))) + (immediate ,(fx- (constant fixnum-bits) end))))] + #;[(fx= end (constant fixnum-bits)) ---] ; end < fixnum-bits + [else + (%inline logor + ,(%inline logand ,arg + (immediate ,(lognot (ash (- (expt 2 (fx- end start)) 1) + (fx+ start (constant fixnum-offset)))))) + ,(%inline srl + ,(%inline sll ,val + (immediate ,(fx- (constant fixnum-bits) (fx- end start)))) + (immediate ,(fx- (constant fixnum-bits) end))))])))) + (define translate + (lambda (e current-shift target-shift) + (let ([delta (fx- current-shift target-shift)]) + (if (fx= delta 0) + e + (if (fx< delta 0) + (%inline sll ,e (immediate ,(fx- delta))) + (%inline srl ,e (immediate ,delta))))))) + (define extract-length + (lambda (t/l length-offset) + (%inline logand + ,(translate t/l length-offset (constant fixnum-offset)) + (immediate ,(- (constant fixnum-factor)))))) + (define build-type/length + (lambda (e type current-shift target-shift) + (let ([e (translate e current-shift target-shift)]) + (if (eqv? type 0) + e + (%inline logor ,e (immediate ,type)))))) + (define-syntax build-ref-check + (syntax-rules () + [(_ type-disp maximum-length length-offset type mask immutable-flag) + (lambda (e-v e-i maybe-e-new) + ; NB: caller must bind e-v, e-i, and maybe-e-new + (safe-assert (no-need-to-bind? #t e-v)) + (safe-assert (no-need-to-bind? #t e-i)) + (safe-assert (or (not maybe-e-new) (no-need-to-bind? #t maybe-e-new))) + (build-and + (%type-check mask-typed-object type-typed-object ,e-v) + (bind #t ([t (%mref ,e-v ,(constant type-disp))]) + (cond + [(expr->index e-i 1 (constant maximum-length)) => + (lambda (index) + (let ([e (%inline u< + (immediate ,(logor (ash index (constant length-offset)) (constant type) (constant immutable-flag))) + ,t)]) + (if (and (eqv? (constant type) (constant type-fixnum)) + (eqv? (constant mask) (constant mask-fixnum))) + (build-and e (build-fixnums? (if maybe-e-new (list t maybe-e-new) (list t)))) + (build-and + (%type-check mask type ,t) + (if maybe-e-new (build-and e (build-fixnums? (list maybe-e-new))) e)))))] + [else + (let ([e (%inline u< ,e-i ,(extract-length t (constant length-offset)))]) + (if (and (eqv? (constant type) (constant type-fixnum)) + (eqv? (constant mask) (constant mask-fixnum))) + (build-and e (build-fixnums? (if maybe-e-new (list e-i t maybe-e-new) (list e-i t)))) + (build-and + (%type-check mask type ,t) + (build-and + (build-fixnums? (if maybe-e-new (list e-i maybe-e-new) (list e-i))) + e))))]))))])) + (define-syntax build-set-immutable! + (syntax-rules () + [(_ type-disp immutable-flag) + (lambda (e-v) + (bind #t (e-v) + `(set! ,(%mref ,e-v ,(constant type-disp)) + ,(%inline logor + ,(%mref ,e-v ,(constant type-disp)) + (immediate ,(constant immutable-flag))))))])) + (define inline-args-limit (constant inline-args-limit)) + (define reduce-equality + (lambda (src sexpr moi e1 e2 e*) + (and (fx<= (length e*) (fx- inline-args-limit 2)) + (bind #t (e1) + (bind #f (e2) + (list-bind #f (e*) + (let compare ([src src] [e2 e2] [e* e*]) + (if (null? e*) + (moi src sexpr (list e1 e2)) + `(if ,(moi src sexpr (list e1 e2)) + ,(compare #f (car e*) (cdr e*)) + (quote #f)))))))))) + (define reduce-inequality + (lambda (src sexpr moi e1 e2 e*) + (and (fx<= (length e*) (fx- inline-args-limit 2)) + (let f ([e2 e2] [e* e*] [re* '()]) + (if (null? e*) + (bind #f ([e2 e2]) + (let compare ([src src] [e* (cons e1 (reverse (cons e2 re*)))]) + (let ([more-args (cddr e*)]) + (if (null? more-args) + (moi src sexpr e*) + `(if ,(moi src sexpr (list (car e*) (cadr e*))) + ,(compare #f (cdr e*)) + (quote #f)))))) + (bind #t ([e2 e2]) (f (car e*) (cdr e*) (cons e2 re*)))))))) + (define reduce ; left associative as required for, e.g., fx- + (lambda (src sexpr moi e e*) + (and (fx<= (length e*) (fx- inline-args-limit 1)) + (bind #f (e) + (list-bind #f ([e* e*]) + (let reduce ([src src] [e e] [e* e*]) + (if (null? e*) + e + (reduce #f (moi src sexpr (list e (car e*))) (cdr e*))))))))) + (define reduce-fp-compare ; suitable for arguments known or assumed to produce flonums + (lambda (reduce) + (lambda (src sexpr moi e1 e2 e*) + (and (fx<= (length e*) (fx- inline-args-limit 2)) + (bind #t fp (e1) + (bind #f fp (e2) + (list-bind #f fp (e*) + (reduce src sexpr moi e1 e2 e*)))))))) + (define reduce-fp ; specialized reducer supports unboxing for nesting + (lambda (src sexpr level name e e*) + (and (fx<= (length e*) (fx- inline-args-limit 1)) + (let ([pr (lookup-primref level name)]) + (let reduce ([e e] [src src] [sexpr sexpr] [e* e*]) + (if (null? e*) + e + (reduce `(call ,(make-info-call src sexpr #f #f #f) #f ,pr ,e ,(car e*)) + #f #f (cdr e*)))))))) + (module (relop-length RELOP< RELOP<= RELOP= RELOP>= RELOP>) + (define RELOP< -2) + (define RELOP<= -1) + (define RELOP= 0) + (define RELOP>= 1) + (define RELOP> 2) + (define (mirror op) (fx- op)) + (define go + (lambda (op e n) + (let f ([n n] [e e]) + (if (fx= n 0) + (cond + [(or (eqv? op RELOP=) (eqv? op RELOP<=)) (build-null? e)] + [(eqv? op RELOP<) `(seq ,e (quote #f))] + [(eqv? op RELOP>) (build-not (build-null? e))] + [(eqv? op RELOP>=) `(seq ,e (quote #t))] + [else (sorry! 'relop-length "unexpected op ~s" op)]) + (cond + [(or (eqv? op RELOP=) (eqv? op RELOP>)) + (bind #t (e) + (build-and + (build-not (build-null? e)) + (f (fx- n 1) (build-cdr e))))] + [(eqv? op RELOP<) + (if (fx= n 1) + (build-null? e) + (bind #t (e) + (build-simple-or + (build-null? e) + (f (fx- n 1) (build-cdr e)))))] + [(eqv? op RELOP<=) + (bind #t (e) + (build-simple-or + (build-null? e) + (f (fx- n 1) (build-cdr e))))] + [(eqv? op RELOP>=) + (if (fx= n 1) + (build-not (build-null? e)) + (bind #t (e) + (build-and + (build-not (build-null? e)) + (f (fx- n 1) (build-cdr e)))))] + [else (sorry! 'relop-length "unexpected op ~s" op)]))))) + (define relop-length1 + (lambda (op e n) + (nanopass-case (L7 Expr) e + [(call ,info ,mdcl ,pr ,e) + (guard (and (eq? (primref-name pr) 'length) (all-set? (prim-mask unsafe) (primref-flags pr)))) + (go op e n)] + [else #f]))) + (define relop-length2 + (lambda (op e1 e2) + (nanopass-case (L7 Expr) e2 + [(quote ,d) (and (fixnum? d) (fx<= 0 d 4) (relop-length1 op e1 d))] + [else #f]))) + (define relop-length + (case-lambda + [(op e) (relop-length1 op e 0)] + [(op e1 e2) (or (relop-length2 op e1 e2) (relop-length2 (mirror op) e2 e1))]))) + (define make-ftype-pointer-equal? + (lambda (e1 e2) + (bind #f (e1 e2) + (%inline eq? + ,(%mref ,e1 ,(constant record-data-disp)) + ,(%mref ,e2 ,(constant record-data-disp)))))) + (define make-ftype-pointer-null? + (lambda (e) + (%inline eq? + ,(%mref ,e ,(constant record-data-disp)) + (immediate 0)))) + (define eqvop-null-fptr + (lambda (e1 e2) + (nanopass-case (L7 Expr) e1 + [(call ,info ,mdcl ,pr ,e1) + (and + (eq? (primref-name pr) 'ftype-pointer-address) + (all-set? (prim-mask unsafe) (primref-flags pr)) + (nanopass-case (L7 Expr) e2 + [(quote ,d) + (and (eqv? d 0) (make-ftype-pointer-null? e1))] + [(call ,info ,mdcl ,pr ,e2) + (and (eq? (primref-name pr) 'ftype-pointer-address) + (all-set? (prim-mask unsafe) (primref-flags pr)) + (make-ftype-pointer-equal? e1 e2))] + [else #f]))] + [(quote ,d) + (and (eqv? d 0) + (nanopass-case (L7 Expr) e2 + [(call ,info ,mdcl ,pr ,e2) + (and (eq? (primref-name pr) 'ftype-pointer-address) + (all-set? (prim-mask unsafe) (primref-flags pr)) + (make-ftype-pointer-null? e2))] + [else #f]))] + [else #f]))) + (define-inline 2 values + [(e) (ensure-single-valued e)] + [e* `(values ,(make-info-call src sexpr #f #f #f) ,e* ...)]) + (define-inline 2 $value + [(e) (ensure-single-valued e #f)]) + (define-inline 2 eq? + [(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))]) + (let () + (define (zgo src sexpr e e1 e2 r6rs?) + (build-simple-or + (%inline eq? ,e (immediate 0)) + `(if ,(build-fixnums? (list e)) + ,(%constant sfalse) + ,(if r6rs? + (build-libcall #t src sexpr fx=? e1 e2) + (build-libcall #t src sexpr fx= e1 e2))))) + (define (go src sexpr e1 e2 r6rs?) + (or (relop-length RELOP= e1 e2) + (cond + [(constant? (lambda (x) (eqv? x 0)) e1) + (bind #t (e2) (zgo src sexpr e2 e1 e2 r6rs?))] + [(constant? (lambda (x) (eqv? x 0)) e2) + (bind #t (e1) (zgo src sexpr e1 e1 e2 r6rs?))] + [else (bind #t (e1 e2) + `(if ,(build-fixnums? (list e1 e2)) + ,(%inline eq? ,e1 ,e2) + ,(if r6rs? + (build-libcall #t src sexpr fx=? e1 e2) + (build-libcall #t src sexpr fx= e1 e2))))]))) + (define-inline 2 fx= + [(e1 e2) (go src sexpr e1 e2 #f)] + [(e1 . e*) #f]) + (define-inline 2 fx=? + [(e1 e2) (go src sexpr e1 e2 #t)] + [(e1 e2 . e*) #f])) + (let () ; level 2 fx<, fx<?, etc. + (define-syntax fx-pred + (syntax-rules () + [(_ op r6rs:op length-op inline-op) + (let () + (define (go src sexpr e1 e2 r6rs?) + (or (relop-length length-op e1 e2) + (bind #t (e1 e2) + `(if ,(build-fixnums? (list e1 e2)) + ,(%inline inline-op ,e1 ,e2) + ,(if r6rs? + (build-libcall #t src sexpr r6rs:op e1 e2) + (build-libcall #t src sexpr op e1 e2)))))) + (define-inline 2 op + [(e1 e2) (go src sexpr e1 e2 #f)] + ; TODO: 3-operand case requires 3-operand library routine + #;[(e1 e2 e3) (go3 src sexpr e1 e2 e3 #f)] + [(e1 . e*) #f]) + (define-inline 2 r6rs:op + [(e1 e2) (go src sexpr e1 e2 #t)] + ; TODO: 3-operand case requires 3-operand library routine + #; [(e1 e2 e3) (go3 src sexpr e1 e2 e3 #t)] + [(e1 e2 . e*) #f]))])) + (fx-pred fx< fx<? RELOP< <) + (fx-pred fx<= fx<=? RELOP<= <=) + (fx-pred fx>= fx>=? RELOP>= >=) + (fx-pred fx> fx>? RELOP> >)) + (let () ; level 3 fx=, fx=?, etc. + (define-syntax fx-pred + (syntax-rules () + [(_ op r6rs:op length-op inline-op) + (let () + (define (go e1 e2) + (or (relop-length length-op e1 e2) + (%inline inline-op ,e1 ,e2))) + (define reducer + (if (eq? 'inline-op 'eq?) + reduce-equality + reduce-inequality)) + (define-inline 3 op + [(e) `(seq ,(ensure-single-valued e) ,(%constant strue))] + [(e1 e2) (go e1 e2)] + [(e1 e2 . e*) (reducer src sexpr moi e1 e2 e*)]) + (define-inline 3 r6rs:op + [(e1 e2) (go e1 e2)] + [(e1 e2 . e*) (reducer src sexpr moi e1 e2 e*)]))])) + (fx-pred fx< fx<? RELOP< <) + (fx-pred fx<= fx<=? RELOP<= <=) + (fx-pred fx= fx=? RELOP= eq?) + (fx-pred fx>= fx>=? RELOP>= >=) + (fx-pred fx> fx>? RELOP> >)) + (let () ; level 3 fxlogand, ... + (define-syntax fxlogop + (syntax-rules () + [(_ op inline-op base) + (define-inline 3 op + [() `(immediate ,(fix base))] + [(e) (ensure-single-valued e)] + [(e1 e2) (%inline inline-op ,e1 ,e2)] + [(e1 . e*) (reduce src sexpr moi e1 e*)])])) + (fxlogop fxlogand logand -1) + (fxlogop fxand logand -1) + (fxlogop fxlogor logor 0) + (fxlogop fxlogior logor 0) + (fxlogop fxior logor 0) + (fxlogop fxlogxor logxor 0) + (fxlogop fxxor logxor 0)) + (let () + (define log-partition + (lambda (p base e*) + (let loop ([e* e*] [n base] [nc* '()]) + (if (null? e*) + (if (and (fixnum? n) (fx= n base) (not (null? nc*))) + (values (car nc*) (cdr nc*) nc*) + (values `(immediate ,(fix n)) nc* nc*)) + (let ([e (car e*)]) + (if (fixnum-constant? e) + (let ([m (constant-value e)]) + (loop (cdr e*) (if n (p n m) m) nc*)) + (loop (cdr e*) n (cons e nc*)))))))) + (let () ; level 2 fxlogor, fxlogior, fxor + (define-syntax fxlogorop + (syntax-rules () + [(_ op) + (let () + (define (go src sexpr e*) + (and (fx<= (length e*) inline-args-limit) + (list-bind #t (e*) + (let-values ([(e e* nc*) (log-partition logor 0 e*)]) + (bind #t ([t (fold-left (lambda (e1 e2) (%inline logor ,e1 ,e2)) e e*)]) + `(if ,(%type-check mask-fixnum type-fixnum ,t) + ,t + ,(case (length nc*) + [(1) (build-libcall #t src sexpr op (car nc*) `(immediate ,(fix 0)))] + [(2) (build-libcall #t src sexpr op (car nc*) (cadr nc*))] + ; TODO: need fxargerr library routine w/who arg & rest interface + [else `(call ,(make-info-call src sexpr #f #t #t) #f ,(Symref 'op) ,nc* (... ...))]))))))) ; NB: should be error call---but is it? + (define-inline 2 op + [() `(immediate ,(fix 0))] + [e* (go src sexpr e*)]))])) + (fxlogorop fxlogor) + (fxlogorop fxlogior) + (fxlogorop fxior)) + (let () ; level 2 fxlogand, ... + (define-syntax fxlogop + (syntax-rules () + [(_ op inline-op base) + (define-inline 2 op + [() `(immediate ,(fix base))] + [e* (and (fx<= (length e*) (fx- inline-args-limit 1)) + (list-bind #t (e*) + ;; NB: using inline-op here because it works when target's + ;; NB: fixnum range is larger than the host's fixnum range + ;; NB: during cross compile + (let-values ([(e e* nc*) (log-partition inline-op base e*)]) + `(if ,(build-fixnums? nc*) + ,(fold-left (lambda (e1 e2) (%inline inline-op ,e1 ,e2)) e e*) + ; TODO: need fxargerr library routine w/who arg & rest interface + ,(case (length nc*) + [(1) (build-libcall #t src sexpr op (car nc*) `(immediate ,(fix 0)))] + [(2) (build-libcall #t src sexpr op (car nc*) (cadr nc*))] + ; TODO: need fxargerr library routine w/who arg & rest interface + [else `(call ,(make-info-call src sexpr #f #t #t) #f ,(Symref 'op) ,nc* (... ...))])))))])])) ; NB: should be error call---but is it? + (fxlogop fxlogand logand -1) + (fxlogop fxand logand -1) + (fxlogop fxlogxor logxor 0) + (fxlogop fxxor logxor 0))) + (define-inline 3 fxlogtest + [(e1 e2) (%inline logtest ,e1 ,e2)]) + (define-inline 2 fxlogtest + [(e1 e2) + (bind #t (e1 e2) + `(if ,(build-fixnums? (list e1 e2)) + ,(%inline logtest ,e1 ,e2) + ,(build-libcall #t src sexpr fxlogtest e1 e2)))]) + (let () + (define xorbits (lognot (constant mask-fixnum))) + (define-syntax fxlognotop + (syntax-rules () + [(_ name) + (begin + (define-inline 3 name + [(e) (%inline logxor ,e (immediate ,xorbits))]) + (define-inline 2 name + [(e) (bind #t (e) + `(if ,(%type-check mask-fixnum type-fixnum ,e) + ,(%inline logxor ,e (immediate ,xorbits)) + ,(build-libcall #t src sexpr name e)))]))])) + (fxlognotop fxlognot) + (fxlognotop fxnot)) + (define-inline 3 $fxu< + [(e1 e2) (or (relop-length RELOP< e1 e2) + (%inline u< ,e1 ,e2))]) + (define-inline 3 fx+ + [() `(immediate 0)] + [(e) (ensure-single-valued e)] + [(e1 e2) (%inline + ,e1 ,e2)] + [(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+? + [(e1 e2) + (let ([Lfalse (make-local-label 'Lfalse)]) + (bind #t (e1 e2) + `(if ,(build-fixnums? (list e1 e2)) + ,(bind #f ([t (%inline +/ovfl ,e1 ,e2)]) + `(if (inline ,(make-info-condition-code 'overflow #f #t) ,%condition-code) + (label ,Lfalse ,(%constant sfalse)) + ,t)) + (goto ,Lfalse))))]) + (let () + (define (go src sexpr e1 e2) + (let ([Llib (make-local-label 'Llib)]) + (bind #t (e1 e2) + `(if ,(build-fixnums? (list e1 e2)) + ,(bind #f ([t (%inline +/ovfl ,e1 ,e2)]) + `(if (inline ,(make-info-condition-code 'overflow #f #t) ,%condition-code) + (label ,Llib ,(build-libcall #t src sexpr fx+ e1 e2)) + ,t)) + (goto ,Llib))))) + (define-inline 2 fx+ + [() `(immediate 0)] + [(e) + (bind #t (e) + `(if ,(%type-check mask-fixnum type-fixnum ,e) + ,e + ,(build-libcall #t #f sexpr fx+ e `(immediate ,(fix 0)))))] + [(e1 e2) (go src sexpr e1 e2)] + ; TODO: 3-operand case requires 3-operand library routine + #;[(e1 e2 e3) + (let ([Llib (make-local-label 'Llib)]) + (bind #t (e1 e2 e3) + `(if ,(build-fixnums? (list e1 e2 e3)) + ,(bind #t ([t (%inline +/ovfl ,e1 ,e2)]) + `(if (inline ,(make-info-condition-code 'overflow #f #t) ,%condition-code) + (label ,Llib ,(build-libcall #t src sexpr fx+ e1 e2 e3)) + ,(bind #t ([t (%inline +/ovfl ,t ,e3)]) + `(if (inline ,(make-info-condition-code 'overflow #f #t) ,%condition-code) + (goto ,Llib) + ,t)))) + (goto ,Llib))))] + [(e1 . e*) #f]) + (define-inline 2 r6rs:fx+ ; limited to two arguments + [(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)] + [(e1 e2) (%inline - ,e1 ,e2)] + [(e1 . e*) (reduce src sexpr moi e1 e*)]) + (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-? + [(e1 e2) + (let ([Lfalse (make-local-label 'Lfalse)]) + (bind #t (e1 e2) + `(if ,(build-fixnums? (list e1 e2)) + ,(bind #f ([t (%inline -/ovfl ,e1 ,e2)]) + `(if (inline ,(make-info-condition-code 'overflow #f #t) ,%condition-code) + (label ,Lfalse ,(%constant sfalse)) + ,t)) + (goto ,Lfalse))))]) + (let () + (define (go src sexpr e1 e2) + (let ([Llib (make-local-label 'Llib)]) + (bind #t (e1 e2) + `(if ,(build-fixnums? (list e1 e2)) + ,(bind #t ([t (%inline -/ovfl ,e1 ,e2)]) + `(if (inline ,(make-info-condition-code 'overflow #f #t) ,%condition-code) + (label ,Llib ,(build-libcall #t src sexpr fx- e1 e2)) + ,t)) + (goto ,Llib))))) + (define-inline 2 fx- + [(e) (go src sexpr `(immediate ,(fix 0)) e)] + [(e1 e2) (go src sexpr e1 e2)] + ; TODO: 3-operand case requires 3-operand library routine + #;[(e1 e2 e3) + (let ([Llib (make-local-label 'Llib)]) + (bind #t (e1 e2 e3) + `(if ,(build-fixnums? (list e1 e2 e3)) + ,(bind #t ([t (%inline -/ovfl ,e1 ,e2)]) + `(if (inline ,(make-info-condition-code 'overflow #f #t) ,%condition-code) + (label ,Llib ,(build-libcall #t src sexpr fx- e1 e2 e3)) + ,(bind #t ([t (%inline -/ovfl ,t ,e3)]) + `(if (inline ,(make-info-condition-code 'overflow #f #t) ,%condition-code) + (goto ,Llib) + ,t)))) + (goto ,Llib))))] + [(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)]) + (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) + `(if ,(build-fixnums? (list e)) + ,(bind #t ([t (%inline -/ovfl ,e (immediate ,(fix 1)))]) + `(if (inline ,(make-info-condition-code 'overflow #f #t) ,%condition-code) + (label ,Llib ,(build-libcall #t src sexpr fx1- e)) + ,t)) + (goto ,Llib))))]) + (define-inline 2 fx1+ + [(e) (let ([Llib (make-local-label 'Llib)]) + (bind #t (e) + `(if ,(build-fixnums? (list e)) + ,(bind #f ([t (%inline +/ovfl ,e (immediate ,(fix 1)))]) + `(if (inline ,(make-info-condition-code 'overflow #f #t) ,%condition-code) + (label ,Llib ,(build-libcall #t src sexpr fx1+ e)) + ,t)) + (goto ,Llib))))]) + + (let () + (define fixnum-powers-of-two + (let f ([m 2] [e 1]) + (if (<= m (constant most-positive-fixnum)) + (cons (cons m e) (f (* m 2) (fx+ e 1))) + '()))) + (define-inline 3 fxdiv + [(e1 e2) + (nanopass-case (L7 Expr) e2 + [(quote ,d) + (let ([a (assv d fixnum-powers-of-two)]) + (and a + (%inline logand + ,(%inline sra ,e1 (immediate ,(cdr a))) + (immediate ,(- (constant fixnum-factor))))))] + [else #f])]) + (define-inline 3 fxmod + [(e1 e2) + (nanopass-case (L7 Expr) e2 + [(quote ,d) + (let ([a (assv d fixnum-powers-of-two)]) + (and a (%inline logand ,e1 (immediate ,(fix (- d 1))))))] + [else #f])]) + (let () + (define (build-fx* e1 e2 ovfl?) + (define (fx*-constant e n) + (if ovfl? + (%inline */ovfl ,e (immediate ,n)) + (cond + [(eqv? n 1) e] + [(eqv? n -1) (%inline - (immediate 0) ,e)] + [(eqv? n 2) (%inline sll ,e (immediate 1))] + [(eqv? n 3) + (bind #t (e) + (%inline + + ,(%inline + ,e ,e) + ,e))] + [(eqv? n 10) + (bind #t (e) + (%inline + + ,(%inline + + ,(%inline sll ,e (immediate 3)) + ,e) + ,e))] + [(assv n fixnum-powers-of-two) => + (lambda (a) (%inline sll ,e (immediate ,(cdr a))))] + [else (%inline * ,e (immediate ,n))]))) + (nanopass-case (L7 Expr) e2 + [(quote ,d) (guard (target-fixnum? d)) (fx*-constant e1 d)] + [else + (nanopass-case (L7 Expr) e1 + [(quote ,d) (guard (target-fixnum? d)) (fx*-constant e2 d)] + [else + (let ([t (make-tmp 't 'uptr)]) + `(let ([,t ,(build-unfix e2)]) + ,(if ovfl? + (%inline */ovfl ,e1 ,t) + (%inline * ,e1 ,t))))])])) + (define-inline 3 fx* + [() `(immediate ,(fix 1))] + [(e) (ensure-single-valued e)] + [(e1 e2) (build-fx* e1 e2 #f)] + [(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)]) + (bind #t (e1 e2) + `(if ,(build-fixnums? (list e1 e2)) + ,(bind #t ([t (build-fx* e1 e2 #t)]) + `(if (inline ,(make-info-condition-code 'multiply-overflow #f #t) ,%condition-code) + (label ,Llib ,(build-libcall #t src sexpr fx* e1 e2)) + ,t)) + (goto ,Llib))))) + (define-inline 2 fx* + [() `(immediate ,(fix 1))] + [(e) + (bind #t (e) + `(if ,(%type-check mask-fixnum type-fixnum ,e) + ,e + ,(build-libcall #t src sexpr fx* e `(immediate ,(fix 0)))))] + [(e1 e2) (go src sexpr e1 e2)] + ; TODO: 3-operand case requires 3-operand library routine + #;[(e1 e2 e3) + (let ([Llib (make-local-label 'Llib)]) + (bind #t (e1 e2 e3) + `(if ,(build-fixnums? (list e1 e2 e3)) + ,(bind #t ([t (build-fx* e1 e2 #t)]) + `(if (inline ,(make-info-condition-code 'overflow #f #t) ,%condition-code) + (label ,Llib ,(build-libcall #t src sexpr fx* e1 e2 e3)) + ,(bind #t ([t (build-fx* t e3 #t)]) + `(if (inline ,(make-info-condition-code 'overflow #f #t) ,%condition-code) + (goto ,Llib) + ,t)))) + (goto ,Llib))))] + [(e1 . e*) #f]) + (define-inline 2 r6rs:fx* ; limited to two arguments + [(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) + (bind #t (e1) + (build-fix + (%inline sra + ,(%inline + ,e1 + ,(%inline srl + ,(if (fx= p2 1) + e1 + (%inline sra ,e1 (immediate ,(fx- p2 1)))) + (immediate ,(fx- (constant fixnum-bits) p2)))) + (immediate ,(fx+ p2 (constant fixnum-offset)))))))) + + (define build-fx/ + (lambda (src sexpr e1 e2) + (or (nanopass-case (L7 Expr) e2 + [(quote ,d) + (let ([a (assv d fixnum-powers-of-two)]) + (and a (build-fx/p2 e1 (cdr a))))] + [else #f]) + (if (constant integer-divide-instruction) + (build-fix (%inline / ,e1 ,e2)) + `(call ,(make-info-call src sexpr #f #f #f) #f + ,(lookup-primref 3 '$fx/) + ,e1 ,e2))))) + + (define-inline 3 fx/ + [(e) (build-fx/ src sexpr `(quote 1) e)] + [(e1 e2) (build-fx/ src sexpr e1 e2)] + [(e1 . e*) (reduce src sexpr moi e1 e*)]) + + (define-inline 3 fxquotient + [(e) (build-fx/ src sexpr `(quote 1) e)] + [(e1 e2) (build-fx/ src sexpr e1 e2)] + [(e1 . e*) (reduce src sexpr moi e1 e*)]) + + (define-inline 3 fxremainder + [(e1 e2) + (bind #t (e1 e2) + (%inline - ,e1 + ,(build-fx* + (build-fx/ src sexpr e1 e2) + e2 #f)))])) + (let () + (define-syntax build-fx + (lambda (x) + (syntax-case x () + [(_ op a1 a2) + #`(%inline op + #,(if (number? (syntax->datum #'a1)) + #`(immediate a1) + #`,a1) + #,(if (number? (syntax->datum #'a2)) + #`(immediate a2) + #`,a2))]))) + (define (build-popcount16 e) + (constant-case popcount-instruction + [(#t) (build-fix (%inline popcount ,e))] ; no unfix needed, since not specialized to 16-bit + [else + (let ([x (make-tmp 'x 'uptr)] + [x2 (make-tmp 'x2 'uptr)] + [x3 (make-tmp 'x3 'uptr)] + [x4 (make-tmp 'x4 'uptr)]) + `(let ([,x ,(build-unfix e)]) + (let ([,x2 ,(build-fx - x (build-fx logand (build-fx srl x 1) #x5555))]) + (let ([,x3 ,(build-fx + (build-fx logand x2 #x3333) (build-fx logand (build-fx srl x2 2) #x3333))]) + (let ([,x4 ,(build-fx logand (build-fx + x3 (build-fx srl x3 4)) #x0f0f)]) + ,(build-fix (build-fx logand (build-fx + x4 (build-fx srl x4 8)) #x1f)))))))])) + (define (build-popcount32 e) + (constant-case popcount-instruction + [(#t) (build-fix (%inline popcount ,e))] ; no unfix needed, since not specialized to 32-bit + [else + (let ([x (make-tmp 'x 'uptr)] + [x2 (make-tmp 'x2 'uptr)] + [x3 (make-tmp 'x3 'uptr)] + [x4 (make-tmp 'x4 'uptr)]) + `(let ([,x ,(build-unfix e)]) + (let ([,x2 ,(build-fx - x (build-fx logand (build-fx srl x 1) #x55555555))]) + (let ([,x3 ,(build-fx + (build-fx logand x2 #x33333333) (build-fx logand (build-fx srl x2 2) #x33333333))]) + (let ([,x4 ,(build-fx logand (build-fx + x3 (build-fx srl x3 4)) #x0f0f0f0f)]) + ,(build-fix (build-fx logand (build-fx srl (build-fx * x4 #x01010101) 24) #x3f)))))))])) + (define (build-popcount e) + (constant-case popcount-instruction + [(#t) (build-fix (%inline popcount ,e))] ; no unfix needed + [else + (constant-case ptr-bits + [(32) (build-popcount32 e)] + [(64) + (let ([x (make-tmp 'x 'uptr)] + [x2 (make-tmp 'x2 'uptr)] + [x3 (make-tmp 'x3 'uptr)] + [x4 (make-tmp 'x4 'uptr)] + [x5 (make-tmp 'x5 'uptr)]) + `(let ([,x ,e]) ; no unfix needed + (let ([,x2 ,(build-fx - x (build-fx logand (build-fx srl x 1) #x5555555555555555))]) + (let ([,x3 ,(build-fx + (build-fx logand x2 #x3333333333333333) (build-fx logand (build-fx srl x2 2) #x3333333333333333))]) + (let ([,x4 ,(build-fx logand (build-fx + x3 (build-fx srl x3 4)) #x0f0f0f0f0f0f0f0f)]) + (let ([,x5 ,(build-fx logand (build-fx + x4 (build-fx srl x4 8)) #x00ff00ff00ff00ff)]) + ,(build-fix (build-fx logand (build-fx srl (build-fx * x5 #x0101010101010101) 56) #x7f))))))))])])) + (define-inline 3 fxpopcount + [(e) + (bind #f (e) + (build-popcount e))]) + (define-inline 2 fxpopcount + [(e) + (bind #t (e) + `(if ,(build-and + (%type-check mask-fixnum type-fixnum ,e) + (%inline >= ,e (immediate ,0))) + ,(build-popcount e) + ,(build-libcall #t #f sexpr fxpopcount e)))]) + (define-inline 3 fxpopcount32 + [(e) + (bind #f (e) + (build-popcount32 e))]) + (define-inline 2 fxpopcount32 + [(e) + (bind #t (e) + `(if ,(constant-case ptr-bits + [(32) + (build-and (%type-check mask-fixnum type-fixnum ,e) + (%inline >= ,e (immediate ,0)))] + [(64) + (build-and (%type-check mask-fixnum type-fixnum ,e) + (%inline u< ,e (immediate ,(fix #x100000000))))]) + ,(build-popcount32 e) + ,(build-libcall #t #f sexpr fxpopcount32 e)))]) + (define-inline 3 fxpopcount16 + [(e) + (bind #f (e) + (build-popcount16 e))]) + (define-inline 2 fxpopcount16 + [(e) + (bind #f (e) + `(if ,(build-and + (%type-check mask-fixnum type-fixnum ,e) + (%inline u< ,e (immediate ,(fix #x10000)))) + ,(build-popcount16 e) + ,(build-libcall #t #f sexpr fxpopcount16 e)))])))) + (let () + (define do-fxsll + (lambda (e1 e2) + (nanopass-case (L7 Expr) e2 + [(quote ,d) + (%inline sll ,e1 (immediate ,d))] + [else + ; TODO: bind-uptr might be handy here and also a make-unfix + (let ([t (make-tmp 't 'uptr)]) + `(let ([,t ,(build-unfix e2)]) + ,(%inline sll ,e1 ,t)))]))) + (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) + (%inline logand + ,(nanopass-case (L7 Expr) e2 + [(quote ,d) + (%inline srl ,e1 (immediate ,d))] + [else + (let ([t (make-tmp 't 'uptr)]) + `(let ([,t ,(build-unfix e2)]) + ,(%inline srl ,e1 ,t)))]) + (immediate ,(fx- (constant fixnum-factor))))]) + (let () + (define do-fxsra + (lambda (e1 e2) + (%inline logand + ,(nanopass-case (L7 Expr) e2 + [(quote ,d) + (%inline sra ,e1 (immediate ,d))] + [else + (let ([t (make-tmp 't 'uptr)]) + `(let ([,t ,(build-unfix e2)]) + ,(%inline sra ,e1 ,t)))]) + (immediate ,(fx- (constant fixnum-factor)))))) + (define-inline 3 fxsra + [(e1 e2) (do-fxsra e1 e2)]) + (define-inline 3 fxarithmetic-shift-right + [(e1 e2) (do-fxsra e1 e2)])) + (let () + (define-syntax %safe-shift + (syntax-rules () + [(_ src sexpr op libcall e1 e2 ?size) + (let ([size ?size]) + (if (constant? (lambda (x) (and (fixnum? x) (fx<= 0 x (fx- size 1)))) e2) + (bind #t (e1 e2) + `(if ,(build-fixnums? (list e1)) + ,(%inline logand + ,(%inline op ,e1 (immediate ,(constant-value e2))) + (immediate ,(- (constant fixnum-factor)))) + ,(build-libcall #t src sexpr libcall e1 e2))) + (bind #t (e1 e2) + `(if ,(build-and + (build-fixnums? (list e1 e2)) + (%inline u< ,e2 (immediate ,(fix size)))) + ,(%inline logand + ,(%inline op ,e1 ,(build-unfix e2)) + (immediate ,(- (constant fixnum-factor)))) + ,(build-libcall #t src sexpr libcall e1 e2)))))])) + (define-inline 2 fxsrl + [(e1 e2) (%safe-shift src sexpr srl fxsrl e1 e2 (+ (constant fixnum-bits) 1))]) + (define-inline 2 fxsra + [(e1 e2) (%safe-shift src sexpr sra fxsra e1 e2 (+ (constant fixnum-bits) 1))]) + (define-inline 2 fxarithmetic-shift-right + [(e1 e2) (%safe-shift src sexpr sra fxarithmetic-shift-right e1 e2 (constant fixnum-bits))])) + (define-inline 3 fxarithmetic-shift + [(e1 e2) + (or (nanopass-case (L7 Expr) e2 + [(quote ,d) + (and (fixnum? d) + (if ($fxu< d (constant fixnum-bits)) + (%inline sll ,e1 (immediate ,d)) + (and (fx< (fx- (constant fixnum-bits)) d 0) + (%inline logand + ,(%inline sra ,e1 (immediate ,(fx- d))) + (immediate ,(- (constant fixnum-factor)))))))] + [else #f]) + (build-libcall #f src sexpr fxarithmetic-shift e1 e2))]) + (define-inline 2 fxarithmetic-shift + [(e1 e2) + (or (nanopass-case (L7 Expr) e2 + [(quote ,d) + (guard (fixnum? d) (fx< (fx- (constant fixnum-bits)) d 0)) + (bind #t (e1) + `(if ,(build-fixnums? (list e1)) + ,(%inline logand + ,(%inline sra ,e1 (immediate ,(fx- d))) + (immediate ,(- (constant fixnum-factor)))) + ,(build-libcall #t src sexpr fxarithmetic-shift e1 e2)))] + [else #f]) + (build-libcall #f src sexpr fxarithmetic-shift e1 e2))]) + (let () + (define dofxlogbit0 + (lambda (e1 e2) + (if (constant? (lambda (x) (and (fixnum? x) ($fxu< x (fx- (constant fixnum-bits) 1)))) e2) + (%inline logand ,e1 + (immediate ,(fix (lognot (ash 1 (constant-value e2)))))) + (%inline logand ,e1 + ,(%inline lognot + ,(%inline sll (immediate ,(fix 1)) + ,(build-unfix e2))))))) + (define dofxlogbit1 + (lambda (e1 e2) + (if (constant? (lambda (x) (and (fixnum? x) ($fxu< x (fx- (constant fixnum-bits) 1)))) e2) + (%inline logor ,e1 + (immediate ,(fix (ash 1 (constant-value e2))))) + (%inline logor ,e1 + ,(%inline sll (immediate ,(fix 1)) + ,(build-unfix e2)))))) + (define-inline 3 fxlogbit0 + [(e1 e2) (dofxlogbit0 e2 e1)]) + (define-inline 3 fxlogbit1 + [(e1 e2) (dofxlogbit1 e2 e1)]) + (define-inline 3 fxcopy-bit + [(e1 e2 e3) + ;; NB: even in the case where e3 is not known to be 0 or 1, seems like we could do better here. + (and (fixnum-constant? e3) + (case (constant-value e3) + [(0) (dofxlogbit0 e1 e2)] + [(1) (dofxlogbit1 e1 e2)] + [else #f]))])) + (let () + (define dofxlogbit0 + (lambda (e1 e2 libcall) + (if (constant? (lambda (x) (and (fixnum? x) ($fxu< x (fx- (constant fixnum-bits) 1)))) e2) + (bind #t (e1) + `(if ,(build-fixnums? (list e1)) + ,(%inline logand ,e1 + (immediate ,(fix (lognot (ash 1 (constant-value e2)))))) + ,(libcall e1 e2))) + (bind #t (e1 e2) + `(if ,(build-and + (build-fixnums? (list e1 e2)) + (%inline u< ,e2 (immediate ,(fix (fx- (constant fixnum-bits) 1))))) + ,(%inline logand ,e1 + ,(%inline lognot + ,(%inline sll (immediate ,(fix 1)) + ,(build-unfix e2)))) + ,(libcall e1 e2)))))) + (define dofxlogbit1 + (lambda (e1 e2 libcall) + (if (constant? (lambda (x) (and (fixnum? x) ($fxu< x (fx- (constant fixnum-bits) 1)))) e2) + (bind #t (e1) + `(if ,(build-fixnums? (list e1)) + ,(%inline logor ,e1 + (immediate ,(fix (ash 1 (constant-value e2))))) + ,(libcall e1 e2))) + (bind #t (e1 e2) + `(if ,(build-and + (build-fixnums? (list e1 e2)) + (%inline u< ,e2 (immediate ,(fix (fx- (constant fixnum-bits) 1))))) + ,(%inline logor ,e1 + ,(%inline sll (immediate ,(fix 1)) + ,(build-unfix e2))) + ,(libcall e1 e2)))))) + (define-inline 2 fxlogbit0 + [(e1 e2) (dofxlogbit0 e2 e1 + (lambda (e2 e1) + (build-libcall #t src sexpr fxlogbit0 e1 e2)))]) + (define-inline 2 fxlogbit1 + [(e1 e2) (dofxlogbit1 e2 e1 + (lambda (e2 e1) + (build-libcall #t src sexpr fxlogbit1 e1 e2)))]) + (define-inline 2 fxcopy-bit + [(e1 e2 e3) + (and (fixnum-constant? e3) + (case (constant-value e3) + [(0) (dofxlogbit0 e1 e2 + (lambda (e1 e2) + (build-libcall #t src sexpr fxcopy-bit e1 e2)))] + [(1) (dofxlogbit1 e1 e2 + (lambda (e1 e2) + (build-libcall #t src sexpr fxcopy-bit e1 e2)))] + [else #f]))])) + (define-inline 3 fxzero? + [(e) (or (relop-length RELOP= e) (%inline eq? ,e (immediate 0)))]) + (define-inline 3 fxpositive? + [(e) (or (relop-length RELOP> e) (%inline > ,e (immediate 0)))]) + (define-inline 3 fxnonnegative? + [(e) (or (relop-length RELOP>= e) (%inline >= ,e (immediate 0)))]) + (define-inline 3 fxnegative? + [(e) (or (relop-length RELOP< e) (%inline < ,e (immediate 0)))]) + (define-inline 3 fxnonpositive? + [(e) (or (relop-length RELOP<= e) (%inline <= ,e (immediate 0)))]) + (define-inline 3 fxeven? + [(e) (%inline eq? + ,(%inline logand ,e (immediate ,(fix 1))) + (immediate ,(fix 0)))]) + (define-inline 3 fxodd? + [(e) (%inline eq? + ,(%inline logand ,e (immediate ,(fix 1))) + (immediate ,(fix 1)))]) + + (define-inline 2 fxzero? + [(e) (or (relop-length RELOP= e) + (bind #t (e) + (build-simple-or + (%inline eq? ,e (immediate 0)) + `(if ,(build-fixnums? (list e)) + ,(%constant sfalse) + ,(build-libcall #t src sexpr fxzero? e)))))]) + (define-inline 2 fxpositive? + [(e) (or (relop-length RELOP> e) + (bind #t (e) + `(if ,(build-fixnums? (list e)) + ,(%inline > ,e (immediate 0)) + ,(build-libcall #t src sexpr fxpositive? e))))]) + (define-inline 2 fxnonnegative? + [(e) (or (relop-length RELOP>= e) + (bind #t (e) + `(if ,(build-fixnums? (list e)) + ,(%inline >= ,e (immediate 0)) + ,(build-libcall #t src sexpr fxnonnegative? e))))]) + (define-inline 2 fxnegative? + [(e) (or (relop-length RELOP< e) + (bind #t (e) + `(if ,(build-fixnums? (list e)) + ,(%inline < ,e (immediate 0)) + ,(build-libcall #t src sexpr fxnegative? e))))]) + (define-inline 2 fxnonpositive? + [(e) (or (relop-length RELOP<= e) + (bind #t (e) + `(if ,(build-fixnums? (list e)) + ,(%inline <= ,e (immediate 0)) + ,(build-libcall #t src sexpr fxnonpositive? e))))]) + (define-inline 2 fxeven? + [(e) (bind #t (e) + `(if ,(build-fixnums? (list e)) + ,(%inline eq? + ,(%inline logand ,e (immediate ,(fix 1))) + (immediate ,(fix 0))) + ,(build-libcall #t src sexpr fxeven? e)))]) + (define-inline 2 fxodd? + [(e) (bind #t (e) + `(if ,(build-fixnums? (list e)) + ,(%inline eq? + ,(%inline logand ,e (immediate ,(fix 1))) + (immediate ,(fix 1))) + ,(build-libcall #t src sexpr fxodd? e)))]) + (let () + (define dofxlogbit? + (lambda (e1 e2) + (cond + [(constant? (lambda (x) (and (fixnum? x) (fx<= 0 x (fx- (constant fixnum-bits) 2)))) e1) + (%inline logtest ,e2 (immediate ,(fix (ash 1 (constant-value e1)))))] + [(constant? (lambda (x) (and (target-fixnum? x) (> x (fx- (constant fixnum-bits) 2)))) e1) + (%inline < ,e2 (immediate ,(fix 0)))] + [(fixnum-constant? e2) + (bind #t (e1) + `(if ,(%inline < (immediate ,(fix (fx- (constant fixnum-bits) 2))) ,e1) + ,(if (< (constant-value e2) 0) (%constant strue) (%constant sfalse)) + ,(%inline logtest + ,(%inline sra ,e2 ,(build-unfix e1)) + (immediate ,(fix 1)))))] + [else + (bind #t (e1 e2) + `(if ,(%inline < (immediate ,(fix (fx- (constant fixnum-bits) 2))) ,e1) + ,(%inline < ,e2 (immediate ,(fix 0))) + ,(%inline logtest + ,(%inline sra ,e2 ,(build-unfix e1)) + (immediate ,(fix 1)))))]))) + + (define-inline 3 fxbit-set? + [(e1 e2) (dofxlogbit? e2 e1)]) + + (define-inline 3 fxlogbit? + [(e1 e2) (dofxlogbit? e1 e2)])) + + (let () + (define dofxlogbit? + (lambda (e1 e2 libcall) + (cond + [(constant? (lambda (x) (and (fixnum? x) (fx<= 0 x (fx- (constant fixnum-bits) 2)))) e1) + (bind #t (e2) + `(if ,(build-fixnums? (list e2)) + ,(%inline logtest ,e2 + (immediate ,(fix (ash 1 (constant-value e1))))) + ,(libcall e1 e2)))] + [(constant? (lambda (x) (and (target-fixnum? x) (> x (fx- (constant fixnum-bits) 2)))) e1) + (bind #t (e2) + `(if ,(build-fixnums? (list e2)) + ,(%inline < ,e2 (immediate ,(fix 0))) + ,(libcall e1 e2)))] + [else + (bind #t (e1 e2) + `(if ,(build-and + (build-fixnums? (list e1 e2)) + (%inline u< ,e1 (immediate ,(fix (constant fixnum-bits))))) + ,(%inline logtest + ,(%inline sra ,e2 ,(build-unfix e1)) + (immediate ,(fix 1))) + ,(libcall e1 e2)))]))) + + (define-inline 2 fxbit-set? + [(e1 e2) (dofxlogbit? e2 e1 + (lambda (e2 e1) + (build-libcall #t src sexpr fxbit-set? e1 e2)))]) + (define-inline 2 fxlogbit? + [(e1 e2) (dofxlogbit? e1 e2 + (lambda (e1 e2) + (build-libcall #t src sexpr fxlogbit? e1 e2)))])) + + ; can avoid if in fxabs with: + ; t = sra(x, k) ; where k is ptr-bits - 1 + ; ; t is now -1 if x's sign bit set, otherwise 0 + ; x = xor(x, t) ; logical not if x negative, otherwise leave x alone + ; x = x - t ; add 1 to complete two's complement negation if + ; ; x was negative, otherwise leave x alone + ; tests on i3le indicate that the if is actually faster, even in a loop + ; where input alternates between positive and negative to defeat branch + ; prediction. + (define-inline 3 fxabs + [(e) (bind #t (e) + `(if ,(%inline < ,e (immediate ,(fix 0))) + ,(%inline - (immediate ,(fix 0)) ,e) + ,e))]) + + ;(define-inline 3 min ; needs library min + ; ; must take care to be inexactness-preserving + ; [(e0) e0] + ; [(e0 e1) + ; (bind #t (e0 e1) + ; `(if ,(build-fixnums? (list e0 e1)) + ; (if ,(%inline < ,e0 ,e1) ,e0 ,e1) + ; ,(build-libcall #t src sexpr min e0 e1)))] + ; [(e0 . e*) (reduce src sexpr moi e1 e*)]) + ; + ;(define-inline 3 max ; needs library max + ; ; must take care to be inexactness-preserving + ; [(e0) e0] + ; [(e0 e1) + ; (bind #t (e0 e1) + ; `(if ,(build-fixnums? (list e0 e1)) + ; (if ,(%inline < ,e0 ,e1) ,e0 ,e1) + ; ,(build-libcall #t src sexpr max e0 e1)))] + ; [(e1 . e*) (reduce src sexpr moi e1 e*)]) + + (define-inline 3 fxmin + [(e) (ensure-single-valued e)] + [(e1 e2) (bind #t (e1 e2) + `(if ,(%inline < ,e1 ,e2) + ,e1 + ,e2))] + [(e1 . e*) (reduce src sexpr moi e1 e*)]) + + (define-inline 3 fxmax + [(e) (ensure-single-valued e)] + [(e1 e2) (bind #t (e1 e2) + `(if ,(%inline < ,e2 ,e1) + ,e1 + ,e2))] + [(e1 . e*) (reduce src sexpr moi e1 e*)]) + + (define-inline 3 fxif + [(e1 e2 e3) + (bind #t (e1) + (%inline logor + ,(%inline logand ,e2 ,e1) + ,(%inline logand ,e3 + ,(%inline lognot ,e1))))]) + + (define-inline 3 fxbit-field + [(e1 e2 e3) + (and (constant? fixnum? e2) (constant? fixnum? e3) + (let ([start (constant-value e2)] [end (constant-value e3)]) + (if (fx= end start) + (%seq ,e1 (immediate ,(fix 0))) + (and (and (fx>= start 0) (fx> end start) (fx< end (constant fixnum-bits))) + (extract-unsigned-bitfield #f start end e1)))))]) + + (define-inline 3 fxcopy-bit-field + [(e1 e2 e3 e4) + (and (constant? fixnum? e2) (constant? fixnum? e3) + (let ([start (constant-value e2)] [end (constant-value e3)]) + (if (fx= end start) + e1 + (and (and (fx>= start 0) (fx> end start) (fx< end (constant fixnum-bits))) + (insert-bitfield #f start end (constant fixnum-bits) e1 e4)))))]) + + ;; could be done with one mutable variable instead of two, but this seems to generate + ;; the same code as the existing compiler + (define-inline 3 fxlength + [(e) + (let ([t (make-assigned-tmp 't 'uptr)] [result (make-assigned-tmp 'result)]) + `(let ([,t ,(build-unfix e)]) + (seq + (if ,(%inline < ,t (immediate 0)) + (set! ,t ,(%inline lognot ,t)) + ,(%constant svoid)) + (let ([,result (immediate ,(fix 0))]) + ,((lambda (body) + (constant-case fixnum-bits + [(30) body] + [(61) + `(seq + (if ,(%inline < ,t (immediate #x100000000)) + ,(%constant svoid) + (seq + (set! ,t ,(%inline srl ,t (immediate 32))) + (set! ,result + ,(%inline + ,result (immediate ,(fix 32)))))) + ,body)])) + (%seq + (if ,(%inline < ,t (immediate #x10000)) + ,(%constant svoid) + (seq + (set! ,t ,(%inline srl ,t (immediate 16))) + (set! ,result ,(%inline + ,result (immediate ,(fix 16)))))) + (if ,(%inline < ,t (immediate #x100)) + ,(%constant svoid) + (seq + (set! ,t ,(%inline srl ,t (immediate 8))) + (set! ,result ,(%inline + ,result (immediate ,(fix 8)))))) + ,(%inline + ,result + (inline ,(make-info-load 'unsigned-8 #f) ,%load + ,(%tc-ref fxlength-bv) ,t + ,(%constant bytevector-data-disp)))))))))]) + + (define-inline 3 fxfirst-bit-set + [(e) + (let ([t (make-assigned-tmp 't 'uptr)] [result (make-assigned-tmp 'result)]) + (bind #t (e) + `(if ,(%inline eq? ,e (immediate ,(fix 0))) + (immediate ,(fix -1)) + (let ([,t ,(build-unfix e)] [,result (immediate ,(fix 0))]) + ,((lambda (body) + (constant-case fixnum-bits + [(30) body] + [(61) + `(seq + (if ,(%inline logtest ,t (immediate #xffffffff)) + ,(%constant svoid) + (seq + (set! ,t ,(%inline srl ,t (immediate 32))) + (set! ,result ,(%inline + ,result (immediate ,(fix 32)))))) + ,body)])) + (%seq + (if ,(%inline logtest ,t (immediate #xffff)) + ,(%constant svoid) + (seq + (set! ,t ,(%inline srl ,t (immediate 16))) + (set! ,result ,(%inline + ,result (immediate ,(fix 16)))))) + (if ,(%inline logtest ,t (immediate #xff)) + ,(%constant svoid) + (seq + (set! ,t ,(%inline srl ,t (immediate 8))) + (set! ,result ,(%inline + ,result (immediate ,(fix 8)))))) + ,(%inline + ,result + (inline ,(make-info-load 'unsigned-8 #f) ,%load + ,(%tc-ref fxfirst-bit-set-bv) + ,(%inline logand ,t (immediate #xff)) + ,(%constant bytevector-data-disp)))))))))]) + + (let () + (define-syntax type-pred + (syntax-rules () + [(_ name? mask type) + (define-inline 2 name? + [(e) (%type-check mask type ,e)])])) + (define-syntax typed-object-pred + (syntax-rules () + [(_ name? mask type) + (define-inline 2 name? + [(e) + (bind #t (e) + (%typed-object-check mask type ,e))])])) + (type-pred boolean? mask-boolean type-boolean) + (type-pred bwp-object? mask-bwp sbwp) + (type-pred char? mask-char type-char) + (type-pred eof-object? mask-eof seof) + (type-pred fixnum? mask-fixnum type-fixnum) + (type-pred flonum? mask-flonum type-flonum) + (type-pred null? mask-nil snil) + (type-pred pair? mask-pair type-pair) + (type-pred procedure? mask-closure type-closure) + (type-pred symbol? mask-symbol type-symbol) + (type-pred $unbound-object? mask-unbound sunbound) + (typed-object-pred bignum? mask-bignum type-bignum) + (typed-object-pred box? mask-box type-box) + (typed-object-pred mutable-box? mask-mutable-box type-mutable-box) + (typed-object-pred immutable-box? mask-mutable-box type-immutable-box) + (typed-object-pred bytevector? mask-bytevector type-bytevector) + (typed-object-pred mutable-bytevector? mask-mutable-bytevector type-mutable-bytevector) + (typed-object-pred immutable-bytevector? mask-mutable-bytevector type-immutable-bytevector) + (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 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) + (typed-object-pred input-port? mask-input-port type-input-port) + (typed-object-pred output-port? mask-output-port type-output-port) + (typed-object-pred port? mask-port type-port) + (typed-object-pred ratnum? mask-ratnum type-ratnum) + (typed-object-pred $record? mask-record type-record) + (typed-object-pred string? mask-string type-string) + (typed-object-pred mutable-string? mask-mutable-string type-mutable-string) + (typed-object-pred immutable-string? mask-mutable-string type-immutable-string) + (typed-object-pred $system-code? mask-system-code type-system-code) + (typed-object-pred $tlc? mask-tlc type-tlc) + (typed-object-pred vector? mask-vector type-vector) + (typed-object-pred mutable-vector? mask-mutable-vector type-mutable-vector) + (typed-object-pred immutable-vector? mask-mutable-vector type-immutable-vector) + (typed-object-pred stencil-vector? mask-stencil-vector type-stencil-vector) + (typed-object-pred thread? mask-thread type-thread)) + (define-inline 3 $bigpositive? + [(e) (%type-check mask-signed-bignum type-positive-bignum + ,(%mref ,e ,(constant bignum-type-disp)))]) + (define-inline 3 csv7:record-field-accessible? + [(e1 e2) (%seq ,e1 ,e2 ,(%constant strue))]) + + (define-inline 2 cflonum? + [(e) (bind #t (e) + `(if ,(%type-check mask-flonum type-flonum ,e) + ,(%constant strue) + ,(%typed-object-check mask-inexactnum type-inexactnum ,e)))]) + (define-inline 2 $immediate? + [(e) (bind #t (e) (%type-check mask-immediate type-immediate ,e))]) + (define-inline 3 $fixmediate + [(e) e]) + + (define-inline 3 $inexactnum-real-part + [(e) (build-$inexactnum-real-part e)]) + (define-inline 3 $inexactnum-imag-part + [(e) (build-$inexactnum-imag-part e)]) + + (define-inline 3 cfl-real-part + [(e) (bind #t (e) + `(if ,(%type-check mask-flonum type-flonum ,e) + ,e + ,(build-$inexactnum-real-part e)))]) + + (define-inline 3 cfl-imag-part + [(e) (bind #t (e) + `(if ,(%type-check mask-flonum type-flonum ,e) + (quote 0.0) + ,(build-$inexactnum-imag-part e)))]) + + (define-inline 3 $closure-ref + [(e-v e-i) + (nanopass-case (L7 Expr) e-i + [(quote ,d) + (guard (target-fixnum? d)) + (%mref ,e-v ,(+ (fix d) (constant closure-data-disp)))] + [else (%mref ,e-v ,e-i ,(constant closure-data-disp))])]) + (define-inline 3 $closure-set! + [(e-v e-i e-new) + (nanopass-case (L7 Expr) e-i + [(quote ,d) + (guard (target-fixnum? d)) + (build-dirty-store e-v (+ (fix d) (constant closure-data-disp)) e-new)] + [else (build-dirty-store e-v e-i (constant closure-data-disp) e-new)])]) + (define-inline 3 $closure-code + [(e) (%inline - + ,(%mref ,e ,(constant closure-code-disp)) + ,(%constant code-data-disp))]) + (define-inline 3 $code-free-count + [(e) (build-fix (%mref ,e ,(constant code-closure-length-disp)))]) + (define-inline 3 $code-mutable-closure? + [(e) (%typed-object-check mask-code-mutable-closure type-code-mutable-closure ,e)]) + (define-inline 3 $code-arity-in-closure? + [(e) (%typed-object-check mask-code-arity-in-closure type-code-arity-in-closure ,e)]) + (define-inline 3 $code-single-valued? + [(e) (%typed-object-check mask-code-single-valued type-code-single-valued ,e)]) + (define-inline 2 $unbound-object + [() `(quote ,($unbound-object))]) + (define-inline 2 void + [() `(quote ,(void))]) + (define-inline 2 eof-object + [() `(quote #!eof)]) + (define-inline 2 cons + [(e1 e2) + (bind #f (e1 e2) + (bind #t ([t (%constant-alloc type-pair (constant size-pair))]) + (%seq + (set! ,(%mref ,t ,(constant pair-car-disp)) ,e1) + (set! ,(%mref ,t ,(constant pair-cdr-disp)) ,e2) + ,t)))]) + (define-inline 2 box + [(e) + (bind #f (e) + (bind #t ([t (%constant-alloc type-typed-object (constant size-box))]) + (%seq + (set! ,(%mref ,t ,(constant box-type-disp)) ,(%constant type-box)) + (set! ,(%mref ,t ,(constant box-ref-disp)) ,e) + ,t)))]) + (define-inline 2 box-immutable + [(e) + (bind #f (e) + (bind #t ([t (%constant-alloc type-typed-object (constant size-box))]) + (%seq + (set! ,(%mref ,t ,(constant box-type-disp)) ,(%constant type-immutable-box)) + (set! ,(%mref ,t ,(constant box-ref-disp)) ,e) + ,t)))]) + (define-inline 3 $make-tlc + [(e-ht e-keyval e-next) + (bind #f (e-ht e-keyval e-next) + (bind #t ([t (%constant-alloc type-typed-object (constant size-tlc))]) + (%seq + (set! ,(%mref ,t ,(constant tlc-type-disp)) ,(%constant type-tlc)) + (set! ,(%mref ,t ,(constant tlc-ht-disp)) ,e-ht) + (set! ,(%mref ,t ,(constant tlc-keyval-disp)) ,e-keyval) + (set! ,(%mref ,t ,(constant tlc-next-disp)) ,e-next) + ,t)))]) + (define-inline 2 list + [e* (build-list e*)]) + (let () + (define (go e e*) + (bind #f (e) + (list-bind #f (e*) + (bind #t ([t (%constant-alloc type-pair (fx* (constant size-pair) (length e*)))]) + (let loop ([e e] [e* e*] [i 0]) + (let ([e2 (car e*)] [e* (cdr e*)]) + `(seq + (set! ,(%mref ,t ,(fx+ i (constant pair-car-disp))) ,e) + ,(if (null? e*) + `(seq + (set! ,(%mref ,t ,(fx+ i (constant pair-cdr-disp))) ,e2) + ,t) + (let ([next-i (fx+ i (constant size-pair))]) + `(seq + (set! ,(%mref ,t ,(fx+ i (constant pair-cdr-disp))) + ,(%inline + ,t (immediate ,next-i))) + ,(loop e2 e* next-i))))))))))) + (define-inline 2 list* + [(e) (ensure-single-valued e)] + [(e . e*) (go e e*)]) + (define-inline 2 cons* + [(e) (ensure-single-valued e)] + [(e . e*) (go e e*)])) + (define-inline 2 vector + [() `(quote #())] + [e* + (let ([n (length e*)]) + (list-bind #f (e*) + (bind #t ([t (%constant-alloc type-typed-object + (fx+ (constant header-size-vector) (fx* n (constant ptr-bytes))))]) + (let loop ([e* e*] [i 0]) + (if (null? e*) + `(seq + (set! ,(%mref ,t ,(constant vector-type-disp)) + (immediate ,(+ (fx* n (constant vector-length-factor)) + (constant type-vector)))) + ,t) + `(seq + (set! ,(%mref ,t ,(fx+ i (constant vector-data-disp))) ,(car e*)) + ,(loop (cdr e*) (fx+ i (constant ptr-bytes)))))))))]) + (let () + (define (go e*) + (let ([n (length e*)]) + (list-bind #f (e*) + (bind #t ([t (%constant-alloc type-typed-object + (fx+ (constant header-size-fxvector) (fx* n (constant ptr-bytes))))]) + (let loop ([e* e*] [i 0]) + (if (null? e*) + `(seq + (set! ,(%mref ,t ,(constant fxvector-type-disp)) + (immediate ,(+ (fx* n (constant fxvector-length-factor)) + (constant type-fxvector)))) + ,t) + `(seq + (set! ,(%mref ,t ,(fx+ i (constant fxvector-data-disp))) ,(car e*)) + ,(loop (cdr e*) (fx+ i (constant ptr-bytes)))))))))) + (define-inline 2 fxvector + [() `(quote #vfx())] + [e* (and (andmap (lambda (x) (constant? target-fixnum? x)) e*) (go e*))]) + (define-inline 3 fxvector + [() `(quote #vfx())] + [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-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*) + `(seq + (set! ,(%mref ,t ,(constant string-type-disp)) + (immediate ,(+ (fx* n (constant string-length-factor)) + (constant type-string)))) + ,t) + `(seq + (inline ,(make-info-load (string-char-type) #f) ,%store ,t ,%zero + (immediate ,(fx+ i (constant string-data-disp))) + ,(car e*)) + ,(loop (cdr e*) (fx+ i (constant string-char-bytes)))))))))) + (define-inline 2 string + [() `(quote "")] + [e* (and (andmap (lambda (x) (constant? char? x)) e*) (go e*))]) + (define-inline 3 string + [() `(quote "")] + [e* (go e*)])) + (let () ; level 2 car, cdr, caar, etc. + (define-syntax def-c..r* + (lambda (x) + (define (go ad*) + (let ([id (datum->syntax #'* (string->symbol (format "c~{~a~}r" ad*)))]) + #`(define-inline 2 #,id + [(e) (let ([Lerr (make-local-label 'Lerr)]) + #,(let f ([ad* ad*]) + (let ([builder (if (char=? (car ad*) #\a) #'build-car #'build-cdr)] + [ad* (cdr ad*)]) + (if (null? ad*) + #`(bind #t (e) + `(if ,(build-pair? e) + ,(#,builder e) + (label ,Lerr ,(build-libcall #t src sexpr #,id e)))) + #`(bind #t ([t #,(f ad*)]) + `(if ,(build-pair? t) + ,(#,builder t) + (goto ,Lerr)))))))]))) + (let f ([n 4] [ad* '()]) + (let ([f (lambda (ad*) + (let ([defn (go ad*)]) + (if (fx= n 1) + defn + #`(begin #,defn #,(f (fx- n 1) ad*)))))]) + #`(begin + #,(f (cons #\a ad*)) + #,(f (cons #\d ad*))))))) + def-c..r*) + (let () ; level 3 car, cdr, caar, etc. + (define-syntax def-c..r* + (lambda (x) + (define (go ad*) + (let ([id (datum->syntax #'* (string->symbol (format "c~{~a~}r" ad*)))]) + #`(define-inline 3 #,id + [(e) #,(let f ([ad* ad*]) + (let ([builder (if (char=? (car ad*) #\a) #'build-car #'build-cdr)] + [ad* (cdr ad*)]) + (if (null? ad*) + #`(#,builder e) + #`(#,builder #,(f ad*)))))]))) + (let f ([n 4] [ad* '()]) + (let ([f (lambda (ad*) + (let ([defn (go ad*)]) + (if (fx= n 1) + defn + #`(begin #,defn #,(f (fx- n 1) ad*)))))]) + #`(begin + #,(f (cons #\a ad*)) + #,(f (cons #\d ad*))))))) + def-c..r*) + (let () ; level 3 simple accessors, e.g., unbox, vector-length + (define-syntax inline-accessor + (syntax-rules () + [(_ prim disp) + (define-inline 3 prim + [(e) (%mref ,e ,(constant disp))])])) + (inline-accessor unbox box-ref-disp) + (inline-accessor $symbol-name symbol-name-disp) + (inline-accessor $symbol-property-list symbol-plist-disp) + (inline-accessor $system-property-list symbol-splist-disp) + (inline-accessor $symbol-hash symbol-hash-disp) + (inline-accessor $ratio-numerator ratnum-numerator-disp) + (inline-accessor $ratio-denominator ratnum-denominator-disp) + (inline-accessor $exactnum-real-part exactnum-real-disp) + (inline-accessor $exactnum-imag-part exactnum-imag-disp) + (inline-accessor binary-port-input-buffer port-ibuffer-disp) + (inline-accessor textual-port-input-buffer port-ibuffer-disp) + (inline-accessor binary-port-output-buffer port-obuffer-disp) + (inline-accessor textual-port-output-buffer port-obuffer-disp) + (inline-accessor $code-name code-name-disp) + (inline-accessor $code-arity-mask code-arity-mask-disp) + (inline-accessor $code-info code-info-disp) + (inline-accessor $code-pinfo* code-pinfo*-disp) + (inline-accessor $continuation-link continuation-link-disp) + (inline-accessor $continuation-winders continuation-winders-disp) + (inline-accessor $continuation-attachments continuation-attachments-disp) + (inline-accessor csv7:record-type-descriptor record-type-disp) + (inline-accessor $record-type-descriptor record-type-disp) + (inline-accessor record-rtd record-type-disp) + (inline-accessor record-type-uid record-type-uid-disp) + (inline-accessor $port-handler port-handler-disp) + (inline-accessor $port-info port-info-disp) + (inline-accessor port-name port-name-disp) + (inline-accessor $thread-tc thread-tc-disp) + ) + (constant-case architecture + [(pb) + ;; Don't try to inline seginfo access, because the C pointer size used + ;; in the table may not match the 64-bit `ptr` size + (void)] + [else + (let () + (define (build-seginfo maybe? object? e) + (let ([ptr (make-assigned-tmp 'ptr)] + [seginfo (make-assigned-tmp 'seginfo)]) + (define (build-level-3 seginfo k) + (constant-case segment-table-levels + [(3) + (let ([s3 (make-assigned-tmp 's3)]) + `(let ([,s3 ,(%mref ,seginfo + ,(%inline sll ,(%inline srl ,ptr (immediate ,(+ (constant segment-t1-bits) + (constant segment-t2-bits)))) + (immediate ,(constant log2-ptr-bytes))) + ,0)]) + ,(if maybe? + `(if ,(%inline eq? ,s3 (immediate 0)) + (immediate 0) + ,(k s3)) + (k s3))))] + [else (k seginfo)])) + (define (build-level-2 s3 k) + (constant-case segment-table-levels + [(2 3) + (let ([s2 (make-assigned-tmp 's2)]) + `(let ([,s2 ,(%mref ,s3 ,(%inline logand + ,(%inline srl ,ptr (immediate ,(fx- (constant segment-t1-bits) + (constant log2-ptr-bytes)))) + (immediate ,(fxsll (fx- (fxsll 1 (constant segment-t2-bits)) 1) + (constant log2-ptr-bytes)))) + 0)]) + ,(if maybe? + `(if ,(%inline eq? ,s2 (immediate 0)) + (immediate 0) + ,(k s2)) + (k s2))))] + [else (k s3)])) + `(let ([,ptr ,(%inline srl ,(if object? + (%inline + ,e (immediate ,(fx- (constant typemod) 1))) + e) + (immediate ,(constant segment-offset-bits)))]) + (let ([,seginfo (literal ,(make-info-literal #f 'entry (lookup-c-entry segment-info) 0))]) + ,(build-level-3 seginfo + (lambda (s3) + (build-level-2 s3 + (lambda (s2) + (%mref ,s2 ,(%inline sll ,(%inline logand ,ptr + (immediate ,(fx- (fxsll 1 (constant segment-t1-bits)) 1))) + (immediate ,(constant log2-ptr-bytes))) + 0))))))))) + (define (build-space-test e space) + `(if ,(%type-check mask-fixnum type-fixnum ,e) + ,(%constant sfalse) + (if ,(%type-check mask-immediate type-immediate ,e) + ,(%constant sfalse) + ,(let ([s-e (build-seginfo #t #t e)] + [si (make-assigned-tmp 'si)]) + `(let ([,si ,s-e]) + (if ,(%inline eq? ,si (immediate 0)) + ,(%constant sfalse) + ,(let ([s `(inline ,(make-info-load 'unsigned-8 #f) ,%load ,si ,%zero (immediate 0))]) + (%inline eq? (immediate ,space) ,s)))))))) + + (define-inline 2 $maybe-seginfo + [(e) + (bind #t (e) + `(if ,(%type-check mask-fixnum type-fixnum ,e) + ,(%constant sfalse) + (if ,(%type-check mask-immediate type-immediate ,e) + ,(%constant sfalse) + ,(let ([s-e (build-seginfo #t #t e)] + [si (make-assigned-tmp 'si)]) + `(let ([,si ,s-e]) + (if ,(%inline eq? ,si (immediate 0)) + ,(%constant sfalse) + ,si))))))]) + (define-inline 2 $seginfo + [(e) + (bind #t (e) (build-seginfo #f #t e))]) + (define-inline 2 $seginfo-generation + [(e) + (bind #f (e) (build-object-ref #f 'unsigned-8 e %zero (constant seginfo-generation-disp)))]) + (define-inline 2 $seginfo-space + [(e) + (bind #f (e) + (build-object-ref #f 'unsigned-8 e %zero (constant seginfo-space-disp)))]) + (define-inline 2 $list-bits-ref + [(e) + (bind #t (e) + (let ([si (make-assigned-tmp 'si)] + [list-bits (make-assigned-tmp 'list-bits)] + [offset (make-assigned-tmp 'offset)] + [byte (make-assigned-tmp 'byte)]) + `(let ([,si ,(build-seginfo #f #t e)]) + (let ([,list-bits ,(%mref ,si ,(constant seginfo-list-bits-disp))]) + (if ,(%inline eq? ,list-bits (immediate 0)) + (immediate 0) + (let ([,offset ,(%inline srl ,(%inline logand ,(%inline + ,e (immediate ,(fx- (constant typemod) 1))) + (immediate ,(fx- (constant bytes-per-segment) 1))) + (immediate ,(constant log2-ptr-bytes)))]) + (let ([,byte (inline ,(make-info-load 'unsigned-8 #f) ,%load ,list-bits ,%zero ,(%inline srl ,offset (immediate 3)))]) + ,(build-fix (%inline logand ,(%inline srl ,byte ,(%inline logand ,offset (immediate 7))) + (immediate ,(constant list-bits-mask)))))))))))]) + (define-inline 2 $generation + [(e) + (bind #t (e) + `(if ,(%type-check mask-fixnum type-fixnum ,e) + ,(%constant sfalse) + ,(let ([s-e (build-seginfo #t #t e)] + [si (make-assigned-tmp 'si)]) + `(let ([,si ,s-e]) + (if ,(%inline eq? ,si (immediate 0)) + ,(%constant sfalse) + ,(build-object-ref #f 'unsigned-8 si %zero 1))))))]) + (define-inline 2 weak-pair? + [(e) (bind #t (e) (build-space-test e (constant space-weakpair)))]) + (define-inline 2 ephemeron-pair? + [(e) (bind #t (e) (build-space-test e (constant space-ephemeron)))]) + (define-inline 2 reference-bytevector? + [(e) (bind #t (e) (build-space-test e (constant space-reference-array)))]))]) + + (define-inline 2 unbox + [(e) + (bind #t (e) + `(if ,(%typed-object-check mask-box type-box ,e) + ,(%mref ,e ,(constant box-ref-disp)) + ,(build-libcall #t src sexpr unbox e)))]) + (let () + (define-syntax def-len + (syntax-rules () + [(_ prim type-disp length-offset) + (define-inline 3 prim + [(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) + (def-len stencil-vector-mask stencil-vector-type-disp stencil-vector-mask-offset)) + (let () + (define-syntax def-len + (syntax-rules () + [(_ prim mask type type-disp length-offset) + (define-inline 2 prim + [(e) (let ([Lerr (make-local-label 'Lerr)]) + (bind #t (e) + `(if ,(%type-check mask-typed-object type-typed-object ,e) + ,(bind #t ([t/l (%mref ,e ,(constant type-disp))]) + `(if ,(%type-check mask type ,t/l) + ,(extract-length t/l (constant length-offset)) + (goto ,Lerr))) + (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)) + ; TODO: consider adding integer-valued?, rational?, rational-valued?, + ; real?, and real-valued? + (define-inline 2 integer? + [(e) (bind #t (e) + (build-simple-or + (%type-check mask-fixnum type-fixnum ,e) + (build-simple-or + (%typed-object-check mask-bignum type-bignum ,e) + (build-and + (%type-check mask-flonum type-flonum ,e) + `(call ,(make-info-call src sexpr #f #f #f) #f ,(lookup-primref 3 'flinteger?) ,e)))))]) + (let () + (define build-number? + (lambda (e) + (bind #t (e) + (build-simple-or + (%type-check mask-fixnum type-fixnum ,e) + (build-simple-or + (%type-check mask-flonum type-flonum ,e) + (build-and + (%type-check mask-typed-object type-typed-object ,e) + (%type-check mask-other-number type-other-number + ,(%mref ,e ,(constant bignum-type-disp))))))))) + (define-inline 2 number? + [(e) (build-number? e)]) + (define-inline 2 complex? + [(e) (build-number? e)])) + (define-inline 3 set-car! + [(e1 e2) (build-dirty-store e1 (constant pair-car-disp) e2)]) + (define-inline 3 set-cdr! + [(e1 e2) (build-dirty-store e1 (constant pair-cdr-disp) e2)]) + (define-inline 3 set-box! + [(e1 e2) (build-dirty-store e1 (constant box-ref-disp) e2)]) + (define-inline 3 box-cas! + [(e1 e2 e3) + (bind #t (e2) + (build-dirty-store e1 %zero (constant box-ref-disp) e3 (make-build-cas e2) build-cas-seq))]) + (define-inline 3 $set-symbol-name! + [(e1 e2) (build-dirty-store e1 (constant symbol-name-disp) e2)]) + (define-inline 3 $set-symbol-property-list! + [(e1 e2) (build-dirty-store e1 (constant symbol-plist-disp) e2)]) + (define-inline 3 $set-system-property-list! + [(e1 e2) (build-dirty-store e1 (constant symbol-splist-disp) e2)]) + (define-inline 3 $set-port-info! + [(e1 e2) (build-dirty-store e1 (constant port-info-disp) e2)]) + (define-inline 3 set-port-name! + [(e1 e2) (build-dirty-store e1 (constant port-name-disp) e2)]) + (define-inline 2 set-box! + [(e-box e-new) + (bind #t (e-box) + (dirty-store-bind #t (e-new) + `(if ,(%typed-object-check mask-mutable-box type-mutable-box ,e-box) + ,(build-dirty-store e-box (constant box-ref-disp) e-new) + ,(build-libcall #t src sexpr set-box! e-box e-new))))]) + (define-inline 2 box-cas! + [(e-box e-old e-new) + (bind #t (e-box e-old) + (dirty-store-bind #t (e-new) + `(if ,(%typed-object-check mask-mutable-box type-mutable-box ,e-box) + ,(build-dirty-store e-box %zero (constant box-ref-disp) e-new (make-build-cas e-old) build-cas-seq) + ,(build-libcall #t src sexpr box-cas! e-box e-old e-new))))]) + (define-inline 2 set-car! + [(e-pair e-new) + (bind #t (e-pair) + (dirty-store-bind #t (e-new) + `(if ,(%type-check mask-pair type-pair ,e-pair) + ,(build-dirty-store e-pair (constant pair-car-disp) e-new) + ,(build-libcall #t src sexpr set-car! e-pair e-new))))]) + (define-inline 2 set-cdr! + [(e-pair e-new) + (bind #t (e-pair) + (dirty-store-bind #t (e-new) + `(if ,(%type-check mask-pair type-pair ,e-pair) + ,(build-dirty-store e-pair (constant pair-cdr-disp) e-new) + ,(build-libcall #t src sexpr set-cdr! e-pair e-new))))]) + (define-inline 3 $set-symbol-hash! + ; no need for dirty store---e2 should be a fixnum + [(e1 e2) `(set! ,(%mref ,e1 ,(constant symbol-hash-disp)) ,e2)]) + (define-inline 2 memory-order-acquire + [() (if-feature pthreads + (constant-case architecture + [(arm32 arm64) (%seq ,(%inline acquire-fence) (quote ,(void)))] + [else `(quote ,(void))]) + `(quote ,(void)))]) + (define-inline 2 memory-order-release + [() (if-feature pthreads + (constant-case architecture + [(arm32 arm64) (%seq ,(%inline release-fence) (quote ,(void)))] + [else `(quote ,(void))]) + `(quote ,(void)))]) + (let () + (define-syntax define-tlc-parameter + (syntax-rules () + [(_ name disp) + (define-inline 3 name + [(e-x) (%mref ,e-x ,(constant disp))])] + [(_ name name! disp) + (begin + (define-tlc-parameter name disp) + (define-inline 3 name! + [(e-x e-new) (build-dirty-store e-x (constant disp) e-new)]))])) + (define-tlc-parameter $tlc-keyval tlc-keyval-disp) + (define-tlc-parameter $tlc-ht tlc-ht-disp) + (define-tlc-parameter $tlc-next $set-tlc-next! tlc-next-disp)) + (define-inline 2 $top-level-value + [(e) (nanopass-case (L7 Expr) e + [(quote ,d) + (guard (symbol? d)) + (if (any-set? (prim-mask (or primitive system)) ($sgetprop d '*flags* 0)) + (Symref d) + (bind #t (e) + (bind #t ([t (%mref ,e ,(constant symbol-value-disp))]) + `(if ,(%type-check mask-unbound sunbound ,t) + ,(build-libcall #t #f sexpr $top-level-value e) + ,t))))] + [else + (bind #t (e) + (let ([Lfail (make-local-label 'tlv-fail)]) + `(if ,(%type-check mask-symbol type-symbol ,e) + ,(bind #t ([t (%mref ,e ,(constant symbol-value-disp))]) + `(if ,(%type-check mask-unbound sunbound ,t) + (goto ,Lfail) + ,t)) + (label ,Lfail ,(build-libcall #t #f sexpr $top-level-value e)))))])]) + (define-inline 3 $top-level-value + [(e) (nanopass-case (L7 Expr) e + [(quote ,d) (guard (symbol? d)) (Symref d)] + [else (%mref ,e ,(constant symbol-value-disp))])]) + (let () + (define (go e-sym e-value) + (bind #t (e-sym) + `(seq + ,(build-dirty-store e-sym (constant symbol-value-disp) e-value) + (set! ,(%mref ,e-sym ,(constant symbol-pvalue-disp)) + (literal + ,(make-info-literal #f 'library + (lookup-libspec nonprocedure-code) + (constant code-data-disp))))))) + (define-inline 3 $set-top-level-value! + [(e-sym e-value) (go e-sym e-value)]) + (define-inline 2 $set-top-level-value! + [(e-sym e-value) (and (constant? symbol? e-sym) (go e-sym e-value))])) + (define-inline 3 $top-level-bound? + [(e-sym) + (build-not + (%type-check mask-unbound sunbound + ,(nanopass-case (L7 Expr) e-sym + [(quote ,d) (guard (symbol? d)) (Symref d)] + [else (%mref ,e-sym ,(constant symbol-value-disp))])))]) + (let () + (define parse-format + (lambda (who src cntl-arg args) + (nanopass-case (L7 Expr) cntl-arg + [(quote ,d) + (guard (c [(and (assertion-violation? c) + (format-condition? c) + (message-condition? c) + (irritants-condition? c)) + ($source-warning 'compile + src #t + "~? in call to ~s" + (condition-message c) + (condition-irritants c) + who) + #f]) + (#%$parse-format-string who d (length args)))] + [else #f]))) + (define fmt->expr + ($make-fmt->expr + (lambda (d) `(quote ,d)) + (lambda (e1 e2) `(seq ,e1 ,e2)) + (lambda (src sexpr prim arg*) + `(call ,(make-info-call src sexpr #f #f #f) #f + ,(lookup-primref 3 prim) + ,arg* ...)))) + (define build-format + (lambda (who src sexpr op-arg cntl-arg arg*) + (let ([x (parse-format who src cntl-arg arg*)]) + (and x + (cond + [(and (fx= (length x) 1) + (string? (car x)) + (nanopass-case (L7 Expr) op-arg + [(quote ,d) (eq? d #f)] + [else #f])) + (%primcall src sexpr string-copy (quote ,(car x)))] + [(and (nanopass-case (L7 Expr) op-arg + [(quote ,d) (not (eq? d #f))] + [else #t]) + (let-values ([(op-arg dobind) (binder #t 'ptr op-arg)] + [(arg* dobind*) (list-binder #t 'ptr arg*)]) + (let ([e (fmt->expr src sexpr x op-arg arg*)]) + (and e (dobind (dobind* e))))))] + [else + (%primcall src sexpr $dofmt (quote ,who) ,op-arg ,cntl-arg + (quote ,x) + ,(build-list arg*))]))))) + (define-inline 2 errorf + [(e-who e-str . e*) + (parse-format 'errorf src e-str e*) + `(seq (pariah) (call ,(make-info-call src sexpr #f #t #t) #f ,(Symref 'errorf) ,e-who ,e-str ,e* ...))]) + (define-inline 2 assertion-violationf + [(e-who e-str . e*) + (parse-format 'assertion-violationf src e-str e*) + `(seq (pariah) (call ,(make-info-call src sexpr #f #t #t) #f ,(Symref 'assertion-violationf) ,e-who ,e-str ,e* ...))]) + (define-inline 2 $oops + [(e-who e-str . e*) + (parse-format '$oops src e-str e*) + `(seq (pariah) (call ,(make-info-call src sexpr #f #t #t) #f ,(Symref '$oops) ,e-who ,e-str ,e* ...))]) + (define-inline 2 $impoops + [(e-who e-str . e*) + (parse-format '$impoops src e-str e*) + `(seq (pariah) (call ,(make-info-call src sexpr #f #t #t) #f ,(Symref '$impoops) ,e-who ,e-str ,e* ...))]) + (define-inline 2 warningf + [(e-who e-str . e*) + (parse-format 'warningf src e-str e*) + `(seq (pariah) (call ,(make-info-call src sexpr #f #t #f) #f ,(Symref 'warningf) ,e-who ,e-str ,e* ...))]) + (define-inline 2 $source-violation + [(e-who e-src e-start? e-str . e*) + (parse-format '$source-violation src e-str e*) + `(seq (pariah) (call ,(make-info-call src sexpr #f #t #t) #f ,(Symref '$source-violation) + ,e-who ,e-src ,e-start? ,e-str ,e* ...))]) + (define-inline 2 $source-warning + [(e-who e-src e-start? e-str . e*) + (parse-format '$source-warning src e-str e*) + `(seq (pariah) (call ,(make-info-call src sexpr #f #t #f) #f ,(Symref '$source-warning) + ,e-who ,e-src ,e-start? ,e-str ,e* ...))]) + (define-inline 2 fprintf + [(e-op e-str . e*) + (parse-format 'fprintf src e-str e*) + #f]) + (define-inline 3 fprintf + [(e-op e-str . e*) (build-format 'fprintf src sexpr e-op e-str e*)]) + (define-inline 2 printf + [(e-str . e*) + (build-format 'printf src sexpr (%tc-ref current-output) e-str e*)]) + (define-inline 2 format + [(e . e*) + (nanopass-case (L7 Expr) e + [(quote ,d) + (if (string? d) + (build-format 'format src sexpr `(quote #f) e e*) + (and (not (null? e*)) + (cond + [(eq? d #f) (build-format 'format src sexpr e (car e*) (cdr e*))] + [(eq? d #t) (build-format 'format src sexpr + (%tc-ref current-output) + (car e*) (cdr e*))] + [else #f])))] + [else #f])])) + (let () + (define hand-coded-closure? + (lambda (name) + (not (memq name '(nuate nonprocedure-code error-invoke invoke + $wrapper-apply wrapper-apply arity-wrapper-apply + popcount-slow cpu-features))))) + (define-inline 2 $hand-coded + [(name) + (nanopass-case (L7 Expr) name + [(quote ,d) + (guard (symbol? d)) + (let ([l (make-local-label 'hcl)]) + (set! new-l* (cons l new-l*)) + (set! new-le* (cons (with-output-language (L9 CaseLambdaExpr) `(hand-coded ,d)) new-le*)) + (if (hand-coded-closure? d) + `(literal ,(make-info-literal #f 'closure l 0)) + `(label-ref ,l 0)))] + [(seq (profile ,src) ,[e]) `(seq (profile ,src) ,e)] + [else ($oops '$hand-coded "~s is not a quoted symbol" name)])])) + (define-inline 2 $tc + [() %tc]) + (define-inline 3 $tc-field + [(e-fld e-tc) + (nanopass-case (L7 Expr) e-fld + [(quote ,d) + (let () + (define-syntax a + (lambda (x) + #`(case d + #,@(fold-left + (lambda (ls field) + (apply + (lambda (name type disp len) + (if (eq? type 'ptr) + (cons + (with-syntax ([name (datum->syntax #'* name)]) + #'[(name) (%tc-ref ,e-tc name)]) + ls) + ls)) + field)) + '() (getprop 'tc '*fields* '())) + [else #f]))) + a)] + [else #f])] + [(e-fld e-tc e-val) + (nanopass-case (L7 Expr) e-fld + [(quote ,d) + (let () + (define-syntax a + (lambda (x) + #`(case d + #,@(fold-left + (lambda (ls field) + (apply + (lambda (name type disp len) + (if (eq? type 'ptr) + (cons + (with-syntax ([name (datum->syntax #'* name)]) + #'[(name) `(set! ,(%tc-ref ,e-tc name) ,e-val)]) + ls) + ls)) + field)) + '() (getprop 'tc '*fields* '())) + [else #f]))) + a)] + [else #f])]) + (let () + (define-syntax define-tc-parameter + (syntax-rules () + [(_ name tc-name) + (begin + (define-inline 2 name + [() (%tc-ref tc-name)] + [(x) #f]) + (define-inline 3 name + [() (%tc-ref tc-name)] + [(x) `(set! ,(%tc-ref tc-name) ,x)]))])) + + (define-tc-parameter current-input-port current-input) + (define-tc-parameter current-output-port current-output) + (define-tc-parameter current-error-port current-error) + (define-tc-parameter generate-inspector-information generate-inspector-information) + (define-tc-parameter generate-procedure-source-information generate-procedure-source-information) + (define-tc-parameter generate-profile-forms generate-profile-forms) + (define-tc-parameter $compile-profile compile-profile) + (define-tc-parameter optimize-level optimize-level) + (define-tc-parameter subset-mode subset-mode) + (define-tc-parameter $suppress-primitive-inlining suppress-primitive-inlining) + (define-tc-parameter $block-counter block-counter) + (define-tc-parameter $sfd sfd) + (define-tc-parameter $current-mso current-mso) + (define-tc-parameter $target-machine target-machine) + (define-tc-parameter $current-stack-link stack-link) + (define-tc-parameter $current-winders winders) + (define-tc-parameter $current-attachments attachments) + (define-tc-parameter default-record-equal-procedure default-record-equal-procedure) + (define-tc-parameter default-record-hash-procedure default-record-hash-procedure) + ) + + (let () + (define (make-wrapper-closure-alloc e-proc e-arity-mask e-data libspec) + (bind #t ([c (%constant-alloc type-closure (fx* (if e-data 4 3) (constant ptr-bytes)))]) + (%seq + (set! ,(%mref ,c ,(constant closure-code-disp)) + (literal ,(make-info-literal #f 'library libspec (constant code-data-disp)))) + (set! ,(%mref ,c ,(constant closure-data-disp)) ,e-proc) + (set! ,(%mref ,c ,(fx+ (constant ptr-bytes) (constant closure-data-disp))) ,e-arity-mask) + ,(if e-data + (%seq + (set! ,(%mref ,c ,(fx+ (fx* (constant ptr-bytes) 2) (constant closure-data-disp))) ,e-data) + ,c) + c)))) + (define-inline 3 $make-wrapper-procedure + [(e-proc e-arity-mask) + (bind #f (e-proc e-arity-mask) + (make-wrapper-closure-alloc e-proc e-arity-mask #f (lookup-libspec $wrapper-apply)))]) + (define-inline 3 make-wrapper-procedure + [(e-proc e-arity-mask e-data) + (bind #f (e-proc e-arity-mask e-data) + (make-wrapper-closure-alloc e-proc e-arity-mask e-data (lookup-libspec wrapper-apply)))]) + (define-inline 3 make-arity-wrapper-procedure + [(e-proc e-arity-mask e-data) + (bind #f (e-proc e-arity-mask e-data) + (make-wrapper-closure-alloc e-proc e-arity-mask e-data (lookup-libspec arity-wrapper-apply)))])) + + (define-inline 3 $install-guardian + [(e-obj e-rep e-tconc ordered?) + (bind #f (e-obj e-rep e-tconc ordered?) + (bind #t ([t (%constant-alloc type-untyped (constant size-guardian-entry))]) + (%seq + (set! ,(%mref ,t ,(constant guardian-entry-obj-disp)) ,e-obj) + (set! ,(%mref ,t ,(constant guardian-entry-rep-disp)) ,e-rep) + (set! ,(%mref ,t ,(constant guardian-entry-tconc-disp)) ,e-tconc) + (set! ,(%mref ,t ,(constant guardian-entry-next-disp)) ,(%tc-ref guardian-entries)) + (set! ,(%mref ,t ,(constant guardian-entry-ordered?-disp)) ,ordered?) + (set! ,(%mref ,t ,(constant guardian-entry-pending-disp)) ,(%constant snil)) + (set! ,(%tc-ref guardian-entries) ,t))))]) + + (define-inline 3 $install-ftype-guardian + [(e-obj e-tconc) + (bind #f (e-obj e-tconc) + (bind #t ([t (%constant-alloc type-untyped (constant size-guardian-entry))]) + (%seq + (set! ,(%mref ,t ,(constant guardian-entry-obj-disp)) ,e-obj) + (set! ,(%mref ,t ,(constant guardian-entry-rep-disp)) (immediate ,(constant ftype-guardian-rep))) + (set! ,(%mref ,t ,(constant guardian-entry-tconc-disp)) ,e-tconc) + (set! ,(%mref ,t ,(constant guardian-entry-next-disp)) ,(%tc-ref guardian-entries)) + (set! ,(%mref ,t ,(constant guardian-entry-ordered?-disp)) ,(%constant sfalse)) + (set! ,(%mref ,t ,(constant guardian-entry-pending-disp)) ,(%constant snil)) + (set! ,(%tc-ref guardian-entries) ,t))))]) + + (define-inline 2 guardian? + [(e) + (bind #t (e) + (build-and + (%type-check mask-closure type-closure ,e) + (%type-check mask-guardian-code type-guardian-code + ,(%mref + ,(%inline - + ,(%mref ,e ,(constant closure-code-disp)) + ,(%constant code-data-disp)) + ,(constant code-type-disp)))))]) + + (define-inline 3 $make-phantom-bytevector + [() + (bind #f () + (bind #t ([t (%constant-alloc type-typed-object (constant size-phantom))]) + (%seq + (set! ,(%mref ,t ,(constant phantom-type-disp)) + ,(%constant type-phantom)) + (set! ,(%mref ,t ,(constant phantom-length-disp)) + (immediate 0)) + ,t)))]) + + (define-inline 3 phantom-bytevector-length + [(e-ph) + (bind #f (e-ph) + (unsigned->ptr (%mref ,e-ph ,(constant phantom-length-disp)) + (constant ptr-bits)))]) + + (define-inline 2 virtual-register-count + [() `(quote ,(constant virtual-register-count))]) + (let () + (define constant-ref + (lambda (e-idx) + (nanopass-case (L7 Expr) e-idx + [(quote ,d) + (guard (and (fixnum? d) ($fxu< d (constant virtual-register-count)))) + (%mref ,%tc ,(fx+ (constant tc-virtual-registers-disp) (fx* d (constant ptr-bytes))))] + [else #f]))) + (define constant-set + (lambda (e-idx e-val) + (let ([ref (constant-ref e-idx)]) + (and ref `(set! ,ref ,e-val))))) + (define index-check + (lambda (e-idx libcall e) + `(if (if ,(%type-check mask-fixnum type-fixnum ,e-idx) + ,(%inline u< ,e-idx (immediate ,(fix (constant virtual-register-count)))) + ,(%constant sfalse)) + ,e + ,libcall))) + (meta-assert (= (constant log2-ptr-bytes) (constant fixnum-offset))) + (define-inline 3 virtual-register + [(e-idx) + (or (constant-ref e-idx) + (%mref ,%tc ,e-idx ,(constant tc-virtual-registers-disp)))]) + (define-inline 2 virtual-register + [(e-idx) + (or (constant-ref e-idx) + (bind #t (e-idx) + (index-check e-idx + (build-libcall #t src sexpr virtual-register e-idx) + (%mref ,%tc ,e-idx ,(constant tc-virtual-registers-disp)))))]) + (define-inline 3 set-virtual-register! + [(e-idx e-val) + (or (constant-set e-idx e-val) + `(set! ,(%mref ,%tc ,e-idx ,(constant tc-virtual-registers-disp)) ,e-val))]) + (define-inline 2 set-virtual-register! + [(e-idx e-val) + (or (constant-set e-idx e-val) + (bind #t (e-idx) + (bind #f (e-val) + (index-check e-idx + (build-libcall #t src sexpr set-virtual-register! e-idx) + `(set! ,(%mref ,%tc ,e-idx ,(constant tc-virtual-registers-disp)) ,e-val)))))])) + + (define-inline 2 $thread-list + [() `(literal ,(make-info-literal #t 'entry (lookup-c-entry thread-list) 0))]) + (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 + [() `(literal ,(make-info-literal #f 'entry (lookup-c-entry raw-collect-thread0-cond) 0))])) + (define-inline 2 not + [(e) `(if ,e ,(%constant sfalse) ,(%constant strue))]) + (define-inline 2 most-negative-fixnum + [() `(quote ,(constant most-negative-fixnum))]) + (define-inline 2 most-positive-fixnum + [() `(quote ,(constant most-positive-fixnum))]) + (define-inline 2 least-fixnum + [() `(quote ,(constant most-negative-fixnum))]) + (define-inline 2 greatest-fixnum + [() `(quote ,(constant most-positive-fixnum))]) + (define-inline 2 fixnum-width + [() `(quote ,(constant fixnum-bits))]) + (constant-case native-endianness + [(unknown) (void)] + [else + (define-inline 2 native-endianness + [() `(quote ,(constant native-endianness))])]) + (define-inline 2 directory-separator + [() `(quote ,(if-feature windows #\\ #\/))]) + (let () ; level 2 char=?, r6rs:char=?, etc. + (define-syntax char-pred + (syntax-rules () + [(_ op r6rs:op inline-op) + (let () + (define (go2 src sexpr e1 e2) + (bind #t (e1 e2) + `(if ,(build-chars? e1 e2) + ,(%inline inline-op ,e1 ,e2) + ,(build-libcall #t src sexpr op e1 e2)))) + (define (go3 src sexpr e1 e2 e3) + (and (constant? char? e1) + (constant? char? e3) + (bind #t (e2) + `(if ,(%type-check mask-char type-char ,e2) + ,(build-and + (%inline inline-op ,e1 ,e2) + (%inline inline-op ,e2 ,e3)) + ; could also pass e2 and e3: + ,(build-libcall #t src sexpr op e1 e2))))) + (define-inline 2 op + [(e1 e2) (go2 src sexpr e1 e2)] + [(e1 e2 e3) (go3 src sexpr e1 e2 e3)] + [(e1 . e*) #f]) + (define-inline 2 r6rs:op + [(e1 e2) (go2 src sexpr e1 e2)] + [(e1 e2 e3) (go3 src sexpr e1 e2 e3)] + [(e1 e2 . e*) #f]))])) + (char-pred char<? r6rs:char<? <) + (char-pred char<=? r6rs:char<=? <=) + (char-pred char=? r6rs:char=? eq?) + (char-pred char>=? r6rs:char>=? >=) + (char-pred char>? r6rs:char>? >)) + (let () ; level 3 char=?, r6rs:char=?, etc. + (define-syntax char-pred + (syntax-rules () + [(_ op r6rs:op inline-op) + (let () + (define (go2 e1 e2) + (%inline inline-op ,e1 ,e2)) + (define (go3 e1 e2 e3) + (bind #t (e2) + (bind #f (e3) + (build-and + (go2 e1 e2) + (go2 e2 e3))))) + (define-inline 3 op + [(e) `(seq ,e ,(%constant strue))] + [(e1 e2) (go2 e1 e2)] + [(e1 e2 e3) (go3 e1 e2 e3)] + [(e1 . e*) #f]) + (define-inline 3 r6rs:op + [(e1 e2) (go2 e1 e2)] + [(e1 e2 e3) (go3 e1 e2 e3)] + [(e1 e2 . e*) #f]))])) + (char-pred char<? r6rs:char<? <) + (char-pred char<=? r6rs:char<=? <=) + (char-pred char=? r6rs:char=? eq?) + (char-pred char>=? r6rs:char>=? >=) + (char-pred char>? r6rs:char>? >)) + (define-inline 3 map + [(e-proc e-ls) + (or (nanopass-case (L7 Expr) e-proc + [,pr + (and (all-set? (prim-mask unsafe) (primref-flags pr)) + (let ([name (primref-name pr)]) + (or (and (eq? name 'car) (build-libcall #f src sexpr map-car e-ls)) + (and (eq? name 'cdr) (build-libcall #f src sexpr map-cdr e-ls)))))] + [else #f]) + (build-libcall #f src sexpr map1 e-proc e-ls))] + [(e-proc e-ls1 e-ls2) + (or (nanopass-case (L7 Expr) e-proc + [,pr + (and (eq? (primref-name pr) 'cons) + (build-libcall #f src sexpr map-cons e-ls1 e-ls2))] + [else #f]) + (build-libcall #f src sexpr map2 e-proc e-ls1 e-ls2))] + [(e-proc e-ls . e-ls*) #f]) + (define-inline 3 andmap + [(e-proc e-ls) (build-libcall #f src sexpr andmap1 e-proc e-ls)] + [(e-proc e-ls . e-ls*) #f]) + (define-inline 3 for-all + [(e-proc e-ls) (build-libcall #f src sexpr andmap1 e-proc e-ls)] + [(e-proc e-ls . e-ls*) #f]) + (define-inline 3 ormap + [(e-proc e-ls) (build-libcall #f src sexpr ormap1 e-proc e-ls)] + [(e-proc e-ls . e-ls*) #f]) + (define-inline 3 exists + [(e-proc e-ls) (build-libcall #f src sexpr ormap1 e-proc e-ls)] + [(e-proc e-ls . e-ls*) #f]) + (define-inline 3 fold-left + [(e-proc e-base e-ls) (build-libcall #f src sexpr fold-left1 e-proc e-base e-ls)] + [(e-proc e-base e-ls1 e-ls2) (build-libcall #f src sexpr fold-left2 e-proc e-base e-ls1 e-ls2)] + [(e-proc e-base e-ls . e-ls*) #f]) + (define-inline 3 fold-right + [(e-proc e-base e-ls) (build-libcall #f src sexpr fold-right1 e-proc e-base e-ls)] + [(e-proc e-base e-ls1 e-ls2) (build-libcall #f src sexpr fold-right2 e-proc e-base e-ls1 e-ls2)] + [(e-proc e-base e-ls . e-ls*) #f]) + (define-inline 3 for-each + [(e-proc e-ls) (build-libcall #f src sexpr for-each1 e-proc e-ls)] + [(e-proc e-ls1 e-ls2) (build-libcall #f src sexpr for-each2 e-proc e-ls1 e-ls2)] + [(e-proc e-ls . e-ls*) #f]) + (define-inline 3 vector-map + [(e-proc e-ls) (build-libcall #f src sexpr vector-map1 e-proc e-ls)] + [(e-proc e-ls1 e-ls2) (build-libcall #f src sexpr vector-map2 e-proc e-ls1 e-ls2)] + [(e-proc e-ls . e-ls*) #f]) + (define-inline 3 vector-for-each + [(e-proc e-ls) (build-libcall #f src sexpr vector-for-each1 e-proc e-ls)] + [(e-proc e-ls1 e-ls2) (build-libcall #f src sexpr vector-for-each2 e-proc e-ls1 e-ls2)] + [(e-proc e-ls . e-ls*) #f]) + (define-inline 3 string-for-each + [(e-proc e-ls) (build-libcall #f src sexpr string-for-each1 e-proc e-ls)] + [(e-proc e-ls1 e-ls2) (build-libcall #f src sexpr string-for-each2 e-proc e-ls1 e-ls2)] + [(e-proc e-ls . e-ls*) #f]) + (define-inline 3 reverse + [(e) (build-libcall #f src sexpr reverse e)]) + (let () + (define inline-getprop + (lambda (plist-offset e-sym e-key e-dflt) + (let ([t-ls (make-assigned-tmp 't-ls)] [t-cdr (make-tmp 't-cdr)] [Ltop (make-local-label 'Ltop)]) + (bind #t (e-key e-dflt) + ; indirect symbol after evaluating e-key and e-dflt + `(let ([,t-ls ,(%mref ,e-sym ,plist-offset)]) + (label ,Ltop + (if ,(%inline eq? ,t-ls ,(%constant snil)) + ,e-dflt + (let ([,t-cdr ,(%mref ,t-ls ,(constant pair-cdr-disp))]) + (if ,(%inline eq? ,(%mref ,t-ls ,(constant pair-car-disp)) ,e-key) + ,(%mref ,t-cdr ,(constant pair-car-disp)) + (seq + (set! ,t-ls ,(%mref ,t-cdr ,(constant pair-cdr-disp))) + (goto ,Ltop))))))))))) + (define-inline 3 getprop + [(e-sym e-key) (inline-getprop (constant symbol-plist-disp) e-sym e-key (%constant sfalse))] + [(e-sym e-key e-dflt) (inline-getprop (constant symbol-plist-disp) e-sym e-key e-dflt)]) + (define-inline 3 $sgetprop + [(e-sym e-key e-dflt) (inline-getprop (constant symbol-splist-disp) e-sym e-key e-dflt)])) + (define-inline 3 assq + [(e-key e-ls) + (let ([t-ls (make-assigned-tmp 't-ls)] [Ltop (make-local-label 'Ltop)]) + (bind #t (e-key) + `(let ([,t-ls ,e-ls]) + (label ,Ltop + (if ,(%inline eq? ,t-ls ,(%constant snil)) + ,(%constant sfalse) + ,(bind #t ([t-a (%mref ,t-ls ,(constant pair-car-disp))]) + `(if ,(%inline eq? ,(%mref ,t-a ,(constant pair-car-disp)) ,e-key) + ,t-a + (seq + (set! ,t-ls ,(%mref ,t-ls ,(constant pair-cdr-disp))) + (goto ,Ltop)))))))))]) + (define-inline 3 length + [(e-ls) + (let ([t-ls (make-assigned-tmp 't-ls)] + [t-n (make-assigned-tmp 't-n)] + [Ltop (make-local-label 'Ltop)]) + (bind #t (e-ls) + `(if ,(%inline eq? ,e-ls ,(%constant snil)) + (immediate ,(fix 0)) + (let ([,t-ls ,e-ls] [,t-n (immediate ,(fix 0))]) + (label ,Ltop + ,(%seq + (set! ,t-ls ,(%mref ,t-ls ,(constant pair-cdr-disp))) + (set! ,t-n ,(%inline + ,t-n (immediate ,(fix 1)))) + (if ,(%inline eq? ,t-ls ,(%constant snil)) + ,t-n + (goto ,Ltop))))))))]) + (define-inline 3 append + ; TODO: hand-coded library routine that allocates the new pairs in a block + [() (%constant snil)] + [(e-ls) e-ls] + [(e-ls1 e-ls2) (build-libcall #f src sexpr append e-ls1 e-ls2)] + [(e-ls1 e-ls2 e-ls3) + (build-libcall #f src sexpr append e-ls1 + (build-libcall #f #f sexpr append e-ls2 e-ls3))] + [(e-ls . e-ls*) #f]) + (define-inline 3 apply + [(e0 e1) (build-libcall #f src sexpr apply0 e0 e1)] + [(e0 e1 e2) (build-libcall #f src sexpr apply1 e0 e1 e2)] + [(e0 e1 e2 e3) (build-libcall #f src sexpr apply2 e0 e1 e2 e3)] + [(e0 e1 e2 e3 e4) (build-libcall #f src sexpr apply3 e0 e1 e2 e3 e4)] + [(e0 e1 . e*) #f]) + (define-inline 2 fxsll + [(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)]) + (define-inline 3 call-with-current-continuation + [(e) (build-libcall #f src sexpr callcc e)]) + (define-inline 3 call/cc + [(e) (build-libcall #f src sexpr callcc e)]) + (define-inline 3 call/1cc + [(e) (build-libcall #f src sexpr call1cc e)]) + (define-inline 2 $event + [() (build-libcall #f src sexpr event)]) + (define-inline 3 eq-hashtable-ref + [(e1 e2 e3) (build-libcall #f src sexpr eq-hashtable-ref e1 e2 e3)]) + (define-inline 3 eq-hashtable-ref-cell + [(e1 e2) (build-libcall #f src sexpr eq-hashtable-ref-cell e1 e2)]) + (define-inline 3 eq-hashtable-contains? + [(e1 e2) (build-libcall #f src sexpr eq-hashtable-contains? e1 e2)]) + (define-inline 3 eq-hashtable-set! + [(e1 e2 e3) (build-libcall #f src sexpr eq-hashtable-set! e1 e2 e3)]) + (define-inline 3 eq-hashtable-update! + [(e1 e2 e3 e4) (build-libcall #f src sexpr eq-hashtable-update! e1 e2 e3 e4)]) + (define-inline 3 eq-hashtable-cell + [(e1 e2 e3) (build-libcall #f src sexpr eq-hashtable-cell e1 e2 e3)]) + (define-inline 3 eq-hashtable-try-atomic-cell + [(e1 e2 e3) (build-libcall #f src sexpr eq-hashtable-try-atomic-cell e1 e2 e3)]) + (define-inline 3 eq-hashtable-delete! + [(e1 e2) (build-libcall #f src sexpr eq-hashtable-delete! e1 e2)]) + (define-inline 3 symbol-hashtable-ref + [(e1 e2 e3) (build-libcall #f src sexpr symbol-hashtable-ref e1 e2 e3)]) + (define-inline 3 symbol-hashtable-ref-cell + [(e1 e2) (build-libcall #f src sexpr symbol-hashtable-ref-cell e1 e2)]) + (define-inline 3 symbol-hashtable-contains? + [(e1 e2) (build-libcall #f src sexpr symbol-hashtable-contains? e1 e2)]) + (define-inline 3 symbol-hashtable-set! + [(e1 e2 e3) (build-libcall #f src sexpr symbol-hashtable-set! e1 e2 e3)]) + (define-inline 3 symbol-hashtable-update! + [(e1 e2 e3 e4) (build-libcall #f src sexpr symbol-hashtable-update! e1 e2 e3 e4)]) + (define-inline 3 symbol-hashtable-cell + [(e1 e2 e3) (build-libcall #f src sexpr symbol-hashtable-cell e1 e2 e3)]) + (define-inline 3 symbol-hashtable-delete! + [(e1 e2) (build-libcall #f src sexpr symbol-hashtable-delete! e1 e2)]) + (define-inline 2 bytevector-s8-set! + [(e1 e2 e3) (build-libcall #f src sexpr bytevector-s8-set! e1 e2 e3)]) + (define-inline 2 bytevector-u8-set! + [(e1 e2 e3) (build-libcall #f src sexpr bytevector-u8-set! e1 e2 e3)]) + (define-inline 3 bytevector=? + [(e1 e2) (build-libcall #f src sexpr bytevector=? e1 e2)]) + (let () + (define eqvop-flonum + (lambda (e1 e2) + (nanopass-case (L7 Expr) e1 + [(quote ,d) (and (flonum? d) + (bind #t (e2) + (build-and + (%type-check mask-flonum type-flonum ,e2) + (if ($nan? d) + ;; NaN: invert `fl=` on self + (bind #t (e2) + (build-not (build-fl= e2 e2))) + ;; Non-NaN: compare bits + (constant-case ptr-bits + [(32) + (safe-assert (not (eq? (constant native-endianness) 'unknown))) + (let ([d0 (if (eq? (constant native-endianness) (native-endianness)) 0 4)]) + (let ([word1 ($object-ref 'integer-32 d (fx+ (constant flonum-data-disp) d0))] + [word2 ($object-ref 'integer-32 d (fx+ (constant flonum-data-disp) (fx- 4 d0)))]) + (build-and + (%inline eq? + ,(%mref ,e2 ,(constant flonum-data-disp)) + (immediate ,word1)) + (%inline eq? + ,(%mref ,e2 ,(fx+ (constant flonum-data-disp) 4)) + (immediate ,word2)))))] + [(64) + (let ([word ($object-ref 'integer-64 d (constant flonum-data-disp))]) + (%inline eq? + ,(%mref ,e2 ,(constant flonum-data-disp)) + (immediate ,word)))] + [else ($oops 'compiler-internal + "eqv doesn't handle ptr-bits = ~s" + (constant ptr-bits))])))))] + [else #f]))) + (define eqok-help? + (lambda (obj) + (or (symbol? obj) + (char? obj) + (target-fixnum? obj) + (null? obj) + (boolean? obj) + (eqv? obj "") + (eqv? obj '#()) + (eqv? obj '#vu8()) + (eqv? obj '#0=#0#) + (eq? obj (void)) + (eof-object? obj) + (bwp-object? obj) + ($unbound-object? obj) + (eqv? obj '#vfx())))) + (define eqvok-help? number?) + (define eqvnever-help? (lambda (obj) (not (number? obj)))) + (define e*ok? + (lambda (e*ok-help?) + (lambda (e) + (nanopass-case (L7 Expr) e + [(quote ,d) (e*ok-help? d)] + [else #f])))) + (define eqok? (e*ok? eqok-help?)) + (define eqvok? (e*ok? eqvok-help?)) + (define eqvnever? (e*ok? eqvnever-help?)) + (define-inline 2 eqv? + [(e1 e2) (or (eqvop-null-fptr e1 e2) + (relop-length RELOP= e1 e2) + (eqvop-flonum e1 e2) + (eqvop-flonum e2 e1) + (if (or (eqok? e1) (eqok? e2) + (eqvnever? e1) (eqvnever? e2)) + (build-eq? e1 e2) + (build-eqv? src sexpr e1 e2)))]) + (let () + (define xform-equal? + (lambda (src sexpr e1 e2) + (nanopass-case (L7 Expr) e1 + [(quote ,d1) + (let xform ([d1 d1] [e2 e2] [n 3] [k (lambda (e n) e)]) + (if (eqok-help? d1) + (k (build-eq? `(quote ,d1) e2) n) + (if (eqvok-help? d1) + (k (build-eqv? src sexpr `(quote ,d1) e2) n) + (and (fx> n 0) + (pair? d1) + (let-values ([(e2 dobind) (binder #t 'ptr e2)]) + (xform (car d1) (build-car e2) (fx- n 1) + (lambda (a n) + (xform (cdr d1) (build-cdr e2) n + (lambda (d n) + (k (dobind + (build-and + (build-pair? e2) + (build-and a d))) + n))))))))))] + [else #f]))) + (define-inline 2 equal? + [(e1 e2) (or (eqvop-null-fptr e1 e2) + (relop-length RELOP= e1 e2) + (xform-equal? src sexpr e1 e2) + (xform-equal? src sexpr e2 e1))])) + (let () + (define mem*ok? + (lambda (e*ok-help?) + (lambda (x) + (nanopass-case (L7 Expr) x + [(quote ,d) + (and (list? d) + (let f ([d d]) + (or (null? d) + (and (e*ok-help? (car d)) + (f (cdr d))))))] + [else #f])))) + (define memqok? (mem*ok? eqok-help?)) + (define memvok? (mem*ok? eqvok-help?)) + (define mem*->e*?s + (lambda (build-e*? limit) + (lambda (e-key e-ls) + (nanopass-case (L7 Expr) e-ls + [(quote ,d) + (and (let f ([d d] [n 0]) + (or (null? d) + (and (pair? d) + (fx< n limit) + (f (cdr d) (fx1+ n))))) + (bind #t (e-key) + (let f ([ls d]) + (if (null? ls) + `(quote #f) + `(if ,(build-e*? e-key `(quote ,(car ls))) + (quote ,ls) + ,(f (cdr ls)))))))] + [else #f])))) + (define memq->eq?s (mem*->e*?s build-eq? 8)) + (define (memv->eqv?s src sexpr) (mem*->e*?s (make-build-eqv? src sexpr) 4)) + (define do-memq + (lambda (src sexpr e-key e-ls) + (or (memq->eq?s e-key e-ls) + (let ([t-ls (make-assigned-tmp 't-ls)] [Ltop (make-local-label 'Ltop)]) + (bind #t (e-key) + `(let ([,t-ls ,e-ls]) + (label ,Ltop + (if ,(%inline eq? ,t-ls ,(%constant snil)) + ,(%constant sfalse) + (if ,(%inline eq? ,(%mref ,t-ls ,(constant pair-car-disp)) ,e-key) + ,t-ls + (seq + (set! ,t-ls ,(%mref ,t-ls ,(constant pair-cdr-disp))) + (goto ,Ltop))))))))))) + (define do-memv + (lambda (src sexpr e-key e-ls) + (or ((memv->eqv?s src sexpr) e-key e-ls) + (build-libcall #f src sexpr memv e-key e-ls)))) + (define-inline 3 memq + [(e-key e-ls) (do-memq src sexpr e-key e-ls)]) + (define-inline 3 memv + [(e-key e-ls) + (if (or (eqok? e-key) (memqok? e-ls)) + (do-memq src sexpr e-key e-ls) + (do-memv src sexpr e-key e-ls))]) + (define-inline 3 member + [(e-key e-ls) + (if (or (eqok? e-key) (memqok? e-ls)) + (do-memq src sexpr e-key e-ls) + (and (or (eqvok? e-key) (memvok? e-ls)) + (do-memv src sexpr e-key e-ls)))]) + (define-inline 2 memq + [(e-key e-ls) (memq->eq?s e-key e-ls)]) + (define-inline 2 memv + [(e-key e-ls) (or (and (memqok? e-ls) (memq->eq?s e-key e-ls)) + ((memv->eqv?s src sexpr) e-key e-ls))]) + (define-inline 2 member + [(e-key e-ls) (or (and (memqok? e-ls) (memq->eq?s e-key e-ls)) + (and (memvok? e-ls) ((memv->eqv?s src sexpr) e-key e-ls)))]))) + ; NB: for all of the I/O routines, consider putting optimize-level 2 code out-of-line + ; w/o going all the way to the port handler, i.e., always defer to library routine but + ; have library routine do the checks and run the optimize-level 3 version...this could + ; save a lot of code + ; NB: verify that the inline checks don't always fail, i.e., don't always send us to the + ; library routine + (let () + (define (go src sexpr e-p check? update? do-libcall) + (let ([Llib (and check? (make-local-label 'Llib))]) + (define maybe-add-port-check + (lambda (e-p body) + (if Llib + `(if (if ,(%type-check mask-typed-object type-typed-object ,e-p) + ,(%type-check mask-binary-input-port type-binary-input-port + ,(%mref ,e-p ,(constant typed-object-type-disp))) + ,(%constant sfalse)) + ,body + (goto ,Llib)) + body))) + (define maybe-add-update + (lambda (t0 e-icount body) + (if update? + `(seq + (set! ,e-icount ,(%inline + ,t0 (immediate 1))) + ,body) + body))) + (bind #t (e-p) + (let ([e-icount (%mref ,e-p ,(constant port-icount-disp))]) + (maybe-add-port-check e-p + (bind #t ([t0 e-icount]) + `(if ,(%inline eq? ,t0 (immediate 0)) + ,(maybe-add-label Llib (do-libcall src sexpr e-p)) + ,(maybe-add-update t0 e-icount + ; TODO: this doesn't completely fall away when used in effect context + (build-fix + `(inline ,(make-info-load 'unsigned-8 #f) ,%load + ,t0 + ,(%mref ,e-p ,(constant port-ilast-disp)) + (immediate 0))))))))))) + (define (unsafe-lookahead-u8-libcall src sexpr e-p) (build-libcall #t src sexpr unsafe-lookahead-u8 e-p)) + (define (safe-lookahead-u8-libcall src sexpr e-p) (build-libcall #t src sexpr safe-lookahead-u8 e-p)) + (define (unsafe-get-u8-libcall src sexpr e-p) (build-libcall #t src sexpr unsafe-get-u8 e-p)) + (define (safe-get-u8-libcall src sexpr e-p) (build-libcall #t src sexpr safe-get-u8 e-p)) + (define-inline 3 lookahead-u8 + [(e-p) (go src sexpr e-p #f #f unsafe-lookahead-u8-libcall)]) + (define-inline 2 lookahead-u8 + [(e-p) (go src sexpr e-p #t #f safe-lookahead-u8-libcall)]) + (define-inline 3 get-u8 + [(e-p) (go src sexpr e-p #f #t unsafe-get-u8-libcall)]) + (define-inline 2 get-u8 + [(e-p) (go src sexpr e-p #t #t safe-get-u8-libcall)])) + (let () + (define (go src sexpr e-p check? update? do-libcall) + (let ([Llib (and check? (make-local-label 'Llib))]) + (define maybe-add-port-check + (lambda (e-p body) + (if Llib + `(if (if ,(%type-check mask-typed-object type-typed-object ,e-p) + ,(%type-check mask-textual-input-port type-textual-input-port + ,(%mref ,e-p ,(constant typed-object-type-disp))) + ,(%constant sfalse)) + ,body + (goto ,Llib)) + body))) + (define maybe-add-update + (lambda (t0 e-icount body) + (if update? + `(seq + (set! ,e-icount ,(%inline + ,t0 ,(%constant string-char-bytes))) + ,body) + body))) + (bind #t (e-p) + (let ([e-icount (%mref ,e-p ,(constant port-icount-disp))]) + (maybe-add-port-check e-p + (bind #t ([t0 e-icount]) + `(if ,(%inline eq? ,t0 (immediate 0)) + ,(maybe-add-label Llib (do-libcall src sexpr e-p)) + ,(maybe-add-update t0 e-icount + ; TODO: this doesn't completely fall away when used in effect context + `(inline ,(make-info-load (string-char-type) #f) ,%load + ,t0 + ,(%mref ,e-p ,(constant port-ilast-disp)) + (immediate 0)))))))))) + (define (unsafe-lookahead-char-libcall src sexpr e-p) (build-libcall #t src sexpr unsafe-lookahead-char e-p)) + (define (safe-lookahead-char-libcall src sexpr e-p) (build-libcall #t src sexpr safe-lookahead-char e-p)) + (define (unsafe-peek-char-libcall src sexpr e-p) (build-libcall #t src sexpr unsafe-peek-char e-p)) + (define (safe-peek-char-libcall src sexpr e-p) (build-libcall #t src sexpr safe-peek-char e-p)) + (define (unsafe-get-char-libcall src sexpr e-p) (build-libcall #t src sexpr unsafe-get-char e-p)) + (define (safe-get-char-libcall src sexpr e-p) (build-libcall #t src sexpr safe-get-char e-p)) + (define (unsafe-read-char-libcall src sexpr e-p) (build-libcall #t src sexpr unsafe-read-char e-p)) + (define (safe-read-char-libcall src sexpr e-p) (build-libcall #t src sexpr safe-read-char e-p)) + (define-inline 3 lookahead-char + [(e-p) (go src sexpr e-p #f #f unsafe-lookahead-char-libcall)]) + (define-inline 2 lookahead-char + [(e-p) (go src sexpr e-p #t #f safe-lookahead-char-libcall)]) + (define-inline 3 peek-char + [() (go src sexpr (%tc-ref current-input) #f #f unsafe-peek-char-libcall)] + [(e-p) (go src sexpr e-p #f #f unsafe-peek-char-libcall)]) + (define-inline 2 peek-char + [() (go src sexpr (%tc-ref current-input) #f #f unsafe-peek-char-libcall)] + [(e-p) (go src sexpr e-p #t #f safe-peek-char-libcall)]) + (define-inline 3 get-char + [(e-p) (go src sexpr e-p #f #t unsafe-get-char-libcall)]) + (define-inline 2 get-char + [(e-p) (go src sexpr e-p #t #t safe-get-char-libcall)]) + (define-inline 3 read-char + [() (go src sexpr (%tc-ref current-input) #f #t unsafe-read-char-libcall)] + [(e-p) (go src sexpr e-p #f #t unsafe-read-char-libcall)]) + (define-inline 2 read-char + [() (go src sexpr (%tc-ref current-input) #f #t unsafe-read-char-libcall)] + [(e-p) (go src sexpr e-p #t #t safe-read-char-libcall)])) + (let () + (define (go src sexpr e-p e-c check-port? check-char? do-libcall) + (let ([const-char? (constant? char? e-c)]) + (let ([Llib (and (or check-char? check-port? (not const-char?)) (make-local-label 'Llib))]) + (define maybe-add-port-check + (lambda (e-p body) + (if check-port? + `(if (if ,(%type-check mask-typed-object type-typed-object ,e-p) + ,(%type-check mask-textual-input-port type-textual-input-port + ,(%mref ,e-p ,(constant typed-object-type-disp))) + ,(%constant sfalse)) + ,body + (goto ,Llib)) + body))) + (define maybe-add-eof-check + (lambda (e-c body) + (if const-char? + body + `(if ,(%inline eq? ,e-c ,(%constant seof)) + (goto ,Llib) + ,body)))) + (define maybe-add-char-check + (lambda (e-c body) + (if check-char? + `(if ,(%type-check mask-char type-char ,e-c) + ,body + (goto ,Llib)) + body))) + (bind #t (e-c e-p) + (let ([e-icount (%mref ,e-p ,(constant port-icount-disp))]) + (maybe-add-port-check e-p + (maybe-add-eof-check e-c + (maybe-add-char-check e-c + (bind #t ([t0 e-icount]) + `(if ,(%inline eq? ,t0 + ,(%inline - + ,(%inline + + ,(%mref ,e-p ,(constant port-ibuffer-disp)) + ,(%constant string-data-disp)) + ,(%mref ,e-p ,(constant port-ilast-disp)))) + ,(maybe-add-label Llib (do-libcall src sexpr e-p e-c)) + (set! ,e-icount ,(%inline - ,t0 ,(%constant string-char-bytes))))))))))))) + (define (unsafe-unget-char-libcall src sexpr e-p e-c) (build-libcall #t src sexpr unsafe-unget-char e-p e-c)) + (define (safe-unget-char-libcall src sexpr e-p e-c) (build-libcall #t src sexpr safe-unget-char e-p e-c)) + (define (unsafe-unread-char-libcall src sexpr e-p e-c) (build-libcall #t src sexpr unsafe-unread-char e-c e-p)) + (define (safe-unread-char-libcall src sexpr e-p e-c) (build-libcall #t src sexpr safe-unread-char e-c e-p)) + (define-inline 3 unget-char + [(e-p e-c) (go src sexpr e-p e-c #f #f unsafe-unget-char-libcall)]) + (define-inline 2 unget-char + [(e-p e-c) (go src sexpr e-p e-c #t (not (constant? char? e-c)) safe-unget-char-libcall)]) + (define-inline 3 unread-char + [(e-c) (go src sexpr (%tc-ref current-input) e-c #f #f unsafe-unread-char-libcall)] + [(e-c e-p) (go src sexpr e-p e-c #f #f unsafe-unread-char-libcall)]) + (define-inline 2 unread-char + [(e-c) (if (constant? char? e-c) + (go src sexpr (%tc-ref current-input) e-c #f #f unsafe-unread-char-libcall) + (go src sexpr (%tc-ref current-input) e-c #f #t safe-unread-char-libcall))] + [(e-c e-p) (go src sexpr e-p e-c #t (not (constant? char? e-c)) safe-unread-char-libcall)])) + (let () + (define octet? + (lambda (x) + (and (fixnum? x) (fx<= 0 x 255)))) + (define maybe-add-octet-check + (lambda (check-octet? Llib e-o body) + (if check-octet? + `(if ,(%type-check mask-octet type-octet ,e-o) + ,body + (goto ,Llib)) + body))) + (let () + (define (go src sexpr e-p e-o check-port? check-octet? do-libcall) + (let ([const-octet? (constant? octet? e-o)]) + (let ([Llib (and (or check-octet? check-port? (not const-octet?)) (make-local-label 'Llib))]) + (define maybe-add-port-check + (lambda (e-p body) + (if check-port? + `(if (if ,(%type-check mask-typed-object type-typed-object ,e-p) + ,(%type-check mask-binary-input-port type-binary-input-port + ,(%mref ,e-p ,(constant typed-object-type-disp))) + ,(%constant sfalse)) + ,body + (goto ,Llib)) + body))) + (define maybe-add-eof-check + (lambda (e-o body) + (if const-octet? + body + `(if ,(%inline eq? ,e-o ,(%constant seof)) + (goto ,Llib) + ,body)))) + (bind #t (e-o e-p) + (let ([e-icount (%mref ,e-p ,(constant port-icount-disp))]) + (maybe-add-port-check e-p + (maybe-add-eof-check e-o + (maybe-add-octet-check check-octet? Llib e-o + (bind #t ([t0 e-icount]) + `(if ,(%inline eq? ,t0 + ,(%inline - + ,(%inline + + ,(%mref ,e-p ,(constant port-ibuffer-disp)) + ,(%constant bytevector-data-disp)) + ,(%mref ,e-p ,(constant port-ilast-disp)))) + ,(maybe-add-label Llib (do-libcall src sexpr e-p e-o)) + (set! ,e-icount ,(%inline - ,t0 (immediate 1))))))))))))) + (define (unsafe-unget-u8-libcall src sexpr e-p e-o) (build-libcall #t src sexpr unsafe-unget-u8 e-p e-o)) + (define (safe-unget-u8-libcall src sexpr e-p e-o) (build-libcall #t src sexpr safe-unget-u8 e-p e-o)) + (define-inline 3 unget-u8 + [(e-p e-o) (go src sexpr e-p e-o #f #f unsafe-unget-u8-libcall)]) + (define-inline 2 unget-u8 + [(e-p e-o) (go src sexpr e-p e-o #t (not (constant? octet? e-o)) safe-unget-u8-libcall)])) + (let () + (define (go src sexpr e-p e-o check-port? check-octet? do-libcall) + (let ([Llib (and (or check-octet? check-port?) (make-local-label 'Llib))]) + (define maybe-add-port-check + (lambda (e-p body) + (if check-port? + `(if (if ,(%type-check mask-typed-object type-typed-object ,e-p) + ,(%type-check mask-binary-output-port type-binary-output-port + ,(%mref ,e-p ,(constant typed-object-type-disp))) + ,(%constant sfalse)) + ,body + (goto ,Llib)) + body))) + (define add-update + (lambda (t0 e-ocount body) + `(seq + (set! ,e-ocount ,(%inline + ,t0 (immediate 1))) + ,body))) + (bind check-octet? (e-o) + (bind #t (e-p) + (let ([e-ocount (%mref ,e-p ,(constant port-ocount-disp))]) + (maybe-add-octet-check check-octet? Llib e-o + (maybe-add-port-check e-p + (bind #t ([t0 e-ocount]) + `(if ,(%inline eq? ,t0 (immediate 0)) + ,(maybe-add-label Llib (do-libcall src sexpr e-o e-p)) + ,(add-update t0 e-ocount + `(inline ,(make-info-load 'unsigned-8 #f) ,%store + ,t0 + ,(%mref ,e-p ,(constant port-olast-disp)) + (immediate 0) + ,(build-unfix e-o)))))))))))) + (define (unsafe-put-u8-libcall src sexpr e-o e-p) (build-libcall #t src sexpr unsafe-put-u8 e-p e-o)) + (define (safe-put-u8-libcall src sexpr e-o e-p) (build-libcall #t src sexpr safe-put-u8 e-p e-o)) + (define-inline 3 put-u8 + [(e-p e-o) (go src sexpr e-p e-o #f #f unsafe-put-u8-libcall)]) + (define-inline 2 put-u8 + [(e-p e-o) (go src sexpr e-p e-o #t (not (constant? octet? e-o)) safe-put-u8-libcall)]))) + (let () + (define (go src sexpr e-p e-c check-port? check-char? do-libcall) + (let ([Llib (and (or check-char? check-port?) (make-local-label 'Llib))]) + (define maybe-add-char-check + (lambda (e-c body) + (if check-char? + `(if ,(%type-check mask-char type-char ,e-c) + ,body + (goto ,Llib)) + body))) + (define maybe-add-port-check + (lambda (e-p body) + (if check-port? + `(if (if ,(%type-check mask-typed-object type-typed-object ,e-p) + ,(%type-check mask-textual-output-port type-textual-output-port + ,(%mref ,e-p ,(constant typed-object-type-disp))) + ,(%constant sfalse)) + ,body + (goto ,Llib)) + body))) + (define add-update + (lambda (t0 e-ocount body) + `(seq + (set! ,e-ocount ,(%inline + ,t0 ,(%constant string-char-bytes))) + ,body))) + (bind check-char? (e-c) + (bind #t (e-p) + (let ([e-ocount (%mref ,e-p ,(constant port-ocount-disp))]) + (maybe-add-char-check e-c + (maybe-add-port-check e-p + (bind #t ([t0 e-ocount]) + `(if ,(%inline eq? ,t0 (immediate 0)) + ,(maybe-add-label Llib (do-libcall src sexpr e-c e-p)) + ,(add-update t0 e-ocount + `(inline ,(make-info-load (string-char-type) #f) ,%store + ,t0 + ,(%mref ,e-p ,(constant port-olast-disp)) + (immediate 0) + ,e-c))))))))))) + (define (unsafe-put-char-libcall src sexpr e-c e-p) (build-libcall #t src sexpr unsafe-put-char e-p e-c)) + (define (safe-put-char-libcall src sexpr e-c e-p) (build-libcall #t src sexpr safe-put-char e-p e-c)) + (define (unsafe-write-char-libcall src sexpr e-c e-p) (build-libcall #t src sexpr unsafe-write-char e-c e-p)) + (define (safe-write-char-libcall src sexpr e-c e-p) (build-libcall #t src sexpr safe-write-char e-c e-p)) + (define (unsafe-newline-libcall src sexpr e-c e-p) (build-libcall #t src sexpr unsafe-newline e-p)) + (define (safe-newline-libcall src sexpr e-c e-p) (build-libcall #t src sexpr safe-newline e-p)) + (define-inline 3 put-char + [(e-p e-c) (go src sexpr e-p e-c #f #f unsafe-put-char-libcall)]) + (define-inline 2 put-char + [(e-p e-c) (go src sexpr e-p e-c #t (not (constant? char? e-c)) safe-put-char-libcall)]) + (define-inline 3 write-char + [(e-c) (go src sexpr (%tc-ref current-output) e-c #f #f unsafe-write-char-libcall)] + [(e-c e-p) (go src sexpr e-p e-c #f #f unsafe-write-char-libcall)]) + (define-inline 2 write-char + [(e-c) (if (constant? char? e-c) + (go src sexpr (%tc-ref current-output) e-c #f #f unsafe-write-char-libcall) + (go src sexpr (%tc-ref current-output) e-c #f #t safe-write-char-libcall))] + [(e-c e-p) (go src sexpr e-p e-c #t (not (constant? char? e-c)) safe-write-char-libcall)]) + (define-inline 3 newline + [() (go src sexpr (%tc-ref current-output) `(quote #\newline) #f #f unsafe-newline-libcall)] + [(e-p) (go src sexpr e-p `(quote #\newline) #f #f unsafe-newline-libcall)]) + (define-inline 2 newline + [() (go src sexpr (%tc-ref current-output) `(quote #\newline) #f #f unsafe-newline-libcall)] + [(e-p) (go src sexpr e-p `(quote #\newline) #t #f safe-newline-libcall)])) + (let () + (define build-fxop? + (lambda (op overflow-flag e1 e2 adjust k) + (let ([Lfail (make-local-label 'Lfail)]) + (bind #t (e1 e2) + `(if ,(build-fixnums? (list e1 e2)) + ,(bind #f ([t `(inline ,null-info ,op ,e1 ,(adjust e2))]) + `(if (inline ,(make-info-condition-code overflow-flag #f #t) ,%condition-code) + (label ,Lfail ,(k e1 e2)) + ,t)) + (goto ,Lfail)))))) + (define-inline 2 + + [() `(immediate ,(fix 0))] + [(e) (build-fxop? %+/ovfl 'overflow e `(quote 0) values (lambda (e1 e2) (build-libcall #t src sexpr + e1 e2)))] + [(e1 e2) (build-fxop? %+/ovfl 'overflow e1 e2 values (lambda (e1 e2) (build-libcall #t src sexpr + e1 e2)))] + ; TODO: handle 3-operand case ala fx+, w/3-operand library + + [(e1 . e*) #f]) + (define-inline 2 * + [() `(immediate ,(fix 1))] + [(e) (build-fxop? %*/ovfl 'multiply-overflow e `(quote 1) build-unfix (lambda (e1 e2) (build-libcall #t src sexpr * e1 e2)))] + ; TODO: swap e1 & e2 if e1 is constant + [(e1 e2) (build-fxop? %*/ovfl 'multiply-overflow e1 e2 build-unfix (lambda (e1 e2) (build-libcall #t src sexpr * e1 e2)))] + ; TODO: handle 3-operand case ala fx+, w/3-operand library * + [(e1 . e*) #f]) + (define-inline 2 - + [(e) (build-fxop? %-/ovfl 'overflow `(quote 0) e values (lambda (e1 e2) (build-libcall #t src sexpr - e1 e2)))] + [(e1 e2) (build-fxop? %-/ovfl 'overflow e1 e2 values (lambda (e1 e2) (build-libcall #t src sexpr - e1 e2)))] + ; TODO: handle 3-operand case ala fx+, w/3-operand library - + [(e1 e2 . e*) #f])) + (let () + (define build-fxop? + (lambda (op e k) + (let ([Lfail (make-local-label 'Lfail)]) + (bind #t (e) + `(if ,(%type-check mask-fixnum type-fixnum ,e) + ,(bind #f ([t `(inline ,null-info ,op ,e (immediate ,(fix 1)))]) + `(if (inline ,(make-info-condition-code 'overflow #f #t) ,%condition-code) + (label ,Lfail ,(k e)) + ,t)) + (goto ,Lfail)))))) + + (define-syntax define-inline-1op + (syntax-rules () + [(_ op name) + (define-inline 2 name + [(e) (build-fxop? op e (lambda (e) (build-libcall #t src sexpr name e)))])])) + + (define-inline-1op %-/ovfl 1-) + (define-inline-1op %-/ovfl -1+) + (define-inline-1op %-/ovfl sub1) + (define-inline-1op %+/ovfl 1+) + (define-inline-1op %+/ovfl add1)) + + (define-inline 2 / + [(e) (build-libcall #f src sexpr / `(immediate ,(fix 1)) e)] + [(e1 e2) (build-libcall #f src sexpr / e1 e2)] + [(e1 . e*) #f]) + + (let () + (define (zgo src sexpr e e1 e2) + (build-simple-or + (%inline eq? ,e (immediate 0)) + `(if ,(build-fixnums? (list e)) + ,(%constant sfalse) + ,(build-libcall #t src sexpr = e1 e2)))) + (define (go src sexpr e1 e2) + (or (eqvop-null-fptr e1 e2) + (relop-length RELOP= e1 e2) + (cond + [(constant? (lambda (x) (eqv? x 0)) e1) + (bind #t (e2) (zgo src sexpr e2 e1 e2))] + [(constant? (lambda (x) (eqv? x 0)) e2) + (bind #t (e1) (zgo src sexpr e1 e1 e2))] + [else (bind #t (e1 e2) + `(if ,(build-fixnums? (list e1 e2)) + ,(%inline eq? ,e1 ,e2) + ,(build-libcall #t src sexpr = e1 e2)))]))) + (define-inline 2 = + [(e1 e2) (go src sexpr e1 e2)] + [(e1 . e*) #f]) + (define-inline 2 r6rs:= + [(e1 e2) (go src sexpr e1 e2)] + [(e1 e2 . e*) #f])) + (let () + (define-syntax define-relop-inline + (syntax-rules () + [(_ name r6rs:name relop op) + (let () + (define builder + (lambda (e1 e2 libcall) + (or (relop-length relop e1 e2) + (bind #t (e1 e2) + `(if ,(build-fixnums? (list e1 e2)) + ,(%inline op ,e1 ,e2) + ,(libcall e1 e2)))))) + (define-inline 2 name + [(e1 e2) + (builder e1 e2 + (lambda (e1 e2) (build-libcall #t src sexpr name e1 e2)))] + ; TODO: handle 3-operand case w/3-operand library routine + [(e1 . e*) #f]) + (define-inline 2 r6rs:name + [(e1 e2) + (builder e1 e2 + (lambda (e1 e2) (build-libcall #t src sexpr name e1 e2)))] + ; TODO: handle 3-operand case w/3-operand library routine + [(e1 e2 . e*) #f]))])) + (define-relop-inline < r6rs:< RELOP< <) + (define-relop-inline <= r6rs:<= RELOP<= <=) + (define-relop-inline >= r6rs:>= RELOP>= >=) + (define-relop-inline > r6rs:> RELOP> >)) + (define-inline 3 positive? ; 3 so opt-level 2 errors come from positive? + [(e) (handle-prim src sexpr 3 '> (list e `(quote 0)))]) + (define-inline 3 nonnegative? ; 3 so opt-level 2 errors come from nonnegative? + [(e) (handle-prim src sexpr 3 '>= (list e `(quote 0)))]) + (define-inline 3 negative? ; 3 so opt-level 2 errors come from negative? + [(e) (handle-prim src sexpr 3 '< (list e `(quote 0)))]) + (define-inline 3 nonpositive? ; 3 so opt-level 2 errors come from nonpositive? + [(e) (handle-prim src sexpr 3 '<= (list e `(quote 0)))]) + (define-inline 2 zero? + [(e) + (or (relop-length RELOP= e) + (nanopass-case (L7 Expr) e + [(call ,info ,mdcl ,pr ,e) + (guard + (eq? (primref-name pr) 'ftype-pointer-address) + (all-set? (prim-mask unsafe) (primref-flags pr))) + (make-ftype-pointer-null? e)] + [else + (bind #t (e) + (build-simple-or + (%inline eq? ,e (immediate ,(fix 0))) + `(if ,(%type-check mask-fixnum type-fixnum ,e) + ,(%constant sfalse) + ,(build-libcall #t src sexpr zero? e))))]))]) + (define-inline 2 positive? [(e) (relop-length RELOP> e)]) + (define-inline 2 nonnegative? [(e) (relop-length RELOP>= e)]) + (define-inline 2 negative? [(e) (relop-length RELOP< e)]) + (define-inline 2 nonpositive? [(e) (relop-length RELOP<= e)]) + (let () + (define-syntax define-logorop-inline + (syntax-rules () + [(_ name ...) + (let () + (define build-logop + (lambda (src sexpr e1 e2 libcall) + (bind #t (e1 e2) + (bind #t ([t (%inline logor ,e1 ,e2)]) + `(if ,(%type-check mask-fixnum type-fixnum ,t) + ,t + ,(libcall src sexpr e1 e2)))))) + (let () + (define libcall (lambda (src sexpr e1 e2) (build-libcall #t src sexpr name e1 e2))) + (define-inline 2 name + [() `(immediate ,(fix 0))] + [(e) (build-logop src sexpr e `(immediate ,(fix 0)) libcall)] + [(e1 e2) (build-logop src sexpr e1 e2 libcall)] + [(e1 . e*) #f])) + ...)])) + (define-logorop-inline logor logior bitwise-ior)) + (let () + (define-syntax define-logop-inline + (syntax-rules () + [(_ op unit name ...) + (let () + (define build-logop + (lambda (src sexpr e1 e2 libcall) + (bind #t (e1 e2) + `(if ,(build-fixnums? (list e1 e2)) + ,(%inline op ,e1 ,e2) + ,(libcall src sexpr e1 e2))))) + (let () + (define libcall (lambda (src sexpr e1 e2) (build-libcall #t src sexpr name e1 e2))) + (define-inline 2 name + [() `(immediate ,(fix unit))] + [(e) (build-logop src sexpr e `(immediate ,(fix unit)) libcall)] + [(e1 e2) (build-logop src sexpr e1 e2 libcall)] + [(e1 . e*) #f])) + ...)])) + (define-logop-inline logand -1 logand bitwise-and) + (define-logop-inline logxor 0 logxor bitwise-xor)) + (let () + (define build-lognot + (lambda (e libcall) + (bind #t (e) + `(if ,(%type-check mask-fixnum type-fixnum ,e) + ,(%inline logxor ,e (immediate ,(fxlognot (constant mask-fixnum)))) + ,(libcall e))))) + + (define-inline 2 lognot + [(e) (build-lognot e (lambda (e) (build-libcall #t src sexpr lognot e)))]) + (define-inline 2 bitwise-not + [(e) (build-lognot e (lambda (e) (build-libcall #t src sexpr bitwise-not e)))])) + + (let () + (define build-logbit? + (lambda (e1 e2 libcall) + (or (nanopass-case (L7 Expr) e1 + [(quote ,d) + (or (and (and (fixnum? d) (fx<= 0 d (fx- (constant fixnum-bits) 2))) + (bind #t (e2) + `(if ,(%type-check mask-fixnum type-fixnum ,e2) + ,(%inline logtest ,e2 (immediate ,(fix (ash 1 d)))) + ,(libcall e1 e2)))) + (and (and (target-fixnum? d) (> d (fx- (constant fixnum-bits) 2))) + (bind #t (e2) + `(if ,(%type-check mask-fixnum type-fixnum ,e2) + ,(%inline < ,e2 (immediate ,(fix 0))) + ,(libcall e1 e2)))))] + [else #f]) + (bind #t (e1 e2) + `(if ,(build-and + (build-fixnums? (list e1 e2)) + (%inline u< ,e1 (immediate ,(fix (constant fixnum-bits))))) + ,(%inline logtest + ,(%inline sra ,e2 ,(build-unfix e1)) + (immediate ,(fix 1))) + ,(libcall e1 e2)))))) + + (define-inline 2 logbit? + [(e1 e2) (build-logbit? e1 e2 (lambda (e1 e2) (build-libcall #t src sexpr logbit? e1 e2)))]) + (define-inline 2 bitwise-bit-set? + [(e1 e2) (build-logbit? e2 e1 (lambda (e2 e1) (build-libcall #t src sexpr bitwise-bit-set? e1 e2)))])) + + (define-inline 2 logbit1 + [(e1 e2) (or (nanopass-case (L7 Expr) e1 + [(quote ,d) + (and (and (fixnum? d) (fx<= 0 d (fx- (constant fixnum-bits) 2))) + (bind #t (e2) + `(if ,(%type-check mask-fixnum type-fixnum ,e2) + ,(%inline logor ,e2 (immediate ,(fix (ash 1 d)))) + ,(build-libcall #t src sexpr logbit1 e1 e2))))] + [else #f]) + (bind #t (e1 e2) + `(if ,(build-and + (build-fixnums? (list e1 e2)) + (%inline u< ,e1 (immediate ,(fix (fx- (constant fixnum-bits) 1))))) + ,(%inline logor ,e2 + ,(%inline sll (immediate ,(fix 1)) ,(build-unfix e1))) + ,(build-libcall #t src sexpr logbit1 e1 e2))))]) + (define-inline 2 logbit0 + [(e1 e2) (or (nanopass-case (L7 Expr) e1 + [(quote ,d) + (and (and (fixnum? d) (fx<= 0 d (fx- (constant fixnum-bits) 2))) + (bind #t (e2) + `(if ,(%type-check mask-fixnum type-fixnum ,e2) + ,(%inline logand ,e2 (immediate ,(fix (lognot (ash 1 d))))) + ,(build-libcall #t src sexpr logbit0 e1 e2))))] + [else #f]) + (bind #t (e1 e2) + `(if ,(build-and + (build-fixnums? (list e1 e2)) + (%inline u< ,e1 (immediate ,(fix (fx- (constant fixnum-bits) 1))))) + ,(%inline logand ,e2 + ,(%inline lognot + ,(%inline sll (immediate ,(fix 1)) ,(build-unfix e1)))) + ,(build-libcall #t src sexpr logbit0 e1 e2))))]) + (define-inline 2 logtest + [(e1 e2) (bind #t (e1 e2) + `(if ,(build-fixnums? (list e1 e2)) + ,(%inline logtest ,e1 ,e2) + ,(build-libcall #t src sexpr logtest e1 e2)))]) + (define-inline 3 $flhash + [(e) (bind #t (e) + `(if ,(build-fl= e e) + ,(%inline logand + ,(%inline srl + ,(constant-case ptr-bits + [(32) (%inline + + ,(%mref ,e ,(constant flonum-data-disp)) + ,(%mref ,e ,(fx+ (constant flonum-data-disp) 4)))] + [(64) (%mref ,e ,(constant flonum-data-disp))]) + (immediate 1)) + (immediate ,(- (constant fixnum-factor)))) + ;; +nan.0 + (immediate ,(fix #xfa1e))))]) + (let () + (define build-flonum-extractor + (lambda (pos size e1) + (let ([cnt (- pos (constant fixnum-offset))] + [mask (* (- (expt 2 size) 1) (expt 2 (constant fixnum-offset)))]) + (%inline logand + ,(let ([body (constant-case native-endianness + [(unknown) + (constant-case ptr-bits + [(64) + (%inline srl ,(%mref ,e1 ,(constant flonum-data-disp)) (immediate 32))] + [(32) + (inline ,(make-info-unboxed-args '(#t)) ,%fpcastto/hi ,e)])] + [else + `(inline ,(make-info-load 'integer-32 #f) ,%load ,e1 ,%zero + (immediate ,(constant-case native-endianness + [(little) (fx+ (constant flonum-data-disp) 4)] + [(big) (constant flonum-data-disp)])))])]) + (let ([body (if (fx> cnt 0) + (%inline srl ,body (immediate ,cnt)) + body)]) + (if (fx< cnt 0) + (%inline sll ,body (immediate ,(fx- 0 cnt))) + body))) + (immediate ,mask))))) + + (define-inline 3 fllp + [(e) (build-flonum-extractor 19 12 e)]) + + (define-inline 3 $flonum-sign + [(e) (build-flonum-extractor 31 1 e)]) + + (define-inline 3 $flonum-exponent + [(e) (build-flonum-extractor 20 11 e)])) + + (define-inline 3 $fleqv? + [(e1 e2) + (bind #t (e1 e2) + `(if ,(build-fl= e1 e1) ; check e1 not +nan.0 + ,(constant-case ptr-bits + [(32) (build-and + (%inline eq? + ,(%mref ,e1 ,(constant flonum-data-disp)) + ,(%mref ,e2 ,(constant flonum-data-disp))) + (%inline eq? + ,(%mref ,e1 ,(fx+ (constant flonum-data-disp) 4)) + ,(%mref ,e2 ,(fx+ (constant flonum-data-disp) 4))))] + [(64) (%inline eq? + ,(%mref ,e1 ,(constant flonum-data-disp)) + ,(%mref ,e2 ,(constant flonum-data-disp)))] + [else ($oops 'compiler-internal + "$fleqv doesn't handle ptr-bits = ~s" + (constant ptr-bits))]) + ;; If e1 is +nan.0, see if e2 is +nan.0: + ,(build-not (build-fl= e2 e2))))]) + + (let () + (define build-fp-op-1 + (lambda (op e) + (bind #f fp (e) + (if (procedure? op) (op e) `(unboxed-fp (inline ,(make-info-unboxed-args '(#t)) ,op ,e)))))) + (define build-fp-op-2 + (lambda (op e1 e2) + (bind #f fp (e1 e2) + (if (procedure? op) (op e1 e2) `(unboxed-fp (inline ,(make-info-unboxed-args '(#t #t)) ,op ,e1 ,e2)))))) + (define build-fl-adjust-sign + (lambda (e combine base) + `(unboxed-fp + ,(constant-case ptr-bits + [(64) + (let ([t (make-tmp 'flsgn)]) + `(let ([,t (inline ,(make-info-unboxed-args '(#t)) ,%fpcastto ,e)]) + (inline ,null-info ,%fpcastfrom (inline ,null-info ,combine ,t ,base))))] + [(32) + (let ([thi (make-tmp 'flsgnh)] + [tlo (make-tmp 'flsgnl)]) + (bind #t fp (e) + `(let ([,thi (inline ,(make-info-unboxed-args '(#t)) ,%fpcastto/hi ,e)] + [,tlo (inline ,(make-info-unboxed-args '(#t)) ,%fpcastto/lo ,e)]) + (inline ,null-info ,%fpcastfrom (inline ,null-info ,combine ,thi ,base) ,tlo))))])))) + (define build-flabs + (lambda (e) + (build-fl-adjust-sign e %logand (%inline srl (immediate -1) (immediate 1))))) + (define build-flneg + (lambda (e) + (build-fl-adjust-sign e %logxor (%inline sll (immediate -1) (immediate ,(fx- (constant ptr-bits) 1)))))) + (define build-fl-call + (lambda (entry . e*) + `(foreign-call ,(with-output-language (Ltype Type) + (make-info-foreign '(atomic) (map (lambda (e) `(fp-double-float)) e*) `(fp-double-float) #t)) + (literal ,(make-info-literal #f 'entry entry 0)) + ,e* ...))) + + (define-inline 3 fl+ + [() `(quote 0.0)] + [(e) (ensure-single-valued e)] + [(e1 e2) (build-fp-op-2 %fp+ e1 e2)] + [(e1 . e*) (reduce-fp src sexpr 3 'fl+ e1 e*)]) + + (define-inline 3 fl* + [() `(quote 1.0)] + [(e) (ensure-single-valued e)] + [(e1 e2) (build-fp-op-2 %fp* e1 e2)] + [(e1 . e*) (reduce-fp src sexpr 3 'fl* e1 e*)]) + + (define-inline 3 fl- + [(e) (build-flneg e)] + [(e1 e2) (build-fp-op-2 %fp- e1 e2)] + [(e1 . e*) (reduce-fp src sexpr 3 'fl- e1 e*)]) + + (define-inline 3 fl/ + [(e) (build-fp-op-2 %fp/ `(quote 1.0) e)] + [(e1 e2) (build-fp-op-2 %fp/ e1 e2)] + [(e1 . e*) (reduce-fp src sexpr 3 'fl/ e1 e*)]) + + (define-inline 3 flsqrt + [(e) + (constant-case architecture + [(x86 x86_64 arm32 arm64 pb) (build-fp-op-1 %fpsqrt e)] + [(ppc32) (build-fl-call (lookup-c-entry flsqrt) e)])]) + + (define-inline 3 flsingle + [(e) (build-fp-op-1 %fpsingle e)]) + + (define-inline 3 flabs + [(e) (build-flabs e)]) + + (let () + (define-syntax define-fl-call + (syntax-rules () + [(_ id extra ...) + (define-inline 3 id + [(e) (build-fl-call (lookup-c-entry id) e)] + extra ...)])) + (define-syntax define-fl2-call + (syntax-rules () + [(_ id id2) + (define-fl-call id + [(e1 e2) (build-fl-call (lookup-c-entry id2) e1 e2)])])) + (define-fl-call flround) ; no support in SSE2 for flround, though this was added in SSE4.1 + (define-fl-call flfloor) + (define-fl-call flceiling) + (define-fl-call fltruncate) + (define-fl-call flsin) + (define-fl-call flcos) + (define-fl-call fltan) + (define-fl-call flasin) + (define-fl-call flacos) + (define-fl2-call flatan flatan2) + (define-fl-call flexp) + (define-fl2-call fllog fllog2)) + + (define-inline 3 flexpt + [(e1 e2) (build-fl-call (lookup-c-entry flexpt) e1 e2)]) + + (let () + (define build-fl-make-rectangular + (lambda (e1 e2) + (bind #f (e1 e2) + (bind #t ([t (%constant-alloc type-typed-object (constant size-inexactnum))]) + (%seq + (set! ,(%mref ,t ,(constant inexactnum-type-disp)) + ,(%constant type-inexactnum)) + (set! ,(%mref ,t ,%zero ,(constant inexactnum-real-disp) fp) + ,(%mref ,e1 ,%zero ,(constant flonum-data-disp) fp)) + (set! ,(%mref ,t ,%zero ,(constant inexactnum-imag-disp) fp) + ,(%mref ,e2 ,%zero ,(constant flonum-data-disp) fp)) + ,t))))) + + (define-inline 3 fl-make-rectangular + [(e1 e2) (build-fl-make-rectangular e1 e2)]) + + (define-inline 3 cfl- + [(e) (bind #t (e) + `(if ,(%type-check mask-flonum type-flonum ,e) + ,(build-flneg e) + ,(build-fl-make-rectangular + (build-flneg (build-$inexactnum-real-part e)) + (build-flneg (build-$inexactnum-imag-part e)))))] + [(e1 e2) (build-libcall #f src sexpr cfl- e1 e2)] + ; TODO: add 3 argument version of cfl- library function + #;[(e1 e2 e3) (build-libcall #f src sexpr cfl- e1 e2 e3)] + [(e1 e2 . e*) #f]) + + (define-inline 3 cfl+ + [() `(quote 0.0)] + [(e) (ensure-single-valued e)] + [(e1 e2) (build-libcall #f src sexpr cfl+ e1 e2)] + ; TODO: add 3 argument version of cfl+ library function + #;[(e1 e2 e3) (build-libcall #f src sexpr cfl+ e1 e2 e3)] + [(e1 e2 . e*) #f]) + + (define-inline 3 cfl* + [() `(quote 1.0)] + [(e) (ensure-single-valued e)] + [(e1 e2) (build-libcall #f src sexpr cfl* e1 e2)] + ; TODO: add 3 argument version of cfl* library function + #;[(e1 e2 e3) (build-libcall #f src sexpr cfl* e1 e2 e3)] + [(e1 e2 . e*) #f]) + + (define-inline 3 cfl/ + [(e) (build-libcall #f src sexpr cfl/ `(quote 1.0) e)] + [(e1 e2) (build-libcall #f src sexpr cfl/ e1 e2)] + ; TODO: add 3 argument version of cfl/ library function + #;[(e1 e2 e3) (build-libcall #f src sexpr cfl/ e1 e2 e3)] + [(e1 e2 . e*) #f]) + + (define-inline 3 cfl-conjugate + [(e) (bind #t (e) + `(if ,(%type-check mask-flonum type-flonum ,e) + ,e + ,(build-fl-make-rectangular + (build-$inexactnum-real-part e) + (build-flneg (build-$inexactnum-imag-part e)))))])) + + (define-inline 3 $make-exactnum + [(e1 e2) (bind #f (e1 e2) + (bind #t ([t (%constant-alloc type-typed-object (constant size-exactnum))]) + (%seq + (set! ,(%mref ,t ,(constant exactnum-type-disp)) + ,(%constant type-exactnum)) + (set! ,(%mref ,t ,(constant exactnum-real-disp)) ,e1) + (set! ,(%mref ,t ,(constant exactnum-imag-disp)) ,e2) + ,t)))]) + + (let () + (define (build-fl< e1 e2) `(inline ,(make-info-unboxed-args '(#t #t)) ,%fp< ,e1 ,e2)) + (define build-fl= + (case-lambda + [(e) (if (constant nan-single-comparison-true?) + (%seq ,e (quote #t)) + (bind #t fp (e) (build-fl= e e)))] + [(e1 e2) (bind #f fp (e1 e2) + `(inline ,(make-info-unboxed-args '(#t #t)) ,%fp= ,e1 ,e2))])) + (define (build-fl<= e1 e2) `(inline ,(make-info-unboxed-args '(#t #t)) ,%fp<= ,e1 ,e2)) + + (let () + (define-syntax define-fl-cmp-inline + (lambda (x) + (syntax-case x () + [(_ op r6rs:op builder inequality? swapped?) + (with-syntax ([(args ...) (if (datum swapped?) #'(e2 e1) #'(e1 e2))] + [reducer (if (datum inequality?) + #'(reduce-fp-compare reduce-inequality) + #'(reduce-fp-compare reduce-equality))]) + #'(begin + (define-inline 3 op + [(e) (build-fl= e)] + [(e1 e2) (builder args ...)] + [(e1 e2 . e*) (reducer src sexpr moi e1 e2 e*)]) + (define-inline 3 r6rs:op + [(e1 e2) (builder args ...)] + [(e1 e2 . e*) (reducer src sexpr moi e1 e2 e*)])))]))) + + (define-fl-cmp-inline fl= fl=? build-fl= #f #f) + (define-fl-cmp-inline fl< fl<? build-fl< #t #f) + (define-fl-cmp-inline fl> fl>? build-fl< #t #t) + (define-fl-cmp-inline fl<= fl<=? build-fl<= #t #f) + (define-fl-cmp-inline fl>= fl>=? build-fl<= #t #t)) + (let () + (define-syntax build-bind-and-check + (syntax-rules () + [(_ src sexpr op e1 e2 body) + (if (known-flonum-result? e1) + (if (known-flonum-result? e2) + body + (bind #t (e2) + `(if ,(%type-check mask-flonum type-flonum ,e2) + ,body + ,(build-libcall #t src sexpr op e2 e2)))) + (if (known-flonum-result? e2) + (bind #t (e1) + `(if ,(%type-check mask-flonum type-flonum ,e1) + ,body + ,(build-libcall #t src sexpr op e1 e1))) + (bind #t (e1 e2) + `(if ,(build-and + (%type-check mask-flonum type-flonum ,e1) + (%type-check mask-flonum type-flonum ,e2)) + ,body + ,(build-libcall #t src sexpr op e1 e2)))))])) + (define build-check-fp-arguments + (lambda (e* build-libcall k) + (let loop ([e* e*] [check-e* '()] [all-e* '()]) + (cond + [(null? e*) + (let loop ([check-e* (reverse check-e*)]) + (cond + [(null? check-e*) (apply k (reverse all-e*))] + [(null? (cdr check-e*)) + (let ([e1 (car check-e*)]) + `(if ,(%type-check mask-flonum type-flonum ,e1) + ,(loop '()) + ,(build-libcall e1 e1)))] + [else + (let ([e1 (car check-e*)] + [e2 (cadr check-e*)]) + `(if ,(build-and + (%type-check mask-flonum type-flonum ,e1) + (%type-check mask-flonum type-flonum ,e2)) + ,(loop (cddr check-e*)) + ,(build-libcall e1 e2)))]))] + [else + (let ([e1 (car e*)]) + (if (known-flonum-result? e1) + (loop (cdr e*) check-e* (cons e1 all-e*)) + (bind #t (e1) + (loop (cdr e*) (cons e1 check-e*) (cons e1 all-e*)))))])))) + (define-syntax define-fl-cmp-inline + (lambda (x) + (syntax-case x () + [(_ op r6rs:op builder inequality? swapped?) + (with-syntax ([(args ...) (if (datum swapped?) #'(e2 e1) #'(e1 e2))] + [reducer (if (datum inequality?) + #'(reduce-fp-compare reduce-inequality) + #'(reduce-fp-compare reduce-equality))]) + #'(begin + (define-inline 2 op + [(e1) (if (known-flonum-result? e1) + (build-fl= e1) + (bind #t (e1) + `(if ,(%type-check mask-flonum type-flonum ,e1) + ,(build-fl= e1) + ,(build-libcall #t src sexpr op e1 e1))))] + [(e1 e2) (build-bind-and-check src sexpr op e1 e2 (builder args ...))] + [(e1 e2 . e*) (and + (fx<= (length e*) (fx- inline-args-limit 2)) + (build-check-fp-arguments (cons* e1 e2 e*) + (lambda (e1 e2) (build-libcall #t src sexpr op e1 e2)) + (lambda (e1 e2 . e*) (reducer src sexpr moi e1 e2 e*))))]) + (define-inline 2 r6rs:op + [(e1 e2) (build-bind-and-check src sexpr r6rs:op e1 e2 (builder args ...))] + [(e1 e2 . e*) (and + (fx<= (length e*) (fx- inline-args-limit 2)) + (build-check-fp-arguments (cons* e1 e2 e*) + (lambda (e1 e2) (build-libcall #t src sexpr r6rs:op e1 e2)) + (lambda (e1 e2 . e*) (reducer src sexpr moi e1 e2 e*))))])))]))) + + (define-fl-cmp-inline fl= fl=? build-fl= #f #f) + (define-fl-cmp-inline fl< fl<? build-fl< #t #f) + (define-fl-cmp-inline fl> fl>? build-fl< #t #t) + (define-fl-cmp-inline fl<= fl<=? build-fl<= #t #f) + (define-fl-cmp-inline fl>= fl>=? build-fl<= #t #t)) + (let () + (define build-cfl= + ; NB: e1 and e2 must be bound + (lambda (e1 e2) + `(if ,(%type-check mask-flonum type-flonum ,e1) + (if ,(%type-check mask-flonum type-flonum ,e2) + ,(build-fl= e1 e2) + ,(build-and + (build-fl= `(quote 0.0) (build-$inexactnum-imag-part e2)) + (build-fl= e1 (build-$inexactnum-real-part e2)))) + (if ,(%type-check mask-flonum type-flonum ,e2) + ,(build-and + (build-fl= `(quote 0.0) (build-$inexactnum-imag-part e1)) + (build-fl= e2 (build-$inexactnum-real-part e1))) + ,(build-and + (build-fl= + (build-$inexactnum-imag-part e1) + (build-$inexactnum-imag-part e2)) + (build-fl= + (build-$inexactnum-real-part e1) + (build-$inexactnum-real-part e2))))))) + (define-inline 3 cfl= + [(e) (if (constant nan-single-comparison-true?) + (%seq ,e (quote #t)) + (bind #f (e) (build-cfl= e e)))] + [(e1 e2) (bind #f (e1 e2) (build-cfl= e1 e2))] + ; TODO: should we avoid building for more then the 3 item case? + [(e1 e2 . e*) (reduce-equality src sexpr moi e1 e2 e*)]))) + + (let () + (define build-checked-fp-op + (case-lambda + [(e k) + (if (known-flonum-result? e) + e + (bind #t (e) + `(if ,(build-flonums? (list e)) + ,e + ,(k e))))] + [(e1 op k) ; `op` can be a procedure that produces an unboxed value + (if (known-flonum-result? e1) + (build-fp-op-1 op e1) + (bind #t (e1) + (let ([e (build-fp-op-1 op e1)] + [k (lambda (e) + `(if ,(build-flonums? (list e1)) + ,e + ,(k e1)))]) + ((lift-fp-unboxed k) e))))] + [(e1 e2 op k) ; `op` can be a procedure that produces an unboxed value + ;; uses result of `e1` or `e2` twice for error if other is always a flonum + (let ([build (lambda (e1 e2) + (build-fp-op-2 op e1 e2))]) + (if (known-flonum-result? e1) + (if (known-flonum-result? e2) + (build e1 e2) + (bind #t (e2) + (build e1 `(if ,(build-flonums? (list e2)) + ,e2 + ,(k e2 e2))))) + (if (known-flonum-result? e2) + (bind #t (e1) + (build `(if ,(build-flonums? (list e1)) + ,e1 + ,(k e1 e1)) + e2)) + (bind #t (e1 e2) + (let ([e (build e1 e2)] + [k (lambda (e) + `(if ,(build-flonums? (list e1 e2)) + ,e + ,(k e1 e2)))]) + ((lift-fp-unboxed k) e))))))])) + + (define-inline 2 fl+ + [() `(quote 0.0)] + [(e) (build-checked-fp-op e + (lambda (e) + (build-libcall #t src sexpr fl+ e `(quote 0.0))))] + [(e1 e2) (build-checked-fp-op e1 e2 %fp+ + (lambda (e1 e2) + (build-libcall #t src sexpr fl+ e1 e2)))] + [(e1 . e*) (reduce-fp src sexpr 2 'fl+ e1 e*)]) + + (define-inline 2 fl* + [() `(quote 1.0)] + [(e) (build-checked-fp-op e + (lambda (e) + (build-libcall #t src sexpr fl* e `(quote 1.0))))] + [(e1 e2) (build-checked-fp-op e1 e2 %fp* + (lambda (e1 e2) + (build-libcall #t src sexpr fl* e1 e2)))] + [(e1 . e*) (reduce-fp src sexpr 2 'fl* e1 e*)]) + + (define-inline 2 fl- + [(e) (build-checked-fp-op e build-flneg + (lambda (e) + (build-libcall #t src sexpr flnegate e)))] + [(e1 e2) (build-checked-fp-op e1 e2 %fp- + (lambda (e1 e2) + (build-libcall #t src sexpr fl- e1 e2)))] + [(e1 . e*) (reduce-fp src sexpr 2 'fl- e1 e*)]) + + (define-inline 2 fl/ + [(e) (build-checked-fp-op `(quote 1.0) e %fp/ + (lambda (e1 e2) + (build-libcall #t src sexpr fl/ e1 e2)))] + [(e1 e2) (build-checked-fp-op e1 e2 %fp/ + (lambda (e1 e2) + (build-libcall #t src sexpr fl/ e1 e2)))] + [(e1 . e*) (reduce-fp src sexpr 2 'fl/ e1 e*)]) + + (define-inline 2 flabs + [(e) (build-checked-fp-op e build-flabs + (lambda (e) + (build-libcall #t src sexpr flabs e)))]) + + (define-inline 2 flsqrt + [(e) + (build-checked-fp-op e + (lambda (e) + (constant-case architecture + [(x86 x86_64 arm32 arm64 pb) (build-fp-op-1 %fpsqrt e)] + [(ppc32) (build-fl-call (lookup-c-entry flsqrt) e)])) + (lambda (e) + (build-libcall #t src sexpr flsqrt e)))]) + + (define-inline 2 flsingle + [(e) + (build-checked-fp-op e + (lambda (e) (build-fp-op-1 %fpsingle e)) + (lambda (e) + (build-libcall #t src sexpr flsingle e)))]) + + (let () + (define-syntax define-fl-call + (syntax-rules () + [(_ id) + (define-inline 2 id + [(e) (build-checked-fp-op e (lambda (e) (build-fl-call (lookup-c-entry id) e)) + (lambda (e) + (build-libcall #t src sexpr id e)))])])) + (define-syntax define-fl2-call + (syntax-rules () + [(_ id id2) + (define-inline 2 id + [(e) (build-checked-fp-op e (lambda (e) (build-fl-call (lookup-c-entry id) e)) + (lambda (e) + (build-libcall #t src sexpr id e)))] + [(e1 e2) (build-checked-fp-op e1 e2 (lambda (e1 e2) (build-fl-call (lookup-c-entry id2) e1 e2)) + (lambda (e1 e2) + (build-libcall #t src sexpr id2 e1 e2)))])])) + (define-fl-call flround) + (define-fl-call flfloor) + (define-fl-call flceiling) + (define-fl-call fltruncate) + (define-fl-call flsin) + (define-fl-call flcos) + (define-fl-call fltan) + (define-fl-call flasin) + (define-fl-call flacos) + (define-fl2-call flatan flatan2) + (define-fl-call flexp) + (define-fl2-call fllog fllog2)) + + (define-inline 2 flexpt + [(e1 e2) (build-checked-fp-op e1 e2 + (lambda (e1 e2) (build-fl-call (lookup-c-entry flexpt) e1 e2)) + (lambda (e1 e2) + (build-libcall #t src sexpr flexpt e1 e2)))]) + + ;; NB: assuming that we have a trunc instruction for now, will need to change to support Sparc + (define-inline 3 flonum->fixnum + [(e-x) (bind #f fp (e-x) + (build-fix + `(inline ,(make-info-unboxed-args '(#t)) ,%fptrunc ,e-x)))]) + (define-inline 2 flonum->fixnum + [(e-x) (build-checked-fp-op e-x + (lambda (e-x) + (define (build-fl< e1 e2) `(inline ,(make-info-unboxed-args '(#t #t)) ,%fp< ,e1 ,e2)) + (bind #t (e-x) + `(if ,(build-and + (build-fl< e-x `(quote ,(constant too-positive-flonum-for-fixnum))) + (build-fl< `(quote ,(constant too-negative-flonum-for-fixnum)) e-x)) + ,(build-fix + `(inline ,(make-info-unboxed-args '(#t)) ,%fptrunc ,e-x)) + ;; We have to box the flonum to report an error: + ,(let ([t (make-tmp 't)]) + `(let ([,t ,(%constant-alloc type-flonum (constant size-flonum))]) + (seq + (set! ,(%mref ,t ,%zero ,(constant flonum-data-disp) fp) ,e-x) + ,(build-libcall #t src sexpr flonum->fixnum t))))))) + (lambda (e-x) + (build-libcall #t src sexpr flonum->fixnum e-x)))]))) + + (let () + (define build-fixnum->flonum + ; NB: x must already be bound in order to ensure it is done before the flonum is allocated + (lambda (e-x k) + (k `(unboxed-fp ,(%inline fpt ,(build-unfix e-x)))))) + (define-inline 3 fixnum->flonum + [(e-x) (bind #f (e-x) (build-fixnum->flonum e-x values))]) + (define-inline 2 fixnum->flonum + [(e-x) (bind #t (e-x) + (build-fixnum->flonum e-x + (lift-fp-unboxed + (lambda (e) + `(if ,(%type-check mask-fixnum type-fixnum ,e-x) + ,e + ,(build-libcall #t src sexpr fixnum->flonum e-x))))))]) + (define-inline 2 real->flonum + [(e-x) + (if (known-flonum-result? e-x) + e-x + (bind #t (e-x) + `(if ,(%type-check mask-fixnum type-fixnum ,e-x) + ,(build-fixnum->flonum e-x values) + (if ,(%type-check mask-flonum type-flonum ,e-x) + ,e-x + ,(build-libcall #t src sexpr real->flonum e-x `(quote real->flonum))))))])) + (define-inline 3 $real->flonum + [(x who) (build-$real->flonum src sexpr x who)]) + (define-inline 2 $record + [(tag . args) (build-$record tag args)]) + (define-inline 3 $object-address + [(e-ptr e-offset) + (unsigned->ptr + (%inline + ,e-ptr ,(build-unfix e-offset)) + (type->width ptr-type))]) + (define-inline 3 $address->object + [(e-addr e-roffset) + (bind #f (e-roffset) + (%inline - + ,(ptr->integer e-addr (type->width ptr-type)) + ,(build-unfix e-roffset)))]) + (define-inline 3 object->reference-address + [(e-ptr) (bind #t (e-ptr) + `(if ,(%inline eq? ,e-ptr (immediate ,(constant sfalse))) + (immediate 0) + ,(unsigned->ptr (%inline + ,e-ptr ,(%constant reference-disp)) (type->width ptr-type))))]) + (define-inline 3 reference-address->object + [(e-ptr) (bind #t (e-ptr) + `(if ,(%inline eq? ,e-ptr (immediate 0)) + (immediate ,(constant sfalse)) + ,(%inline - ,(ptr->integer e-ptr (type->width ptr-type)) ,(%constant reference-disp))))]) + (define-inline 2 $object-ref + [(type base offset) + (nanopass-case (L7 Expr) type + [(quote ,d) + (let ([type (filter-foreign-type d)]) + (and (memq type (record-datatype list)) + (not (memq type '(char wchar boolean))) + (build-object-ref #f type base offset)))] + [else #f])]) + (define-inline 2 $swap-object-ref + [(type base offset) + (nanopass-case (L7 Expr) type + [(quote ,d) + (let ([type (filter-foreign-type d)]) + (and (memq type (record-datatype list)) + (not (memq type '(char wchar boolean))) + (build-object-ref #t type base offset)))] + [else #f])]) + (define-inline 3 foreign-ref + [(e-type e-addr e-offset) + (nanopass-case (L7 Expr) e-type + [(quote ,d) + (let ([type (filter-foreign-type d)]) + (and (memq type (record-datatype list)) + (not (memq type '(char wchar boolean))) + (bind #f (e-offset) + (build-object-ref #f type + (ptr->integer e-addr (constant ptr-bits)) + e-offset))))] + [else #f])]) + (define-inline 3 $foreign-swap-ref + [(e-type e-addr e-offset) + (nanopass-case (L7 Expr) e-type + [(quote ,d) + (let ([type (filter-foreign-type d)]) + (and (memq type (record-datatype list)) + (not (memq type '(char wchar boolean))) + (bind #f (e-offset) + (build-object-ref #t type + (ptr->integer e-addr (constant ptr-bits)) + e-offset))))] + [else #f])]) + (define-inline 2 $object-set! + [(type base offset value) + (nanopass-case (L7 Expr) type + [(quote ,d) + (let ([type (filter-foreign-type d)]) + (and (memq type (record-datatype list)) + (not (memq type '(char wchar boolean))) + (or (>= (constant ptr-bits) (type->width type)) (eq? type 'double-float)) + (build-object-set! type base offset value)))] + [else #f])]) + (define-inline 3 foreign-set! + [(e-type e-addr e-offset e-value) + (nanopass-case (L7 Expr) e-type + [(quote ,d) + (let ([type (filter-foreign-type d)]) + (and (memq type (record-datatype list)) + (not (memq type '(char wchar boolean))) + (or (>= (constant ptr-bits) (type->width type)) (eq? type 'double-float)) + (bind #f (e-offset e-value) + (build-object-set! type + (ptr->integer e-addr (constant ptr-bits)) + e-offset + e-value))))] + [else #f])]) + (define-inline 3 $foreign-swap-set! + [(e-type e-addr e-offset e-value) + (nanopass-case (L7 Expr) e-type + [(quote ,d) + (let ([type (filter-foreign-type d)]) + (and (memq type (record-datatype list)) + (not (memq type '(char wchar boolean single-float))) + (>= (constant ptr-bits) (type->width type)) + (bind #f (e-offset e-value) + (build-swap-object-set! type + (ptr->integer e-addr (constant ptr-bits)) + e-offset + e-value))))] + [else #f])]) + (define-inline 2 $make-fptr + [(e-ftype e-addr) + (nanopass-case (L7 Expr) e-addr + [(call ,info ,mdcl ,pr ,e1) + (guard + (eq? (primref-name pr) 'ftype-pointer-address) + (all-set? (prim-mask unsafe) (primref-flags pr))) + (bind #f (e-ftype e1) + (bind #t ([t (%constant-alloc type-typed-object (fx* 2 (constant ptr-bytes)))]) + (%seq + (set! ,(%mref ,t ,(constant record-type-disp)) ,e-ftype) + (set! ,(%mref ,t ,(constant record-data-disp)) + ,(%mref ,e1 ,(constant record-data-disp))) + ,t)))] + [else + (bind #f (e-ftype e-addr) + (bind #t ([t (%constant-alloc type-typed-object (fx* 2 (constant ptr-bytes)))]) + (%seq + (set! ,(%mref ,t ,(constant record-type-disp)) ,e-ftype) + (set! ,(%mref ,t ,(constant record-data-disp)) + ,(ptr->integer e-addr (constant ptr-bits))) + ,t)))])]) + (define-inline 3 ftype-pointer-address + [(e-fptr) + (build-object-ref #f + (constant-case ptr-bits + [(64) 'unsigned-64] + [(32) 'unsigned-32]) + e-fptr %zero (constant record-data-disp))]) + (define-inline 3 ftype-pointer-null? + [(e-fptr) (make-ftype-pointer-null? e-fptr)]) + (define-inline 3 ftype-pointer=? + [(e1 e2) (make-ftype-pointer-equal? e1 e2)]) + (let () + (define build-fx+raw + (lambda (fx-arg raw-arg) + (if (constant? (lambda (x) (eqv? x 0)) fx-arg) + raw-arg + (%inline + ,raw-arg ,(build-unfix fx-arg))))) + (define $extract-fptr-address + (lambda (e-fptr) + (define suppress-unsafe-cast + (lambda (e-fptr) + (nanopass-case (L7 Expr) e-fptr + [(call ,info1 ,mdcl1 ,pr1 (quote ,d) (call ,info2 ,mdcl2 ,pr2 ,e)) + (guard + (eq? (primref-name pr1) '$make-fptr) + (all-set? (prim-mask unsafe) (primref-flags pr2)) + (eq? (primref-name pr2) 'ftype-pointer-address) + (all-set? (prim-mask unsafe) (primref-flags pr2))) + e] + [else e-fptr]))) + (nanopass-case (L7 Expr) e-fptr + ; skip allocation and dereference of ftype-pointer for $fptr-fptr-ref + [(call ,info ,mdcl ,pr ,e1 ,e2 ,e3) ; e1, e2, e3 = fptr, offset, ftd + (guard + (eq? (primref-name pr) '$fptr-fptr-ref) + (all-set? (prim-mask unsafe) (primref-flags pr))) + (let-values ([(e-index imm-offset) (offset-expr->index+offset e2)]) + (bind #f (e-index e3) + `(inline ,(make-info-load ptr-type #f) ,%load + ,($extract-fptr-address e1) + ,e-index (immediate ,imm-offset))))] + ; skip allocation and dereference of ftype-pointer for $fptr-&ref + [(call ,info ,mdcl ,pr ,e1 ,e2 ,e3) ; e1, e2, e3 = fptr, offset, ftd + (guard + (eq? (primref-name pr) '$fptr-&ref) + (all-set? (prim-mask unsafe) (primref-flags pr))) + (build-fx+raw e2 ($extract-fptr-address e1))] + ; skip allocation and dereference of ftype-pointer for $make-fptr + [(call ,info ,mdcl ,pr ,e1 ,e2) ; e1, e2 = ftd, (ptr) addr + (guard + (eq? (primref-name pr) '$make-fptr) + (all-set? (prim-mask unsafe) (primref-flags pr))) + (nanopass-case (L7 Expr) e2 + [(call ,info ,mdcl ,pr ,e3) + (guard + (eq? (primref-name pr) 'ftype-pointer-address) + (all-set? (prim-mask unsafe) (primref-flags pr))) + (bind #f (e1) + (%mref ,e3 ,(constant record-data-disp)))] + [else + (bind #f (e1) + (ptr->integer e2 (constant ptr-bits)))])] + [else + `(inline ,(make-info-load ptr-type #f) ,%load ,(suppress-unsafe-cast e-fptr) ,%zero + ,(%constant record-data-disp))]))) + (let () + (define-inline 3 $fptr-offset-addr + [(e-fptr e-offset) + ; bind offset before doing the load (a) to maintain applicative order---the + ; load can cause an invalid memory reference---and (b) so that the raw value + ; isn't live across any calls + (bind #f (e-offset) + (build-fx+raw e-offset + ($extract-fptr-address e-fptr)))]) + (define-inline 3 $fptr-&ref + [(e-fptr e-offset e-ftd) + ; see comment in $fptr-offset-addr + (bind #f (e-offset e-ftd) + (build-$record e-ftd + (list (build-fx+raw e-offset ($extract-fptr-address e-fptr)))))])) + (define-inline 3 $fptr-fptr-ref + [(e-fptr e-offset e-ftd) + (let-values ([(e-index imm-offset) (offset-expr->index+offset e-offset)]) + (bind #f (e-index) + (build-$record e-ftd + (list `(inline ,(make-info-load ptr-type #f) ,%load + ,($extract-fptr-address e-fptr) + ,e-index (immediate ,imm-offset))))))]) + (define-inline 3 $fptr-fptr-set! + [(e-fptr e-offset e-val) + (let-values ([(e-index imm-offset) (offset-expr->index+offset e-offset)]) + (bind #f ([e-addr ($extract-fptr-address e-fptr)] e-index e-val) + `(inline ,(make-info-load ptr-type #f) ,%store ,e-addr ,e-index (immediate ,imm-offset) + (inline ,(make-info-load ptr-type #f) ,%load ,e-val ,%zero + ,(%constant record-data-disp)))))]) + (let () + (define $do-fptr-ref-inline + (lambda (swapped? type e-fptr e-offset) + (bind #f (e-offset) + (build-object-ref swapped? type ($extract-fptr-address e-fptr) e-offset)))) + (define-syntax define-fptr-ref-inline + (lambda (x) + (define build-inline + (lambda (name type ref maybe-k) + #`(define-inline 3 #,name + [(e-fptr e-offset) + #,((lambda (body) (if maybe-k #`(#,maybe-k #,body) body)) + #`($do-fptr-ref-inline #,ref #,type e-fptr e-offset))]))) + (syntax-case x () + [(_ name ?type ref) (build-inline #'name #'?type #'ref #f)] + [(_ name ?type ref ?k) (build-inline #'name #'?type #'ref #'?k)]))) + + (define-fptr-ref-inline $fptr-ref-integer-8 'integer-8 #f) + (define-fptr-ref-inline $fptr-ref-unsigned-8 'unsigned-8 #f) + + (define-fptr-ref-inline $fptr-ref-integer-16 'integer-16 #f) + (define-fptr-ref-inline $fptr-ref-unsigned-16 'unsigned-16 #f) + (define-fptr-ref-inline $fptr-ref-swap-integer-16 'integer-16 #t) + (define-fptr-ref-inline $fptr-ref-swap-unsigned-16 'unsigned-16 #t) + + (when-known-endianness + (define-fptr-ref-inline $fptr-ref-integer-24 'integer-24 #f) + (define-fptr-ref-inline $fptr-ref-unsigned-24 'unsigned-24 #f) + (define-fptr-ref-inline $fptr-ref-swap-integer-24 'integer-24 #t) + (define-fptr-ref-inline $fptr-ref-swap-unsigned-24 'unsigned-24 #t)) + + (define-fptr-ref-inline $fptr-ref-integer-32 'integer-32 #f) + (define-fptr-ref-inline $fptr-ref-unsigned-32 'unsigned-32 #f) + (define-fptr-ref-inline $fptr-ref-swap-integer-32 'integer-32 #t) + (define-fptr-ref-inline $fptr-ref-swap-unsigned-32 'unsigned-32 #t) + + (when-known-endianness + (define-fptr-ref-inline $fptr-ref-integer-40 'integer-40 #f) + (define-fptr-ref-inline $fptr-ref-unsigned-40 'unsigned-40 #f) + (define-fptr-ref-inline $fptr-ref-swap-integer-40 'integer-40 #t) + (define-fptr-ref-inline $fptr-ref-swap-unsigned-40 'unsigned-40 #t) + + (define-fptr-ref-inline $fptr-ref-integer-48 'integer-48 #f) + (define-fptr-ref-inline $fptr-ref-unsigned-48 'unsigned-48 #f) + (define-fptr-ref-inline $fptr-ref-swap-integer-48 'integer-48 #t) + (define-fptr-ref-inline $fptr-ref-swap-unsigned-48 'unsigned-48 #t) + + (define-fptr-ref-inline $fptr-ref-integer-56 'integer-56 #f) + (define-fptr-ref-inline $fptr-ref-unsigned-56 'unsigned-56 #f) + (define-fptr-ref-inline $fptr-ref-swap-integer-56 'integer-56 #t) + (define-fptr-ref-inline $fptr-ref-swap-unsigned-56 'unsigned-56 #t)) + + (define-fptr-ref-inline $fptr-ref-integer-64 'integer-64 #f) + (define-fptr-ref-inline $fptr-ref-unsigned-64 'unsigned-64 #f) + (define-fptr-ref-inline $fptr-ref-swap-integer-64 'integer-64 #t) + (define-fptr-ref-inline $fptr-ref-swap-unsigned-64 'unsigned-64 #t) + + (define-fptr-ref-inline $fptr-ref-double-float 'double-float #f) + (define-fptr-ref-inline $fptr-ref-swap-double-float 'double-float #t) + + (define-fptr-ref-inline $fptr-ref-single-float 'single-float #f) + (define-fptr-ref-inline $fptr-ref-swap-single-float 'single-float #t) + + (define-fptr-ref-inline $fptr-ref-char 'unsigned-8 #f + (lambda (x) (build-integer->char x))) + + (define-fptr-ref-inline $fptr-ref-wchar + (constant-case wchar-bits [(16) 'unsigned-16] [(32) 'unsigned-32]) + #f + (lambda (x) (build-integer->char x))) + (define-fptr-ref-inline $fptr-ref-swap-wchar + (constant-case wchar-bits [(16) 'unsigned-16] [(32) 'unsigned-32]) + #t + (lambda (x) (build-integer->char x))) + + (define-fptr-ref-inline $fptr-ref-boolean + (constant-case int-bits [(32) 'unsigned-32] [(64) 'unsigned-64]) + #f + (lambda (x) + `(if ,(%inline eq? ,x (immediate 0)) + ,(%constant sfalse) + ,(%constant strue)))) + (define-fptr-ref-inline $fptr-ref-swap-boolean + (constant-case int-bits [(32) 'unsigned-32] [(64) 'unsigned-64]) + #t + (lambda (x) + `(if ,(%inline eq? ,x (immediate 0)) + ,(%constant sfalse) + ,(%constant strue)))) + + (define-fptr-ref-inline $fptr-ref-fixnum 'fixnum #f) + (define-fptr-ref-inline $fptr-ref-swap-fixnum 'fixnum #t)) + (let () + (define $do-fptr-set!-inline + (lambda (set type e-fptr e-offset e-val) + (bind #f (e-offset) + (set type ($extract-fptr-address e-fptr) e-offset e-val)))) + (define-syntax define-fptr-set!-inline + (lambda (x) + (define build-body + (lambda (type set maybe-massage-val) + #``(seq ,e-info + #,(let ([body #`($do-fptr-set!-inline #,set #,type e-fptr e-offset e-val)]) + (if maybe-massage-val + #`,(bind #f (e-offset [e-val (#,maybe-massage-val e-val)]) #,body) + #`,(bind #f (e-offset e-val) #,body)))))) + (define build-inline + (lambda (name check-64? body) + #`(define-inline 3 #,name + [(e-info e-fptr e-offset e-val) + #,(if check-64? + #`(and (fx>= (constant ptr-bits) 64) #,body) + body)]))) + (syntax-case x () + [(_ check-64? name ?type set) + (build-inline #'name (datum check-64?) (build-body #'?type #'set #f))] + [(_ check-64? name ?type set ?massage-value) + (build-inline #'name (datum check-64?) (build-body #'?type #'set #'?massage-value))]))) + + (define-fptr-set!-inline #f $fptr-set-integer-8! 'integer-8 build-object-set!) + (define-fptr-set!-inline #f $fptr-set-unsigned-8! 'unsigned-8 build-object-set!) + + (define-fptr-set!-inline #f $fptr-set-integer-16! 'integer-16 build-object-set!) + (define-fptr-set!-inline #f $fptr-set-unsigned-16! 'unsigned-16 build-object-set!) + (define-fptr-set!-inline #f $fptr-set-swap-integer-16! 'integer-16 build-swap-object-set!) + (define-fptr-set!-inline #f $fptr-set-swap-unsigned-16! 'unsigned-16 build-swap-object-set!) + + (when-known-endianness + (define-fptr-set!-inline #f $fptr-set-integer-24! 'integer-24 build-object-set!) + (define-fptr-set!-inline #f $fptr-set-unsigned-24! 'unsigned-24 build-object-set!) + (define-fptr-set!-inline #f $fptr-set-swap-integer-24! 'integer-24 build-swap-object-set!) + (define-fptr-set!-inline #f $fptr-set-swap-unsigned-24! 'unsigned-24 build-swap-object-set!)) + + (define-fptr-set!-inline #f $fptr-set-integer-32! 'integer-32 build-object-set!) + (define-fptr-set!-inline #f $fptr-set-unsigned-32! 'unsigned-32 build-object-set!) + (define-fptr-set!-inline #f $fptr-set-swap-integer-32! 'integer-32 build-swap-object-set!) + (define-fptr-set!-inline #f $fptr-set-swap-unsigned-32! 'unsigned-32 build-swap-object-set!) + + (when-known-endianness + (define-fptr-set!-inline #t $fptr-set-integer-40! 'integer-40 build-object-set!) + (define-fptr-set!-inline #t $fptr-set-unsigned-40! 'unsigned-40 build-object-set!) + (define-fptr-set!-inline #t $fptr-set-swap-integer-40! 'integer-40 build-swap-object-set!) + (define-fptr-set!-inline #t $fptr-set-swap-unsigned-40! 'unsigned-40 build-swap-object-set!) + + (define-fptr-set!-inline #t $fptr-set-integer-48! 'integer-48 build-object-set!) + (define-fptr-set!-inline #t $fptr-set-unsigned-48! 'unsigned-48 build-object-set!) + (define-fptr-set!-inline #t $fptr-set-swap-integer-48! 'integer-48 build-swap-object-set!) + (define-fptr-set!-inline #t $fptr-set-swap-unsigned-48! 'unsigned-48 build-swap-object-set!) + + (define-fptr-set!-inline #t $fptr-set-integer-56! 'integer-56 build-object-set!) + (define-fptr-set!-inline #t $fptr-set-unsigned-56! 'unsigned-56 build-object-set!) + (define-fptr-set!-inline #t $fptr-set-swap-integer-56! 'integer-56 build-swap-object-set!) + (define-fptr-set!-inline #t $fptr-set-swap-unsigned-56! 'unsigned-56 build-swap-object-set!)) + + (define-fptr-set!-inline #t $fptr-set-integer-64! 'integer-64 build-object-set!) + (define-fptr-set!-inline #t $fptr-set-unsigned-64! 'unsigned-64 build-object-set!) + (define-fptr-set!-inline #t $fptr-set-swap-integer-64! 'integer-64 build-swap-object-set!) + (define-fptr-set!-inline #t $fptr-set-swap-unsigned-64! 'unsigned-64 build-swap-object-set!) + + (define-fptr-set!-inline #f $fptr-set-double-float! 'double-float build-object-set!) + (define-fptr-set!-inline #t $fptr-set-swap-double-float! 'double-float build-swap-object-set!) + + (define-fptr-set!-inline #f $fptr-set-single-float! 'single-float build-object-set!) + + (define-fptr-set!-inline #f $fptr-set-char! 'unsigned-8 build-object-set! + (lambda (z) (build-char->integer z))) + + (define-fptr-set!-inline #f $fptr-set-wchar! + (constant-case wchar-bits + [(16) 'unsigned-16] + [(32) 'unsigned-32]) + build-object-set! + (lambda (z) (build-char->integer z))) + (define-fptr-set!-inline #f $fptr-set-swap-wchar! + (constant-case wchar-bits + [(16) 'unsigned-16] + [(32) 'unsigned-32]) + build-swap-object-set! + (lambda (z) (build-char->integer z))) + + (define-fptr-set!-inline #f $fptr-set-boolean! + (constant-case int-bits + [(32) 'unsigned-32] + [(64) 'unsigned-64]) + build-object-set! + (lambda (z) `(if ,z (immediate ,(fix 1)) (immediate ,(fix 0))))) + (define-fptr-set!-inline #f $fptr-set-swap-boolean! + (constant-case int-bits + [(32) 'unsigned-32] + [(64) 'unsigned-64]) + build-swap-object-set! + (lambda (z) `(if ,z (immediate ,(fix 1)) (immediate ,(fix 0))))) + + (define-fptr-set!-inline #f $fptr-set-fixnum! 'fixnum build-object-set!) + (define-fptr-set!-inline #f $fptr-set-swap-fixnum! 'fixnum build-swap-object-set!)) + (let () + (define-syntax define-fptr-bits-ref-inline + (lambda (x) + (syntax-case x () + [(_ name signed? type swapped?) + #'(define-inline 3 name + [(e-fptr e-offset e-start e-end) + (and (fixnum-constant? e-start) (fixnum-constant? e-end) + (let ([imm-start (constant-value e-start)] [imm-end (constant-value e-end)]) + (and (<= (type->width 'type) (constant ptr-bits)) + (and (fx>= imm-start 0) (fx> imm-end imm-start) (fx<= imm-end (constant ptr-bits))) + ((if signed? fx<= fx<) (fx- imm-end imm-start) (constant fixnum-bits)) + (let-values ([(e-index imm-offset) (offset-expr->index+offset e-offset)]) + (bind #f (e-index) + (build-int-load swapped? 'type ($extract-fptr-address e-fptr) e-index imm-offset + (lambda (x) + ((if signed? extract-signed-bitfield extract-unsigned-bitfield) #t imm-start imm-end x))))))))])]))) + + (define-fptr-bits-ref-inline $fptr-ref-ibits-unsigned-8 #t unsigned-8 #f) + (define-fptr-bits-ref-inline $fptr-ref-ubits-unsigned-8 #f unsigned-8 #f) + + (define-fptr-bits-ref-inline $fptr-ref-ibits-unsigned-16 #t unsigned-16 #f) + (define-fptr-bits-ref-inline $fptr-ref-ubits-unsigned-16 #f unsigned-16 #f) + (define-fptr-bits-ref-inline $fptr-ref-ibits-swap-unsigned-16 #t unsigned-16 #t) + (define-fptr-bits-ref-inline $fptr-ref-ubits-swap-unsigned-16 #f unsigned-16 #t) + + (when-known-endianness + (define-fptr-bits-ref-inline $fptr-ref-ibits-unsigned-24 #t unsigned-24 #f) + (define-fptr-bits-ref-inline $fptr-ref-ubits-unsigned-24 #f unsigned-24 #f) + (define-fptr-bits-ref-inline $fptr-ref-ibits-swap-unsigned-24 #t unsigned-24 #t) + (define-fptr-bits-ref-inline $fptr-ref-ubits-swap-unsigned-24 #f unsigned-24 #t)) + + (define-fptr-bits-ref-inline $fptr-ref-ibits-unsigned-32 #t unsigned-32 #f) + (define-fptr-bits-ref-inline $fptr-ref-ubits-unsigned-32 #f unsigned-32 #f) + (define-fptr-bits-ref-inline $fptr-ref-ibits-swap-unsigned-32 #t unsigned-32 #t) + (define-fptr-bits-ref-inline $fptr-ref-ubits-swap-unsigned-32 #f unsigned-32 #t) + + (when-known-endianness + (define-fptr-bits-ref-inline $fptr-ref-ibits-unsigned-40 #t unsigned-40 #f) + (define-fptr-bits-ref-inline $fptr-ref-ubits-unsigned-40 #f unsigned-40 #f) + (define-fptr-bits-ref-inline $fptr-ref-ibits-swap-unsigned-40 #t unsigned-40 #t) + (define-fptr-bits-ref-inline $fptr-ref-ubits-swap-unsigned-40 #f unsigned-40 #t) + + (define-fptr-bits-ref-inline $fptr-ref-ibits-unsigned-48 #t unsigned-48 #f) + (define-fptr-bits-ref-inline $fptr-ref-ubits-unsigned-48 #f unsigned-48 #f) + (define-fptr-bits-ref-inline $fptr-ref-ibits-swap-unsigned-48 #t unsigned-48 #t) + (define-fptr-bits-ref-inline $fptr-ref-ubits-swap-unsigned-48 #f unsigned-48 #t) + + (define-fptr-bits-ref-inline $fptr-ref-ibits-unsigned-56 #t unsigned-56 #f) + (define-fptr-bits-ref-inline $fptr-ref-ubits-unsigned-56 #f unsigned-56 #f) + (define-fptr-bits-ref-inline $fptr-ref-ibits-swap-unsigned-56 #t unsigned-56 #t) + (define-fptr-bits-ref-inline $fptr-ref-ubits-swap-unsigned-56 #f unsigned-56 #t)) + + (define-fptr-bits-ref-inline $fptr-ref-ibits-unsigned-64 #t unsigned-64 #f) + (define-fptr-bits-ref-inline $fptr-ref-ubits-unsigned-64 #f unsigned-64 #f) + (define-fptr-bits-ref-inline $fptr-ref-ibits-swap-unsigned-64 #t unsigned-64 #t) + (define-fptr-bits-ref-inline $fptr-ref-ubits-swap-unsigned-64 #f unsigned-64 #t)) + (let () + (define-syntax define-fptr-bits-set-inline + (lambda (x) + (syntax-case x () + [(_ check-64? name type swapped?) + (with-syntax ([(checks ...) #'((fixnum-constant? e-start) (fixnum-constant? e-end))]) + (with-syntax ([(checks ...) (if (datum check-64?) + #'((fx>= (constant ptr-bits) 64) checks ...) + #'(checks ...))]) + #`(define-inline 3 name + [(e-fptr e-offset e-start e-end e-val) + (and + checks ... + (let ([imm-start (constant-value e-start)] [imm-end (constant-value e-end)]) + (and (<= (type->width 'type) (constant ptr-bits)) + (and (fx>= imm-start 0) (fx> imm-end imm-start) (fx<= imm-end (constant ptr-bits))) + (fx< (fx- imm-end imm-start) (constant fixnum-bits)) + (let-values ([(e-index imm-offset) (offset-expr->index+offset e-offset)]) + (bind #t (e-index) + (bind #f (e-val) + (bind #t ([e-addr ($extract-fptr-address e-fptr)]) + (build-int-load swapped? 'type e-addr e-index imm-offset + (lambda (x) + (build-int-store swapped? 'type e-addr e-index imm-offset + (insert-bitfield #t imm-start imm-end (type->width 'type) x + e-val)))))))))))])))]))) + + (define-fptr-bits-set-inline #f $fptr-set-bits-unsigned-8! unsigned-8 #f) + + (define-fptr-bits-set-inline #f $fptr-set-bits-unsigned-16! unsigned-16 #f) + (define-fptr-bits-set-inline #f $fptr-set-bits-swap-unsigned-16! unsigned-16 #t) + + (when-known-endianness + (define-fptr-bits-set-inline #f $fptr-set-bits-unsigned-24! unsigned-24 #f) + (define-fptr-bits-set-inline #f $fptr-set-bits-swap-unsigned-24! unsigned-24 #t)) + + (define-fptr-bits-set-inline #f $fptr-set-bits-unsigned-32! unsigned-32 #f) + (define-fptr-bits-set-inline #f $fptr-set-bits-swap-unsigned-32! unsigned-32 #t) + + (when-known-endianness + (define-fptr-bits-set-inline #f $fptr-set-bits-unsigned-40! unsigned-40 #f) + (define-fptr-bits-set-inline #f $fptr-set-bits-swap-unsigned-40! unsigned-40 #t) + + (define-fptr-bits-set-inline #f $fptr-set-bits-unsigned-48! unsigned-48 #f) + (define-fptr-bits-set-inline #f $fptr-set-bits-swap-unsigned-48! unsigned-48 #t) + + (define-fptr-bits-set-inline #f $fptr-set-bits-unsigned-56! unsigned-56 #f) + (define-fptr-bits-set-inline #f $fptr-set-bits-swap-unsigned-56! unsigned-56 #t)) + + (define-fptr-bits-set-inline #t $fptr-set-bits-unsigned-64! unsigned-64 #f) + (define-fptr-bits-set-inline #t $fptr-set-bits-swap-unsigned-64! unsigned-64 #t)) + (define-inline 3 $fptr-locked-decr! + [(e-fptr e-offset) + `(seq + ,(let-values ([(e-index imm-offset) (offset-expr->index+offset e-offset)]) + (%inline locked-decr! + ,($extract-fptr-address e-fptr) + ,e-index (immediate ,imm-offset))) + (inline ,(make-info-condition-code 'eq? #f #t) ,%condition-code))]) + (define-inline 3 $fptr-locked-incr! + [(e-fptr e-offset) + `(seq + ,(let-values ([(e-index imm-offset) (offset-expr->index+offset e-offset)]) + (%inline locked-incr! + ,($extract-fptr-address e-fptr) + ,e-index (immediate ,imm-offset))) + (inline ,(make-info-condition-code 'eq? #f #t) ,%condition-code))]) + (let () + (define clear-lock + (lambda (e-fptr e-offset) + (let ([lock-type (constant-case ptr-bits [(32) 'integer-32] [(64) 'integer-64])]) + (let-values ([(e-index imm-offset) (offset-expr->index+offset e-offset)]) + `(inline ,(make-info-load lock-type #f) ,%store + ,($extract-fptr-address e-fptr) + ,e-index (immediate ,imm-offset) (immediate 0)))))) + (define-inline 3 $fptr-init-lock! + [(e-fptr e-offset) (clear-lock e-fptr e-offset)]) + (define-inline 3 $fptr-unlock! + [(e-fptr e-offset) (clear-lock e-fptr e-offset)])) + (define-inline 3 $fptr-lock! + [(e-fptr e-offset) + (let-values ([(e-index imm-offset) (offset-expr->index+offset e-offset)]) + (bind #t ([e-base ($extract-fptr-address e-fptr)]) + (%inline lock! ,e-base ,e-index (immediate ,imm-offset))))]) + (define-inline 3 $fptr-spin-lock! + [(e-fptr e-offset) + (let-values ([(e-index imm-offset) (offset-expr->index+offset e-offset)]) + (bind #t ([e-base ($extract-fptr-address e-fptr)]) + (bind #t (e-index) + (let ([L1 (make-local-label 'L1)] [L2 (make-local-label 'L2)]) + `(label ,L1 + (if ,(%inline lock! ,e-base ,e-index (immediate ,imm-offset)) + ,(%constant svoid) + (seq + (pariah) + (label ,L2 + (seq + ,(%inline pause) + (if ,(%inline eq? (mref ,e-base ,e-index ,imm-offset uptr) (immediate 0)) + (goto ,L1) + (goto ,L2)))))))))))])) + (let () + (define build-port-flags-set? + (lambda (e-p e-flags) + (%inline logtest + ,(%mref ,e-p ,(constant port-type-disp)) + ,(nanopass-case (L7 Expr) e-flags + [(quote ,d) `(immediate ,(ash d (constant port-flags-offset)))] + [else (%inline sll ,e-flags + (immediate ,(fx- (constant port-flags-offset) (constant fixnum-offset))))])))) + (define build-port-input-empty? + (lambda (e-p) + (%inline eq? + ,(%mref ,e-p ,(constant port-icount-disp)) + (immediate 0)))) + (define-inline 3 binary-port? + [(e-p) (build-port-flags-set? e-p `(quote ,(constant port-flag-binary)))]) + (define-inline 3 textual-port? + [(e-p) (build-not (build-port-flags-set? e-p `(quote ,(constant port-flag-binary))))]) + (define-inline 3 port-closed? + [(e-p) (build-port-flags-set? e-p `(quote ,(constant port-flag-closed)))]) + (define-inline 3 $port-flags-set? + [(e-p e-flags) (build-port-flags-set? e-p e-flags)]) + (define-inline 3 port-eof? + [(e-p) + (bind #t (e-p) + `(if ,(build-port-input-empty? e-p) + (if ,(build-port-flags-set? e-p `(quote ,(constant port-flag-eof))) + (immediate ,(constant strue)) + ,(build-libcall #t src sexpr unsafe-port-eof? e-p)) + (immediate ,(constant sfalse))))]) + (define-inline 2 port-eof? + [(e-p) + (let ([Llib (make-local-label 'Llib)]) + (bind #t (e-p) + `(if ,(%type-check mask-typed-object type-typed-object ,e-p) + ,(bind #t ([t0 (%mref ,e-p ,(constant typed-object-type-disp))]) + `(if ,(%type-check mask-input-port type-input-port ,t0) + (if ,(build-port-input-empty? e-p) + (if ,(%inline logtest ,t0 + (immediate ,(ash (constant port-flag-eof) (constant port-flags-offset)))) + (immediate ,(constant strue)) + (label ,Llib ,(build-libcall #t src sexpr safe-port-eof? e-p))) + (immediate ,(constant sfalse))) + (goto ,Llib))) + (goto ,Llib))))]) + (define-inline 3 port-input-empty? + [(e-p) (build-port-input-empty? e-p)]) + (define-inline 3 port-output-full? + [(e-p) + (%inline eq? + ,(%mref ,e-p ,(constant port-ocount-disp)) + (immediate 0))])) + (let () + (define build-set-port-flags! + (lambda (e-p e-flags) + (bind #t (e-p) + `(set! ,(%mref ,e-p ,(constant port-type-disp)) + ,(%inline logor + ,(%mref ,e-p ,(constant port-type-disp)) + ,(nanopass-case (L7 Expr) e-flags + [(quote ,d) `(immediate ,(ash d (constant port-flags-offset)))] + [else + (translate e-flags + (constant fixnum-offset) + (constant port-flags-offset))])))))) + (define build-reset-port-flags! + (lambda (e-p e-flags) + (bind #t (e-p) + `(set! ,(%mref ,e-p ,(constant port-type-disp)) + ,(%inline logand + ,(%mref ,e-p ,(constant port-type-disp)) + ,(nanopass-case (L7 Expr) e-flags + [(quote ,d) `(immediate ,(lognot (ash d (constant port-flags-offset))))] + [else + (%inline lognot + ,(translate e-flags + (constant fixnum-offset) + (constant port-flags-offset)))])))))) + (define-inline 3 $set-port-flags! + [(e-p e-flags) (build-set-port-flags! e-p e-flags)]) + (define-inline 3 $reset-port-flags! + [(e-p e-flags) (build-reset-port-flags! e-p e-flags)]) + (define-inline 3 mark-port-closed! + [(e-p) (build-set-port-flags! e-p `(quote ,(constant port-flag-closed)))]) + (let () + (define (go e-p e-bool flag) + (let ([e-flags `(quote ,flag)]) + (nanopass-case (L7 Expr) e-bool + [(quote ,d) + ((if d build-set-port-flags! build-reset-port-flags!) e-p e-flags)] + [else + (bind #t (e-p) + `(if ,e-bool + ,(build-set-port-flags! e-p e-flags) + ,(build-reset-port-flags! e-p e-flags)))]))) + (define-inline 3 set-port-bol! + [(e-p e-bool) (go e-p e-bool (constant port-flag-bol))]) + (define-inline 3 set-port-eof! + [(e-p e-bool) (go e-p e-bool (constant port-flag-eof))]))) + (let () + (define (build-port-input-size port-type e-p) + (bind #t (e-p) + (translate + (%inline - + ,(%inline - + ,(%mref ,e-p ,(constant port-ilast-disp)) + ,(%mref ,e-p ,(constant port-ibuffer-disp))) + (immediate + ,(if (eq? port-type 'textual) + (constant string-data-disp) + (constant bytevector-data-disp)))) + (if (eq? port-type 'textual) (constant string-char-offset) 0) + (constant fixnum-offset)))) + (define-inline 3 textual-port-input-size + [(e-p) (build-port-input-size 'textual e-p)]) + (define-inline 3 binary-port-input-size + [(e-p) (build-port-input-size 'binary e-p)])) + (let () + (define (build-port-output-size port-type e-p) + (bind #t (e-p) + (translate + (%inline - + ,(%inline - + ,(%mref ,e-p ,(constant port-olast-disp)) + ,(%mref ,e-p ,(constant port-obuffer-disp))) + (immediate + ,(if (eq? port-type 'textual) + (constant string-data-disp) + (constant bytevector-data-disp)))) + (if (eq? port-type 'textual) (constant string-char-offset) 0) + (constant fixnum-offset)))) + (define-inline 3 textual-port-output-size + [(e-p) (build-port-output-size 'textual e-p)]) + (define-inline 3 binary-port-output-size + [(e-p) (build-port-output-size 'binary e-p)])) + (let () + (define (build-port-input-index port-type e-p) + (bind #t (e-p) + (translate + ; TODO: use lea2? + (%inline + + ,(%inline - + ,(%inline - + ,(%mref ,e-p ,(constant port-ilast-disp)) + ,(%mref ,e-p ,(constant port-ibuffer-disp))) + (immediate + ,(if (eq? port-type 'textual) + (constant string-data-disp) + (constant bytevector-data-disp)))) + ,(%mref ,e-p ,(constant port-icount-disp))) + (if (eq? port-type 'textual) (constant string-char-offset) 0) + (constant fixnum-offset)))) + (define-inline 3 textual-port-input-index + [(e-p) (build-port-input-index 'textual e-p)]) + (define-inline 3 binary-port-input-index + [(e-p) (build-port-input-index 'binary e-p)])) + (let () + (define (build-port-output-index port-type e-p) + (bind #t (e-p) + (translate + (%inline + + ,(%inline - + ,(%inline - + ,(%mref ,e-p ,(constant port-olast-disp)) + ,(%mref ,e-p ,(constant port-obuffer-disp))) + (immediate + ,(if (eq? port-type 'textual) + (constant string-data-disp) + (constant bytevector-data-disp)))) + ,(%mref ,e-p ,(constant port-ocount-disp))) + (if (eq? port-type 'textual) (constant string-char-offset) 0) + (constant fixnum-offset)))) + (define-inline 3 textual-port-output-index + [(e-p) (build-port-output-index 'textual e-p)]) + (define-inline 3 binary-port-output-index + [(e-p) (build-port-output-index 'binary e-p)])) + (let () + (define (build-port-input-count port-type e-p) + (bind #t (e-p) + (translate + (%inline - + (immediate 0) + ,(%mref ,e-p ,(constant port-icount-disp))) + (if (eq? port-type 'textual) (constant string-char-offset) 0) + (constant fixnum-offset)))) + (define-inline 3 textual-port-input-count + [(e-p) (build-port-input-count 'textual e-p)]) + (define-inline 3 binary-port-input-count + [(e-p) (build-port-input-count 'binary e-p)])) + (let () + (define (build-port-output-count port-type e-p) + (bind #t (e-p) + (translate + (%inline - + (immediate 0) + ,(%mref ,e-p ,(constant port-ocount-disp))) + (if (eq? port-type 'textual) (constant string-char-offset) 0) + (constant fixnum-offset)))) + (define-inline 3 textual-port-output-count + [(e-p) (build-port-output-count 'textual e-p)]) + (define-inline 3 binary-port-output-count + [(e-p) (build-port-output-count 'binary e-p)])) + (let () + (define (build-set-port-input-size! port-type e-p e-x) + ; actually, set last to buffer[0] + size; count to size + (bind #t (e-p) + (bind #t ([e-x (translate e-x + (constant fixnum-offset) + (if (eq? port-type 'textual) (constant string-char-offset) 0))]) + `(seq + (set! ,(%mref ,e-p ,(constant port-icount-disp)) + ,(%inline - (immediate 0) ,e-x)) + (set! ,(%mref ,e-p ,(constant port-ilast-disp)) + ,(%inline + + ,(%inline + + ,(%mref ,e-p ,(constant port-ibuffer-disp)) + (immediate + ,(if (eq? port-type 'textual) + (constant string-data-disp) + (constant bytevector-data-disp)))) + ,e-x)))))) + (define-inline 3 set-textual-port-input-size! + [(e-p e-x) (build-set-port-input-size! 'textual e-p e-x)]) + (define-inline 3 set-binary-port-input-size! + [(e-p e-x) (build-set-port-input-size! 'binary e-p e-x)])) + (let () + (define (build-set-port-output-size! port-type e-p e-x) + ; actually, set last to buffer[0] + size; count to size + (bind #t (e-p) + (bind #t ([e-x (translate e-x + (constant fixnum-offset) + (if (eq? port-type 'textual) (constant string-char-offset) 0))]) + `(seq + (set! ,(%mref ,e-p ,(constant port-ocount-disp)) + ,(%inline - (immediate 0) ,e-x)) + (set! ,(%mref ,e-p ,(constant port-olast-disp)) + ,(%inline + + ,(%inline + + ,(%mref ,e-p ,(constant port-obuffer-disp)) + (immediate + ,(if (eq? port-type 'textual) + (constant string-data-disp) + (constant bytevector-data-disp)))) + ,e-x)))))) + (define-inline 3 set-textual-port-output-size! + [(e-p e-x) (build-set-port-output-size! 'textual e-p e-x)]) + (define-inline 3 set-binary-port-output-size! + [(e-p e-x) (build-set-port-output-size! 'binary e-p e-x)])) + (let () + (define (build-set-port-input-index! port-type e-p e-x) + ; actually, set count to index - size, where size = last - buffer[0] + (bind #t (e-p) + `(set! ,(%mref ,e-p ,(constant port-icount-disp)) + ,(%inline - + ,(translate e-x + (constant fixnum-offset) + (if (eq? port-type 'textual) (constant string-char-offset) 0)) + ,(%inline - + ,(%mref ,e-p ,(constant port-ilast-disp)) + ,(%inline + + ,(%mref ,e-p ,(constant port-ibuffer-disp)) + (immediate + ,(if (eq? port-type 'textual) + (constant string-data-disp) + (constant bytevector-data-disp))))))))) + (define-inline 3 set-textual-port-input-index! + [(e-p e-x) (build-set-port-input-index! 'textual e-p e-x)]) + (define-inline 3 set-binary-port-input-index! + [(e-p e-x) (build-set-port-input-index! 'binary e-p e-x)])) + (let () + (define (build-set-port-output-index! port-type e-p e-x) + ; actually, set count to index - size, where size = last - buffer[0] + (bind #t (e-p) + `(set! ,(%mref ,e-p ,(constant port-ocount-disp)) + ,(%inline - + ,(translate e-x + (constant fixnum-offset) + (if (eq? port-type 'textual) (constant string-char-offset) 0)) + ,(%inline - + ,(%mref ,e-p ,(constant port-olast-disp)) + ,(%inline + + ,(%mref ,e-p ,(constant port-obuffer-disp)) + (immediate + ,(if (eq? port-type 'textual) + (constant string-data-disp) + (constant bytevector-data-disp))))))))) + (define-inline 3 set-textual-port-output-index! + [(e-p e-x) (build-set-port-output-index! 'textual e-p e-x)]) + (define-inline 3 set-binary-port-output-index! + [(e-p e-x) (build-set-port-output-index! 'binary e-p e-x)])) + (let () + (define (make-build-set-port-buffer! port-type ibuffer-disp icount-disp ilast-disp) + (lambda (e-p e-b new?) + (bind #t (e-p e-b) + `(seq + ,(if new? + `(set! ,(%mref ,e-p ,ibuffer-disp) ,e-b) + (build-dirty-store e-p ibuffer-disp e-b)) + ,(bind #t ([e-length (if (eq? port-type 'textual) + (translate + (%inline logand + ,(%mref ,e-b ,(constant string-type-disp)) + (immediate ,(fx- (expt 2 (constant string-length-offset))))) + (constant string-length-offset) + (constant string-char-offset)) + (%inline srl + ,(%mref ,e-b ,(constant bytevector-type-disp)) + ,(%constant bytevector-length-offset)))]) + `(seq + (set! ,(%mref ,e-p ,icount-disp) + ,(%inline - (immediate 0) ,e-length)) + (set! ,(%mref ,e-p ,ilast-disp) + ,(%lea ,e-b ,e-length + (if (eq? port-type 'textual) + (constant string-data-disp) + (constant bytevector-data-disp)))))))))) + (define (make-port e-name e-handler e-ib e-ob e-info flags set-ibuf! set-obuf!) + (bind #f (e-name e-handler e-info e-ib e-ob) + (bind #t ([e-p (%constant-alloc type-typed-object (constant size-port))]) + (%seq + (set! ,(%mref ,e-p ,(constant port-type-disp)) (immediate ,flags)) + (set! ,(%mref ,e-p ,(constant port-handler-disp)) ,e-handler) + (set! ,(%mref ,e-p ,(constant port-name-disp)) ,e-name) + (set! ,(%mref ,e-p ,(constant port-info-disp)) ,e-info) + ,(set-ibuf! e-p e-ib #t) + ,(set-obuf! e-p e-ob #t) + ,e-p)))) + (define (make-build-clear-count count-disp) + (lambda (e-p e-b new?) + `(set! ,(%mref ,e-p ,count-disp) (immediate 0)))) + (let () + (define build-set-textual-port-input-buffer! + (make-build-set-port-buffer! 'textual + (constant port-ibuffer-disp) + (constant port-icount-disp) + (constant port-ilast-disp))) + (define build-set-textual-port-output-buffer! + (make-build-set-port-buffer! 'textual + (constant port-obuffer-disp) + (constant port-ocount-disp) + (constant port-olast-disp))) + (define-inline 3 set-textual-port-input-buffer! + [(e-p e-b) (build-set-textual-port-input-buffer! e-p e-b #f)]) + (define-inline 3 set-textual-port-output-buffer! + [(e-p e-b) (build-set-textual-port-output-buffer! e-p e-b #f)]) + (let () + (define (go e-name e-handler e-ib e-info) + (make-port e-name e-handler e-ib `(quote "") e-info + (fxlogor (constant type-input-port) (constant PORT-FLAG-INPUT-MODE)) + build-set-textual-port-input-buffer! + (make-build-clear-count (constant port-ocount-disp)))) + (define-inline 3 $make-textual-input-port + [(e-name e-handler e-ib) (go e-name e-handler e-ib `(quote #f))] + [(e-name e-handler e-ib e-info) (go e-name e-handler e-ib e-info)])) + (let () + (define (go e-name e-handler e-ob e-info) + (make-port e-name e-handler `(quote "") e-ob e-info + (constant type-output-port) + (make-build-clear-count (constant port-icount-disp)) + build-set-textual-port-output-buffer!)) + (define-inline 3 $make-textual-output-port + [(e-name e-handler e-ob) (go e-name e-handler e-ob `(quote #f))] + [(e-name e-handler e-ob e-info) (go e-name e-handler e-ob e-info)])) + (let () + (define (go e-name e-handler e-ib e-ob e-info) + (make-port e-name e-handler e-ib e-ob e-info + (constant type-io-port) + build-set-textual-port-input-buffer! + build-set-textual-port-output-buffer!)) + (define-inline 3 $make-textual-input/output-port + [(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-set-binary-port-input-buffer! + (make-build-set-port-buffer! 'binary + (constant port-ibuffer-disp) + (constant port-icount-disp) + (constant port-ilast-disp))) + (define build-set-binary-port-output-buffer! + (make-build-set-port-buffer! 'binary + (constant port-obuffer-disp) + (constant port-ocount-disp) + (constant port-olast-disp))) + (define-inline 3 set-binary-port-input-buffer! + [(e-p e-b) (build-set-binary-port-input-buffer! e-p e-b #f)]) + (define-inline 3 set-binary-port-output-buffer! + [(e-p e-b) (build-set-binary-port-output-buffer! e-p e-b #f)]) + (let () + (define (go e-name e-handler e-ib e-info) + (make-port e-name e-handler e-ib `(quote #vu8()) e-info + (fxlogor (constant type-input-port) (constant PORT-FLAG-INPUT-MODE) (constant PORT-FLAG-BINARY)) + build-set-binary-port-input-buffer! + (make-build-clear-count (constant port-ocount-disp)))) + (define-inline 3 $make-binary-input-port + [(e-name e-handler e-ib) (go e-name e-handler e-ib `(quote #f))] + [(e-name e-handler e-ib e-info) (go e-name e-handler e-ib e-info)])) + (let () + (define (go e-name e-handler e-ob e-info) + (make-port e-name e-handler `(quote #vu8()) e-ob e-info + (fxlogor (constant type-output-port) (constant PORT-FLAG-BINARY)) + (make-build-clear-count (constant port-icount-disp)) + build-set-binary-port-output-buffer!)) + (define-inline 3 $make-binary-output-port + [(e-name e-handler e-ob) (go e-name e-handler e-ob `(quote #f))] + [(e-name e-handler e-ob e-info) (go e-name e-handler e-ob e-info)])) + (let () + (define (go e-name e-handler e-ib e-ob e-info) + (make-port e-name e-handler e-ib e-ob e-info + (fxlogor (constant type-io-port) (constant PORT-FLAG-BINARY)) + build-set-binary-port-input-buffer! + build-set-binary-port-output-buffer!)) + (define-inline 3 $make-binary-input/output-port + [(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 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? + [(e-fv e-i) (bind #t (e-fv e-i) (build-fxvector-set!-check e-fv e-i #f))]) + (let () + (define (go e-fv e-i) + (cond + [(expr->index e-i 1 (constant maximum-fxvector-length)) => + (lambda (index) + (%mref ,e-fv + ,(+ (fix index) (constant fxvector-data-disp))))] + [else (%mref ,e-fv ,e-i ,(constant fxvector-data-disp))])) + (define-inline 3 fxvector-ref + [(e-fv e-i) (go e-fv e-i)]) + (define-inline 2 fxvector-ref + [(e-fv e-i) + (bind #t (e-fv e-i) + `(if ,(build-fxvector-ref-check e-fv e-i #f) + ,(go e-fv e-i) + ,(build-libcall #t src sexpr fxvector-ref e-fv e-i)))])) + (let () + (define (go e-fv e-i e-new) + `(set! + ,(cond + [(expr->index e-i 1 (constant maximum-fxvector-length)) => + (lambda (index) + (%mref ,e-fv + ,(+ (fix index) (constant fxvector-data-disp))))] + [else (%mref ,e-fv ,e-i ,(constant fxvector-data-disp))]) + ,e-new)) + (define-inline 3 fxvector-set! + [(e-fv e-i e-new) + (go e-fv e-i e-new)]) + (define-inline 2 fxvector-set! + [(e-fv e-i e-new) + (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)))]))) + (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) + ((build-ref-check string-type-disp maximum-string-length string-length-offset type-string mask-string string-immutable-flag) e-s e-i #f))) + (define build-string-set!-check + (lambda (e-s e-i) + ((build-ref-check string-type-disp maximum-string-length string-length-offset type-mutable-string mask-mutable-string string-immutable-flag) e-s e-i #f))) + (define-inline 2 $string-ref-check? + [(e-s e-i) (bind #t (e-s e-i) (build-string-ref-check e-s e-i))]) + (define-inline 2 $string-set!-check? + [(e-s e-i) (bind #t (e-s e-i) (build-string-set!-check e-s e-i))]) + (let () + (define (go e-s e-i) + (cond + [(expr->index e-i 1 (constant maximum-string-length)) => + (lambda (index) + `(inline ,(make-info-load (string-char-type) #f) ,%load ,e-s ,%zero + (immediate ,(+ (* (constant string-char-bytes) index) (constant string-data-disp)))))] + [else + `(inline ,(make-info-load (string-char-type) #f) ,%load ,e-s + ,(translate e-i + (constant fixnum-offset) + (constant string-char-offset)) + ,(%constant string-data-disp))])) + (define-inline 3 string-ref + [(e-s e-i) (go e-s e-i)]) + (define-inline 2 string-ref + [(e-s e-i) + (bind #t (e-s e-i) + `(if ,(build-string-ref-check e-s e-i) + ,(go e-s e-i) + ,(build-libcall #t src sexpr string-ref e-s e-i)))])) + (let () + (define (go e-s e-i e-new) + (cond + [(expr->index e-i 1 (constant maximum-string-length)) => + (lambda (index) + `(inline ,(make-info-load (string-char-type) #f) ,%store ,e-s ,%zero + (immediate ,(+ (* (constant string-char-bytes) index) (constant string-data-disp))) + ,e-new))] + [else + `(inline ,(make-info-load (string-char-type) #f) ,%store ,e-s + ,(translate e-i + (constant fixnum-offset) + (constant string-char-offset)) + ,(%constant string-data-disp) + ,e-new)])) + (define-inline 3 string-set! + [(e-s e-i e-new) (go e-s e-i e-new)]) + (define-inline 2 string-set! + [(e-s e-i e-new) + (bind #t (e-s e-i e-new) + `(if ,(let ([e-ref-check (build-string-set!-check e-s e-i)]) + (if (constant? char? e-new) + e-ref-check + (build-and e-ref-check (%type-check mask-char type-char ,e-new)))) + ,(go e-s e-i e-new) + ,(build-libcall #t src sexpr string-set! e-s e-i e-new)))]) + (define-inline 3 $string-set-immutable! + [(e-s) ((build-set-immutable! string-type-disp string-immutable-flag) e-s)]))) + (let () + (define build-vector-ref-check (build-ref-check vector-type-disp maximum-vector-length vector-length-offset type-vector mask-vector vector-immutable-flag)) + (define build-vector-set!-check (build-ref-check vector-type-disp maximum-vector-length vector-length-offset type-mutable-vector mask-mutable-vector vector-immutable-flag)) + (define-inline 2 $vector-ref-check? + [(e-v e-i) (bind #t (e-v e-i) (build-vector-ref-check e-v e-i #f))]) + (define-inline 2 $vector-set!-check? + [(e-v e-i) (bind #t (e-v e-i) (build-vector-set!-check e-v e-i #f))]) + (let () + (define (go e-v e-i) + (nanopass-case (L7 Expr) e-i + [(quote ,d) + (guard (target-fixnum? d)) + (%mref ,e-v ,(+ (fix d) (constant vector-data-disp)))] + [else (%mref ,e-v ,e-i ,(constant vector-data-disp))])) + (define-inline 3 vector-ref + [(e-v e-i) (go e-v e-i)]) + (define-inline 2 vector-ref + [(e-v e-i) + (bind #t (e-v e-i) + `(if ,(build-vector-ref-check e-v e-i #f) + ,(go e-v e-i) + ,(build-libcall #t src sexpr vector-ref e-v e-i)))])) + (let () + (define (go e-v e-i e-new) + (nanopass-case (L7 Expr) e-i + [(quote ,d) + (guard (target-fixnum? d)) + (build-dirty-store e-v (+ (fix d) (constant vector-data-disp)) e-new)] + [else (build-dirty-store e-v e-i (constant vector-data-disp) e-new)])) + (define-inline 3 vector-set! + [(e-v e-i e-new) (go e-v e-i e-new)]) + (define-inline 2 vector-set! + [(e-v e-i e-new) + (bind #t (e-v e-i) + (dirty-store-bind #t (e-new) + `(if ,(build-vector-set!-check e-v e-i #f) + ,(go e-v e-i e-new) + ,(build-libcall #t src sexpr vector-set! e-v e-i e-new))))]) + (define-inline 3 $vector-set-immutable! + [(e-fv) ((build-set-immutable! vector-type-disp vector-immutable-flag) e-fv)])) + (let () + (define (go e-v e-i e-old e-new) + (nanopass-case (L7 Expr) e-i + [(quote ,d) + (guard (target-fixnum? d)) + (build-dirty-store e-v %zero (+ (fix d) (constant vector-data-disp)) e-new (make-build-cas e-old) build-cas-seq)] + [else (build-dirty-store e-v e-i (constant vector-data-disp) e-new (make-build-cas e-old) build-cas-seq)])) + (define-inline 3 vector-cas! + [(e-v e-i e-old e-new) (go e-v e-i e-old e-new)]) + (define-inline 2 vector-cas! + [(e-v e-i e-old e-new) + (bind #t (e-v e-i e-old) + (dirty-store-bind #t (e-new) + `(if ,(build-vector-set!-check e-v e-i #f) + ,(go e-v e-i e-old e-new) + ,(build-libcall #t src sexpr vector-cas! e-v e-i e-old e-new))))])) + (let () + (define (go e-v e-i e-new) + `(set! + ,(nanopass-case (L7 Expr) e-i + [(quote ,d) + (guard (target-fixnum? d)) + (%mref ,e-v ,(+ (fix d) (constant vector-data-disp)))] + [else (%mref ,e-v ,e-i ,(constant vector-data-disp))]) + ,e-new)) + (define-inline 3 vector-set-fixnum! + [(e-v e-i e-new) (go e-v e-i e-new)]) + (define-inline 2 vector-set-fixnum! + [(e-v e-i e-new) + (bind #t (e-v e-i e-new) + `(if ,(build-vector-set!-check e-v e-i e-new) + ,(go e-v e-i e-new) + ,(build-libcall #t src sexpr vector-set-fixnum! e-v e-i e-new)))]))) + (let () + (define (go e-v e-i) + (nanopass-case (L7 Expr) e-i + [(quote ,d) + (guard (target-fixnum? d)) + (%mref ,e-v ,(+ (fix d) (constant stencil-vector-data-disp)))] + [else (%mref ,e-v ,e-i ,(constant stencil-vector-data-disp))])) + (define-inline 3 stencil-vector-ref + [(e-v e-i) (go e-v e-i)])) + (let () + (define (go e-v e-i e-new) + (nanopass-case (L7 Expr) e-i + [(quote ,d) + (guard (target-fixnum? d)) + (build-dirty-store e-v (+ (fix d) (constant stencil-vector-data-disp)) e-new)] + [else (build-dirty-store e-v e-i (constant stencil-vector-data-disp) e-new)])) + (define-inline 3 stencil-vector-set! + [(e-v e-i e-new) (go e-v e-i e-new)])) + (let () + (define (build-dirty-store-reference base index offset e) + (let ([a (if (eq? index %zero) + (%lea ,base offset) + (%lea ,base ,index offset))]) + (bind #t ([e e]) + ;; eval a second so the address is not live across any calls + (bind #t ([a a]) + `(if ,(%inline eq? ,e (immediate ,(constant sfalse))) + (set! ,(%mref ,a ,0) (immediate 0)) + ,(add-store-fence + (%seq + (set! ,(%mref ,a ,0) ,(%inline + ,e ,(%constant reference-disp))) + ,(%inline remember ,a)))))))) + (define (go e-v e-i e-new) + (nanopass-case (L7 Expr) e-i + [(quote ,d) + (guard (target-fixnum? d)) + (build-dirty-store-reference e-v %zero (+ d (constant bytevector-data-disp)) e-new)] + [else (build-dirty-store-reference e-v (build-unfix e-i) (constant bytevector-data-disp) e-new)])) + (define-inline 3 bytevector-reference-set! + [(e-v e-i e-new) (go e-v e-i e-new)]) + (define-inline 3 bytevector-reference-ref + [(bv i) (let ([t (make-tmp 't 'uptr)]) + `(let ([,t (inline ,(make-info-load ptr-type #f) ,%load + ,bv ,(build-unfix i) (immediate ,(constant bytevector-data-disp)))]) + (if ,(%inline eq? ,t (immediate 0)) + (immediate ,(constant sfalse)) + ,(%inline - ,t ,(%constant reference-disp)))))])) + (let () + (define (go e-v e-i e-new) + `(set! + ,(nanopass-case (L7 Expr) e-i + [(quote ,d) + (guard (target-fixnum? d)) + (%mref ,e-v ,(+ (fix d) (constant stencil-vector-data-disp)))] + [else (%mref ,e-v ,e-i ,(constant stencil-vector-data-disp))]) + ,e-new)) + (define-inline 3 $stencil-vector-set! + [(e-v e-i e-new) (go e-v e-i e-new)])) + (let () + (define (go e-v e-i) + (nanopass-case (L7 Expr) e-i + [(quote ,d) + (guard (target-fixnum? d)) + (%mref ,e-v ,(+ (fix d) (constant record-data-disp)))] + [else (%mref ,e-v ,e-i ,(constant record-data-disp))])) + (define-inline 3 $record-ref + [(e-v e-i) (go e-v e-i)])) + (let () + (define (go e-v e-i e-new) + (nanopass-case (L7 Expr) e-i + [(quote ,d) + (guard (target-fixnum? d)) + (build-dirty-store e-v (+ (fix d) (constant record-data-disp)) e-new)] + [else (build-dirty-store e-v e-i (constant record-data-disp) e-new)])) + (define-inline 3 $record-set! + [(e-v e-i e-new) (go e-v e-i e-new)])) + (let () + (define (go e-v e-i e-old e-new) + (nanopass-case (L7 Expr) e-i + [(quote ,d) + (guard (target-fixnum? d)) + (build-dirty-store e-v %zero (+ (fix d) (constant record-data-disp)) e-new (make-build-cas e-old) build-cas-seq)] + [else (build-dirty-store e-v e-i (constant record-data-disp) e-new (make-build-cas e-old) build-cas-seq)])) + (define-inline 3 $record-cas! + [(e-v e-i e-old e-new) (go e-v e-i e-old e-new)])) + (let () + (define build-bytevector-ref-check + (lambda (e-bits e-bv e-i check-mutable?) + (nanopass-case (L7 Expr) e-bits + [(quote ,d) + (guard (and (fixnum? d) (fx> d 0) (fx= (* (fxquotient d 8) 8) d))) + (let ([bits d] [bytes (fxquotient d 8)]) + (bind #t (e-bv e-i) + (build-and + (%type-check mask-typed-object type-typed-object ,e-bv) + (bind #t ([t (%mref ,e-bv ,(constant bytevector-type-disp))]) + (build-and + (if check-mutable? + (%type-check mask-mutable-bytevector type-mutable-bytevector ,t) + (%type-check mask-bytevector type-bytevector ,t)) + (cond + [(expr->index e-i bytes (constant maximum-bytevector-length)) => + (lambda (index) + (%inline u< + (immediate ,(logor (ash (+ index (fx- bytes 1)) (constant bytevector-length-offset)) + (constant type-bytevector) (constant bytevector-immutable-flag))) + ,t))] + [else + (build-and + ($type-check (fxlogor (fix (fx- bytes 1)) (constant mask-fixnum)) (constant type-fixnum) e-i) + (%inline u< + ; NB. add cannot overflow or change negative to positive when + ; low-order (log2 bytes) bits of fixnum value are zero, as + ; guaranteed by type-check above + ,(if (fx= bytes 1) + e-i + (%inline + ,e-i (immediate ,(fix (fx- bytes 1))))) + ,(%inline logand + ,(translate t + (constant bytevector-length-offset) + (constant fixnum-offset)) + (immediate ,(- (constant fixnum-factor))))))]))))))] + [(seq (profile ,src) ,[e]) (and e `(seq (profile ,src) ,e))] + [else #f]))) + (define-inline 2 $bytevector-ref-check? + [(e-bits e-bv e-i) (build-bytevector-ref-check e-bits e-bv e-i #f)]) + (define-inline 2 $bytevector-set!-check? + [(e-bits e-bv e-i) (build-bytevector-ref-check e-bits e-bv e-i #t)])) + (let () + (define build-bytevector-fill + (let ([filler (make-build-fill 1 (constant bytevector-data-disp))]) + (lambda (e-bv e-bytes e-fill) + (bind #t uptr ([e-fill (build-unfix e-fill)]) + (filler e-bv e-bytes e-fill))))) + (let () + (define do-make-bytevector + (lambda (e-length maybe-e-fill) + ; NB: caller must bind maybe-e-fill + (safe-assert (or (not maybe-e-fill) (no-need-to-bind? #f maybe-e-fill))) + (if (constant? (lambda (x) (and (fixnum? x) (fx<= 0 x 10000))) e-length) + (let ([n (constant-value e-length)]) + (if (fx= n 0) + `(quote ,(bytevector)) + (bind #t ([t (%constant-alloc type-typed-object + (fx+ (constant header-size-bytevector) n))]) + `(seq + (set! ,(%mref ,t ,(constant bytevector-type-disp)) + (immediate ,(fx+ (fx* n (constant bytevector-length-factor)) + (constant type-bytevector)))) + ,(if maybe-e-fill + (build-bytevector-fill t `(immediate ,n) maybe-e-fill) + t))))) + (bind #t (e-length) + (let ([t-bytes (make-tmp 'tbytes 'uptr)] [t-vec (make-tmp 'tvec)]) + `(if ,(%inline eq? ,e-length (immediate 0)) + (quote ,(bytevector)) + (let ([,t-bytes ,(build-unfix e-length)]) + (let ([,t-vec (alloc ,(make-info-alloc (constant type-typed-object) #f #f) + ,(%inline logand + ,(%inline + ,t-bytes + (immediate ,(fx+ (constant header-size-bytevector) + (fx- (constant byte-alignment) 1)))) + (immediate ,(- (constant byte-alignment)))))]) + (seq + (set! ,(%mref ,t-vec ,(constant bytevector-type-disp)) + ,(build-type/length t-bytes + (constant type-bytevector) + 0 + (constant bytevector-length-offset))) + ,(if maybe-e-fill + (build-bytevector-fill t-vec t-bytes maybe-e-fill) + t-vec)))))))))) + (let () + (define valid-length? + (lambda (e-length) + (constant? + (lambda (x) + (and (or (fixnum? x) (bignum? x)) + (<= 0 x (constant maximum-bytevector-length)))) + e-length))) + (define-inline 2 make-bytevector + [(e-length) (and (valid-length? e-length) (do-make-bytevector e-length #f))] + [(e-length e-fill) + (and (valid-length? e-length) + (constant? (lambda (x) (and (fixnum? x) (fx<= -128 x 255))) e-fill) + (do-make-bytevector e-length e-fill))])) + (define-inline 3 make-bytevector + [(e-length) (do-make-bytevector e-length #f)] + [(e-length e-fill) (bind #f (e-fill) (do-make-bytevector e-length e-fill))])) + (define-inline 3 bytevector-fill! + [(e-bv e-fill) + (bind #t (e-bv e-fill) + `(seq + ,(build-bytevector-fill e-bv + (%inline srl + ,(%mref ,e-bv ,(constant bytevector-type-disp)) + ,(%constant bytevector-length-offset)) + e-fill) + ,(%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 + (lambda (e*) + (define (find-k n) + (constant-case native-endianness + [(unknown) + (values 1 'unsigned-8)] + [else + (let loop ([bytes (constant-case ptr-bits [(32) 4] [(64) 8])] + [type* (constant-case ptr-bits + [(32) '(unsigned-32 unsigned-16 unsigned-8)] + [(64) '(unsigned-64 unsigned-32 unsigned-16 unsigned-8)])]) + (let ([bytes/2 (fxsrl bytes 1)]) + (if (fx<= n bytes/2) + (loop bytes/2 (cdr type*)) + (values bytes (car type*)))))])) + (define (build-chunk k n e*) + (define (build-shift e shift) + (if (fx= shift 0) e (%inline sll ,e (immediate ,shift)))) + (let loop ([k (constant-case native-endianness + [(little) (fxmin k n)] + [(big) k] + [(unknown) (safe-assert (= k 1)) 1])] + [e* (constant-case native-endianness + [(little) (reverse (if (fx<= n k) e* (list-head e* k)))] + [(big) e*] + [(unknown) e*])] + [constant-part 0] + [expression-part #f] + [expression-shift 0] + [mask? #f]) ; no need to mask the high-order byte + (if (fx= k 0) + (if expression-part + (let ([expression-part (build-shift expression-part expression-shift)]) + (if (= constant-part 0) + expression-part + (%inline logor ,expression-part (immediate ,constant-part)))) + `(immediate ,constant-part)) + (let ([k (fx- k 1)] + [constant-part (ash constant-part 8)] + [expression-shift (fx+ expression-shift 8)]) + (if (null? e*) + (loop k e* constant-part expression-part expression-shift #t) + (let ([e (car e*)] [e* (cdr e*)]) + (if (fixnum-constant? e) + (loop k e* (logor constant-part (logand (constant-value e) #xff)) expression-part expression-shift #t) + (loop k e* constant-part + (let* ([e (build-unfix e)] + [e (if mask? (%inline logand ,e (immediate #xff)) e)]) + (if expression-part + (%inline logor ,(build-shift expression-part expression-shift) ,e) + e)) + 0 #t)))))))) + (let ([len (length e*)]) + (if (fx= len 0) + `(quote ,(bytevector)) + (list-bind #f (e*) + (bind #t ([t (%constant-alloc type-typed-object + (fx+ (constant header-size-bytevector) len))]) + `(seq + (set! ,(%mref ,t ,(constant bytevector-type-disp)) + (immediate ,(+ (* len (constant bytevector-length-factor)) + (constant type-bytevector)))) + ; build and store k-octet (k = 4 on 32-bit machines, k = 8 on 64-bit + ; machines) chunks, taking endianness into account. for the last + ; chunk, set k = 1, 2, 4, or 8 depending on the number of octets + ; remaining, padding with zeros as necessary. + ,(let f ([e* e*] [n (length e*)] [offset (constant bytevector-data-disp)]) + (let-values ([(k type) (find-k n)]) + `(seq + (inline ,(make-info-load type #f) ,%store ,t ,%zero (immediate ,offset) + ,(build-chunk k n e*)) + ,(if (fx<= n k) + t + (f (list-tail e* k) (fx- n k) (fx+ offset k))))))))))))) + + (define-inline 2 bytevector + [e* (and (andmap + (lambda (x) + (constant? + (lambda (x) (and (fixnum? x) (fx<= -128 x 255))) + x)) + e*) + (build-bytevector e*))]) + + (define-inline 3 bytevector + [e* (build-bytevector e*)])) + + (let () + (define byte-offset + (lambda (off) + (cond + [(nanopass-case (L7 Expr) off + [(quote ,d) + (and (and (integer? d) (exact? d)) + (let ([n (+ d (constant bytevector-data-disp))]) + (and (target-fixnum? n) + `(quote ,n))))] + [else #f])] + [else (%inline + ,off + (quote ,(constant bytevector-data-disp)))]))) + + (define-inline 3 bytevector-copy! + [(bv1 off1 bv2 off2 n) + (%primcall src sexpr $byte-copy! ,bv1 ,(byte-offset off1) ,bv2 ,(byte-offset off2) ,n)])) + + (define-inline 3 bytevector-truncate! + [(bv len) + (if (fixnum-constant? len) + (let ([len (constant-value len)]) + (if (fx= len 0) + `(quote ,(bytevector)) + (bind #t (bv) + `(seq + (set! ,(%mref ,bv ,(constant bytevector-type-disp)) + (immediate ,(fx+ (fx* len (constant bytevector-length-factor)) + (constant type-bytevector)))) + ,bv)))) + (bind #t (bv len) + `(if ,(%inline eq? ,len (immediate 0)) + (quote ,(bytevector)) + (seq + (set! ,(%mref ,bv ,(constant bytevector-type-disp)) + ,(build-type/length len + (constant type-bytevector) + (constant fixnum-offset) + (constant bytevector-length-offset))) + ,bv))))]) + + (define-inline 3 $bytevector-set-immutable! + [(bv) ((build-set-immutable! bytevector-type-disp bytevector-immutable-flag) bv)]) + + (let () + (define bv-index-offset + (lambda (offset-expr) + (if (fixnum-constant? offset-expr) + (values %zero (+ (constant bytevector-data-disp) (constant-value offset-expr))) + (values (build-unfix offset-expr) (constant bytevector-data-disp))))) + + (define bv-offset-okay? + (lambda (x mask) + (constant? (lambda (x) (and (target-fixnum? x) (>= x 0) (eq? (logand x mask) 0))) x))) + + (let () + (define-syntax define-bv-8-inline + (syntax-rules () + [(_ name type) + (define-inline 2 name + [(e-bv e-offset) + (bind #t (e-bv e-offset) + `(if ,(handle-prim #f #f 3 '$bytevector-ref-check? (list `(quote 8) e-bv e-offset)) + ,(let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) + (build-object-ref #f 'type e-bv e-index imm-offset)) + ,(build-libcall #t src sexpr name e-bv e-offset)))])])) + + (define-bv-8-inline bytevector-s8-ref integer-8) + (define-bv-8-inline bytevector-u8-ref unsigned-8)) + + (let () + (define-syntax define-bv-native-ref-inline + (lambda (x) + (syntax-case x () + [(_ name type) + #'(define-inline 3 name + [(e-bv e-offset) + (let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) + (build-object-ref #f 'type e-bv e-index imm-offset))])]))) + + (define-bv-native-ref-inline bytevector-s8-ref integer-8) + (define-bv-native-ref-inline bytevector-u8-ref unsigned-8) + + (define-bv-native-ref-inline bytevector-s16-native-ref integer-16) + (define-bv-native-ref-inline bytevector-u16-native-ref unsigned-16) + + (define-bv-native-ref-inline bytevector-s32-native-ref integer-32) + (define-bv-native-ref-inline bytevector-u32-native-ref unsigned-32) + + (define-bv-native-ref-inline bytevector-s64-native-ref integer-64) + (define-bv-native-ref-inline bytevector-u64-native-ref unsigned-64) + + (define-bv-native-ref-inline bytevector-ieee-single-native-ref single-float) + (define-bv-native-ref-inline bytevector-ieee-double-native-ref double-float) + + ;; Inline to enable unboxing: + (define-inline 2 bytevector-ieee-double-native-ref + [(e-bv e-offset) + (bind #t (e-bv e-offset) + (let ([info (make-info-call #f #f #f #f #f)]) + `(if (call ,info ,#f ,(lookup-primref 3 '$bytevector-ref-check?) (quote 64) ,e-bv ,e-offset) + (call ,info ,#f ,(lookup-primref 3 'bytevector-ieee-double-native-ref) ,e-bv ,e-offset) + ,(build-libcall #t src sexpr bytevector-ieee-double-native-ref e-bv e-offset))))])) + + (let () + (define-syntax define-bv-native-int-set!-inline + (lambda (x) + (syntax-case x () + [(_ check-64? name type) + (with-syntax ([body #'(let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) + (build-object-set! 'type e-bv e-index imm-offset e-val))]) + (with-syntax ([body (if (datum check-64?) + #'(and (>= (constant ptr-bits) 64) body) + #'body)]) + #'(define-inline 3 name + [(e-bv e-offset e-val) body])))]))) + + (define-bv-native-int-set!-inline #f bytevector-s8-set! integer-8) + (define-bv-native-int-set!-inline #f bytevector-u8-set! unsigned-8) + (define-bv-native-int-set!-inline #f $bytevector-set! unsigned-8) + + (define-bv-native-int-set!-inline #f bytevector-s16-native-set! integer-16) + (define-bv-native-int-set!-inline #f bytevector-u16-native-set! unsigned-16) + + (define-bv-native-int-set!-inline #f bytevector-s32-native-set! integer-32) + (define-bv-native-int-set!-inline #f bytevector-u32-native-set! unsigned-32) + + (define-bv-native-int-set!-inline #t bytevector-s64-native-set! integer-64) + (define-bv-native-int-set!-inline #t bytevector-u64-native-set! unsigned-64)) + + (let () + (define-syntax define-bv-native-ieee-set!-inline + (lambda (x) + (syntax-case x () + [(_ name type) + #'(define-inline 3 name + [(e-bv e-offset e-val) + (let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) + (bind #f (e-bv e-index) + (build-object-set! 'type e-bv e-index imm-offset + (build-$real->flonum src sexpr e-val `(quote name)))))])]))) + + (define-bv-native-ieee-set!-inline bytevector-ieee-single-native-set! single-float) + (define-bv-native-ieee-set!-inline bytevector-ieee-double-native-set! double-float) + + ;; Inline to enable unboxing: + (define-inline 2 bytevector-ieee-double-native-set! + [(e-bv e-offset e-val) + (bind #t (e-bv e-offset) + (let ([info (make-info-call #f #f #f #f #f)]) + `(if (call ,info ,#f ,(lookup-primref 3 '$bytevector-set!-check?) (quote 64) ,e-bv ,e-offset) + ;; checks to make sure e-val produces a real number: + (call ,info ,#f ,(lookup-primref 3 'bytevector-ieee-double-native-set!) ,e-bv ,e-offset ,e-val) + ,(build-libcall #t src sexpr bytevector-ieee-double-native-set! e-bv e-offset))))])) + + (let () + (define-syntax define-bv-int-ref-inline + (lambda (x) + (define p2? + (lambda (n) + (let f ([i 1]) + (or (fx= i n) + (and (not (fx> i n)) (f (fxsll i 1))))))) + (syntax-case x () + [(_ name type mask) + #`(define-inline 3 name + [(e-bv e-offset e-eness) + (and (or (constant unaligned-integers) + (and #,(p2? (fx+ (datum mask) 1)) (bv-offset-okay? e-offset mask))) + (constant? (lambda (x) (memq x '(big little))) e-eness) + (let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) + (build-object-ref (not (eq? (constant-value e-eness) (constant native-endianness))) + 'type e-bv e-index imm-offset)))])]))) + + (define-bv-int-ref-inline bytevector-s16-ref integer-16 1) + (define-bv-int-ref-inline bytevector-u16-ref unsigned-16 1) + + (when-known-endianness + (define-bv-int-ref-inline bytevector-s24-ref integer-24 1) + (define-bv-int-ref-inline bytevector-u24-ref unsigned-24 1)) + + (define-bv-int-ref-inline bytevector-s32-ref integer-32 3) + (define-bv-int-ref-inline bytevector-u32-ref unsigned-32 3) + + (when-known-endianness + (define-bv-int-ref-inline bytevector-s40-ref integer-40 3) + (define-bv-int-ref-inline bytevector-u40-ref unsigned-40 3) + + (define-bv-int-ref-inline bytevector-s48-ref integer-48 3) + (define-bv-int-ref-inline bytevector-u48-ref unsigned-48 3) + + (define-bv-int-ref-inline bytevector-s56-ref integer-56 7) + (define-bv-int-ref-inline bytevector-u56-ref unsigned-56 7)) + + (define-bv-int-ref-inline bytevector-s64-ref integer-64 7) + (define-bv-int-ref-inline bytevector-u64-ref unsigned-64 7)) + + (let () + (define-syntax define-bv-ieee-ref-inline + (lambda (x) + (syntax-case x () + [(_ name type mask) + #'(define-inline 3 name + [(e-bv e-offset e-eness) + (and (or (constant unaligned-floats) + (bv-offset-okay? e-offset mask)) + (safe-assert (not (eq? (constant native-endianness) 'unknown))) + (constant? (lambda (x) (eq? x (constant native-endianness))) e-eness) + (let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) + (build-object-ref #f 'type e-bv e-index imm-offset)))])]))) + + (define-bv-ieee-ref-inline bytevector-ieee-single-ref single-float 3) + (define-bv-ieee-ref-inline bytevector-ieee-double-ref double-float 7)) + + (let () + (define-syntax define-bv-int-set!-inline + (lambda (x) + (syntax-case x () + [(_ check-64? name type mask) + (with-syntax ([body #'(and (or (constant unaligned-integers) + (and mask (bv-offset-okay? e-offset mask))) + (safe-assert (not (eq? (constant native-endianness) 'unknown))) + (constant? (lambda (x) (memq x '(big little))) e-eness) + (let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) + (if (eq? (constant-value e-eness) (constant native-endianness)) + (build-object-set! 'type e-bv e-index imm-offset e-value) + (build-swap-object-set! 'type e-bv e-index imm-offset e-value))))]) + (with-syntax ([body (if (datum check-64?) + #'(and (>= (constant ptr-bits) 64) body) + #'body)]) + #'(define-inline 3 name + [(e-bv e-offset e-value e-eness) body])))]))) + + (define-bv-int-set!-inline #f bytevector-s16-set! integer-16 1) + (define-bv-int-set!-inline #f bytevector-u16-set! unsigned-16 1) + + (define-bv-int-set!-inline #f bytevector-s24-set! integer-24 #f) + (define-bv-int-set!-inline #f bytevector-u24-set! unsigned-24 #f) + + (define-bv-int-set!-inline #f bytevector-s32-set! integer-32 3) + (define-bv-int-set!-inline #f bytevector-u32-set! unsigned-32 3) + + (define-bv-int-set!-inline #t bytevector-s40-set! integer-40 #f) + (define-bv-int-set!-inline #t bytevector-u40-set! unsigned-40 #f) + + (define-bv-int-set!-inline #t bytevector-s48-set! integer-48 #f) + (define-bv-int-set!-inline #t bytevector-u48-set! unsigned-48 #f) + + (define-bv-int-set!-inline #t bytevector-s56-set! integer-56 #f) + (define-bv-int-set!-inline #t bytevector-u56-set! unsigned-56 #f) + + (define-bv-int-set!-inline #t bytevector-s64-set! integer-64 7) + (define-bv-int-set!-inline #t bytevector-u64-set! unsigned-64 7)) + + (let () + (define-syntax define-bv-ieee-set!-inline + (lambda (x) + (syntax-case x () + [(_ name type mask) + #'(define-inline 3 name + [(e-bv e-offset e-value e-eness) + (and (or (constant unaligned-floats) (bv-offset-okay? e-offset mask)) + (safe-assert (not (eq? (constant native-endianness) 'unknown))) + (constant? (lambda (x) (eq? x (constant native-endianness))) e-eness) + (let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) + (bind #f (e-bv e-index) + (build-object-set! 'type e-bv e-index imm-offset + (build-$real->flonum src sexpr e-value + `(quote name))))))])]))) + + (define-bv-ieee-set!-inline bytevector-ieee-single-set! single-float 3) + (define-bv-ieee-set!-inline bytevector-ieee-double-set! double-float 7)) + + (let () + (define anyint-ref-helper + (lambda (type mask e-bv e-offset e-eness) + (and (or (constant unaligned-integers) (bv-offset-okay? e-offset mask)) + (constant? (lambda (x) (memq x '(big little))) e-eness) + (safe-assert (not (eq? (constant native-endianness) 'unknown))) + (let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) + (build-object-ref (not (eq? (constant-value e-eness) (constant native-endianness))) + type e-bv e-index imm-offset))))) + (define-syntax define-bv-anyint-ref-inline + (syntax-rules () + [(_ name type8 type16 type32 type64) + (define-inline 3 name + [(e-bv e-offset e-eness e-size) + (and (fixnum-constant? e-size) + (case (constant-value e-size) + [(1) (let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) + `(seq + ,e-eness + ,(build-object-ref #f 'type8 e-bv e-index imm-offset)))] + [(2) (anyint-ref-helper 'type16 #b1 e-bv e-offset e-eness)] + [(4) (anyint-ref-helper 'type32 #b11 e-bv e-offset e-eness)] + [(8) (anyint-ref-helper 'type64 #b111 e-bv e-offset e-eness)] + [else #f]))])])) + + (define-bv-anyint-ref-inline bytevector-sint-ref + integer-8 integer-16 integer-32 integer-64) + (define-bv-anyint-ref-inline bytevector-uint-ref + unsigned-8 unsigned-16 unsigned-32 unsigned-64)) + + (let () + (define anyint-set!-helper + (lambda (type mask e-bv e-offset e-value e-eness) + (and (or (constant unaligned-integers) (bv-offset-okay? e-offset mask)) + (safe-assert (not (eq? (constant native-endianness) 'unknown))) + (constant? (lambda (x) (memq x '(big little))) e-eness) + (let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) + (if (eq? (constant-value e-eness) (constant native-endianness)) + (build-object-set! type e-bv e-index imm-offset e-value) + (build-swap-object-set! type e-bv e-index imm-offset e-value)))))) + (define-syntax define-bv-anyint-set!-inline + (syntax-rules () + [(_ name type8 type16 type32 type64) + (define-inline 3 name + [(e-bv e-offset e-value e-eness e-size) + (and (fixnum-constant? e-size) + (case (constant-value e-size) + [(1) (let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) + `(seq + ,e-eness + ,(build-object-set! 'type8 e-bv e-index imm-offset e-value)))] + [(2) (anyint-set!-helper 'type16 1 e-bv e-offset e-value e-eness)] + [(4) (anyint-set!-helper 'type32 3 e-bv e-offset e-value e-eness)] + [(8) (and (>= (constant ptr-bits) 64) + (anyint-set!-helper 'type64 7 e-bv e-offset e-value e-eness))] + [else #f]))])])) + + (define-bv-anyint-set!-inline bytevector-sint-set! + integer-8 integer-16 integer-32 integer-64) + (define-bv-anyint-set!-inline bytevector-uint-set! + unsigned-8 unsigned-16 unsigned-32 unsigned-64))) + + (let () + (define (byte-count e-n) + (or (nanopass-case (L7 Expr) e-n + [(quote ,d) + (and (and (integer? d) (exact? d)) + (let ([n (* d (constant string-char-bytes))]) + (and (target-fixnum? n) + `(immediate ,(fix n)))))] + [else #f]) + (%inline sll ,e-n ,(%constant string-char-offset)))) + (define byte-offset + (lambda (e-off) + (or (nanopass-case (L7 Expr) e-off + [(quote ,d) + (and (and (integer? d) (exact? d)) + (let ([n (+ (* d (constant string-char-bytes)) + (constant string-data-disp))]) + (and (target-fixnum? n) + `(immediate ,(fix n)))))] + [else #f]) + (%inline + + ,(%inline sll ,e-off ,(%constant string-char-offset)) + (immediate ,(fix (constant string-data-disp))))))) + (define-inline 3 string-copy! + [(e-bv1 e-off1 e-bv2 e-off2 e-n) + (%primcall src sexpr $byte-copy! ,e-bv1 ,(byte-offset e-off1) ,e-bv2 ,(byte-offset e-off2) ,(byte-count e-n))])) + + (define-inline 3 string-truncate! + [(e-str e-len) + (if (fixnum-constant? e-len) + (let ([len (constant-value e-len)]) + (if (fx= len 0) + `(quote ,(string)) + (bind #t (e-str) + `(seq + (set! ,(%mref ,e-str ,(constant string-type-disp)) + (immediate ,(fx+ (fx* len (constant string-length-factor)) + (constant type-string)))) + ,e-str)))) + (bind #t (e-str e-len) + `(if ,(%inline eq? ,e-len (immediate 0)) + (quote ,(string)) + (seq + (set! ,(%mref ,e-str ,(constant string-type-disp)) + ,(build-type/length e-len + (constant type-string) + (constant fixnum-offset) + (constant string-length-offset))) + ,e-str))))]) + + (let () + (define build-string-fill + (make-build-fill (constant string-char-bytes) (constant string-data-disp))) + (let () + (define do-make-string + (lambda (e-length e-fill) + ; NB: caller must bind e-fill + (safe-assert (no-need-to-bind? #f e-fill)) + (if (constant? (lambda (x) (and (fixnum? x) (fx<= 0 x 10000))) e-length) + (let ([n (constant-value e-length)]) + (if (fx= n 0) + `(quote ,(string)) + (let ([bytes (fx* n (constant string-char-bytes))]) + (bind #t ([t (%constant-alloc type-typed-object + (fx+ (constant header-size-string) bytes))]) + `(seq + (set! ,(%mref ,t ,(constant string-type-disp)) + (immediate ,(fx+ (fx* n (constant string-length-factor)) + (constant type-string)))) + ,(build-string-fill t `(immediate ,bytes) e-fill)))))) + (bind #t (e-length) + (let ([t-bytes (make-tmp 'tsize 'uptr)] [t-str (make-tmp 'tstr)]) + `(if ,(%inline eq? ,e-length (immediate 0)) + (quote ,(string)) + (let ([,t-bytes ,(translate e-length + (constant fixnum-offset) + (constant string-char-offset))]) + (let ([,t-str (alloc ,(make-info-alloc (constant type-typed-object) #f #f) + ,(%inline logand + ,(%inline + ,t-bytes + (immediate ,(fx+ (constant header-size-string) + (fx- (constant byte-alignment) 1)))) + (immediate ,(- (constant byte-alignment)))))]) + (seq + (set! ,(%mref ,t-str ,(constant string-type-disp)) + ,(build-type/length t-bytes + (constant type-string) + (constant string-char-offset) + (constant string-length-offset))) + ,(build-string-fill t-str t-bytes e-fill)))))))))) + (define default-fill `(immediate ,(ptr->imm #\nul))) + (define-inline 3 make-string + [(e-length) (do-make-string e-length default-fill)] + [(e-length e-fill) (bind #t (e-fill) (do-make-string e-length e-fill))]) + (let () + (define (valid-length? e-length) + (constant? + (lambda (x) + (and (or (fixnum? x) (bignum? x)) + (<= 0 x (constant maximum-string-length)))) + e-length)) + (define-inline 2 make-string + [(e-length) + (and (valid-length? e-length) + (do-make-string e-length default-fill))] + [(e-length e-fill) + (and (valid-length? e-length) + (constant? char? e-fill) + (do-make-string e-length e-fill))]))) + (define-inline 3 string-fill! + [(e-str e-fill) + `(seq + ,(bind #t (e-str e-fill) + (build-string-fill e-str + (translate + (%inline logxor + ,(%mref ,e-str ,(constant string-type-disp)) + ,(%constant type-string)) + (constant string-length-offset) + (constant string-char-offset)) + e-fill)) + ,(%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 + (make-build-fill (constant ptr-bytes) (constant fxvector-data-disp))) + (meta-assert (= (constant log2-ptr-bytes) (constant fixnum-offset))) + (let () + (define do-make-fxvector + (lambda (e-length e-fill) + ; NB: caller must bind e-fill + (safe-assert (no-need-to-bind? #f e-fill)) + (if (constant? (lambda (x) (and (fixnum? x) (fx<= 0 x 10000))) e-length) + (let ([n (constant-value e-length)]) + (if (fx= n 0) + `(quote ,(fxvector)) + (let ([bytes (fx* n (constant ptr-bytes))]) + (bind #t ([t (%constant-alloc type-typed-object + (fx+ (constant header-size-fxvector) bytes))]) + `(seq + (set! ,(%mref ,t ,(constant fxvector-type-disp)) + (immediate ,(fx+ (fx* n (constant fxvector-length-factor)) + (constant type-fxvector)))) + ,(build-fxvector-fill t `(immediate ,bytes) e-fill)))))) + (bind #t (e-length) ; fixnum length doubles as byte count + (let ([t-fxv (make-tmp 'tfxv)]) + `(if ,(%inline eq? ,e-length (immediate 0)) + (quote ,(fxvector)) + (let ([,t-fxv (alloc ,(make-info-alloc (constant type-typed-object) #f #f) + ,(%inline logand + ,(%inline + ,e-length + (immediate ,(fx+ (constant header-size-fxvector) + (fx- (constant byte-alignment) 1)))) + (immediate ,(- (constant byte-alignment)))))]) + (seq + (set! ,(%mref ,t-fxv ,(constant fxvector-type-disp)) + ,(build-type/length e-length + (constant type-fxvector) + (constant fixnum-offset) + (constant fxvector-length-offset))) + ,(build-fxvector-fill t-fxv e-length e-fill))))))))) + (define default-fill `(immediate ,(fix 0))) + (define-inline 3 make-fxvector + [(e-length) (do-make-fxvector e-length default-fill)] + [(e-length e-fill) (bind #t (e-fill) (do-make-fxvector e-length e-fill))]) + (let () + (define (valid-length? e-length) + (constant? + (lambda (x) + (and (or (fixnum? x) (bignum? x)) + (<= 0 x (constant maximum-fxvector-length)))) + e-length)) + (define-inline 2 make-fxvector + [(e-length) + (and (valid-length? e-length) + (do-make-fxvector e-length default-fill))] + [(e-length e-fill) + (and (valid-length? e-length) + (constant? fixnum? e-fill) + (do-make-fxvector e-length e-fill))]))) + (define-inline 3 fxvector-fill! + [(e-fxv e-fill) + `(seq + ,(bind #t (e-fxv e-fill) + (build-fxvector-fill e-fxv + (translate + (%inline logxor + ,(%mref ,e-fxv ,(constant fxvector-type-disp)) + ,(%constant type-fxvector)) + (constant fxvector-length-offset) + (constant fixnum-offset)) + e-fill)) + ,(%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))) + (let () + (define do-make-vector + (lambda (e-length e-fill) + ; NB: caller must bind e-fill + (safe-assert (no-need-to-bind? #f e-fill)) + (if (constant? (lambda (x) (and (fixnum? x) (fx<= 0 x 10000))) e-length) + (let ([n (constant-value e-length)]) + (if (fx= n 0) + `(quote ,(vector)) + (let ([bytes (fx* n (constant ptr-bytes))]) + (bind #t ([t (%constant-alloc type-typed-object + (fx+ (constant header-size-vector) bytes))]) + `(seq + (set! ,(%mref ,t ,(constant vector-type-disp)) + (immediate ,(+ (fx* n (constant vector-length-factor)) + (constant type-vector)))) + ,(build-vector-fill t `(immediate ,bytes) e-fill)))))) + (bind #t (e-length) ; fixnum length doubles as byte count + (let ([t-vec (make-tmp 'tvec)]) + `(if ,(%inline eq? ,e-length (immediate 0)) + (quote ,(vector)) + (let ([,t-vec (alloc ,(make-info-alloc (constant type-typed-object) #f #f) + ,(%inline logand + ,(%inline + ,e-length + (immediate ,(fx+ (constant header-size-vector) + (fx- (constant byte-alignment) 1)))) + (immediate ,(- (constant byte-alignment)))))]) + (seq + (set! ,(%mref ,t-vec ,(constant vector-type-disp)) + ,(build-type/length e-length + (constant type-vector) + (constant fixnum-offset) + (constant vector-length-offset))) + ,(build-vector-fill t-vec e-length e-fill))))))))) + (define default-fill `(immediate ,(fix 0))) + (define-inline 3 make-vector + [(e-length) (do-make-vector e-length default-fill)] + [(e-length e-fill) (bind #t (e-fill) (do-make-vector e-length e-fill))]) + (let () + (define (valid-length? e-length) + (constant? + (lambda (x) (and (target-fixnum? x) (>= x 0))) + e-length)) + (define-inline 2 make-vector + [(e-length) + (and (valid-length? e-length) + (do-make-vector e-length default-fill))] + [(e-length e-fill) + (and (valid-length? e-length) + (constant? fixnum? 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))) + (let () + (define build-stencil-vector-type + (lambda (e-mask) ; e-mask is used only once + (%inline logor + (immediate ,(constant type-stencil-vector)) + ,(%inline sll ,e-mask (immediate ,(fx- (constant stencil-vector-mask-offset) + (constant fixnum-offset))))))) + (define do-stencil-vector + (lambda (e-mask e-val*) + (list-bind #f (e-val*) + (bind #f (e-mask) + (let ([t-vec (make-tmp 'tvec)]) + `(let ([,t-vec ,(%constant-alloc type-typed-object + (fx+ (constant header-size-stencil-vector) + (fx* (length e-val*) (constant ptr-bytes))))]) + ,(let loop ([e-val* e-val*] [i 0]) + (if (null? e-val*) + `(seq + (set! ,(%mref ,t-vec ,(constant stencil-vector-type-disp)) + ,(build-stencil-vector-type e-mask)) + ,t-vec) + `(seq + (set! ,(%mref ,t-vec ,(fx+ i (constant stencil-vector-data-disp))) ,(car e-val*)) + ,(loop (cdr e-val*) (fx+ i (constant ptr-bytes)))))))))))) + (define do-make-stencil-vector + (lambda (e-length e-mask) + (bind #t (e-length) + (bind #f (e-mask) + (let ([t-vec (make-tmp 'tvec)]) + `(let ([,t-vec (alloc ,(make-info-alloc (constant type-typed-object) #f #f) + ,(%inline logand + ,(%inline + ,e-length + (immediate ,(fx+ (constant header-size-stencil-vector) + (fx- (constant byte-alignment) 1)))) + (immediate ,(- (constant byte-alignment)))))]) + ,(%seq + (set! ,(%mref ,t-vec ,(constant stencil-vector-type-disp)) + ,(build-stencil-vector-type e-mask)) + ;; Content not filled! This function is meant to be called by + ;; `$stencil-vector-update`, which has GC disabled between + ;; allocation and filling in the data + ,t-vec))))))) + (define-inline 3 stencil-vector + [(e-mask . e-val*) + (do-stencil-vector e-mask e-val*)]) + (define-inline 2 $make-stencil-vector + [(e-length e-mask) (do-make-stencil-vector e-length e-mask)]) + (define-inline 3 $make-stencil-vector + [(e-length e-mask) (do-make-stencil-vector e-length e-mask)]) + (define-inline 3 stencil-vector-update + [(e-vec e-sub-mask e-add-mask . e-val*) + `(call ,(make-info-call src sexpr #f #f #f) #f + ,(lookup-primref 3 '$stencil-vector-update) + ,e-vec ,e-sub-mask ,e-add-mask ,e-val* ...)]) + (define-inline 3 stencil-vector-truncate! + [(e-vec e-mask) + (bind #f (e-vec e-mask) + `(seq + (set! ,(%mref ,e-vec ,(constant stencil-vector-type-disp)) + ,(build-stencil-vector-type e-mask)) + ,(%constant svoid)))]))) + (let () + (meta-assert (= (constant log2-ptr-bytes) (constant fixnum-offset))) + (define-inline 3 $make-eqhash-vector + [(e-length) + (let ([t-vec (make-tmp 'tvec)] + [t-idx (make-assigned-tmp 't-idx)] + [Ltop (make-local-label 'Ltop)]) + `(let ([,t-idx ,e-length]) + (if ,(%inline eq? ,t-idx (immediate 0)) + (quote ,(vector)) + (let ([,t-vec (alloc ,(make-info-alloc (constant type-typed-object) #f #f) + ,(%inline logand + ,(%inline + ,t-idx + (immediate ,(fx+ (constant header-size-vector) + (fx- (constant byte-alignment) 1)))) + (immediate ,(- (constant byte-alignment)))))]) + (seq + (set! ,(%mref ,t-vec ,(constant vector-type-disp)) + ,(build-type/length t-idx + (constant type-vector) + (constant fixnum-offset) + (constant vector-length-offset))) + (label ,Ltop + ,(%seq + (set! ,t-idx ,(%inline - ,t-idx (immediate ,(fix 1)))) + (set! ,(%mref ,t-vec ,t-idx ,(constant vector-data-disp)) ,t-idx) + (if ,(%inline eq? ,t-idx (immediate 0)) + ,t-vec + (goto ,Ltop)))))))))])) + + (let () + (define build-continuation?-test + (lambda (e) ; e must be bound + (build-and + (%type-check mask-closure type-closure ,e) + (%type-check mask-continuation-code type-continuation-code + ,(%mref + ,(%inline - + ,(%mref ,e ,(constant closure-code-disp)) + ,(%constant code-data-disp)) + ,(constant code-type-disp)))))) + (define-inline 2 $continuation? + [(e) (bind #t (e) + (build-continuation?-test e))]) + (define-inline 2 $assert-continuation + [(e) (bind #t (e) + `(if ,(build-and + (build-continuation?-test e) + (%inline eq? ,(%mref ,e ,(constant continuation-winders-disp)) ,(%tc-ref winders))) + ,(%constant svoid) + ,(build-libcall #t src sexpr $check-continuation e (%constant sfalse) (%constant sfalse))))] + [(e1 e2) (bind #t (e1 e2) + `(if ,(build-and + (build-continuation?-test e1) + (build-and + (%inline eq? ,(%mref ,e1 ,(constant continuation-winders-disp)) ,(%tc-ref winders)) + (build-simple-or + (%inline eq? ,e2 ,(%mref ,e1 ,(constant continuation-attachments-disp))) + (build-and + (%type-check mask-pair type-pair ,e2) + (%inline eq? ,(%mref ,e2 ,(constant pair-cdr-disp)) ,(%mref ,e1 ,(constant continuation-attachments-disp))))))) + ,(%constant svoid) + ,(build-libcall #t src sexpr $check-continuation e1 (%constant strue) e2)))]) + (define-inline 3 $assert-continuation + [(e) (bind #t (e) + `(if ,(%inline eq? ,(%mref ,e ,(constant continuation-winders-disp)) ,(%tc-ref winders)) + ,(%constant svoid) + ,(build-libcall #t src sexpr $check-continuation e (%constant sfalse) (%constant sfalse))))] + [(e1 e2) #f])) + + (define-inline 3 $continuation-stack-length + [(e) + (translate (%mref ,e ,(constant continuation-stack-length-disp)) + (constant fixnum-offset) + (constant log2-ptr-bytes))]) + (define-inline 3 $continuation-stack-clength + [(e) + (translate (%mref ,e ,(constant continuation-stack-clength-disp)) + (constant fixnum-offset) + (constant log2-ptr-bytes))]) + (let () + (define (build-ra e) + (%mref ,e ,(constant continuation-return-address-disp))) + (define (build-stack-ra e-k e-i) + (%mref ,(%mref ,e-k ,(constant continuation-stack-disp)) + ,(translate e-i (constant fixnum-offset) (constant log2-ptr-bytes)) + 0)) + + (define build-return-code + (lambda (e-ra) + (bind #t ([ra e-ra]) + (bind #t ([t `(if ,(%inline logtest ,(%mref ,ra ,(constant compact-return-address-mask+size+mode-disp)) + ,(%constant compact-header-mask)) + ,(%inline + ,ra ,(%constant compact-return-address-toplink-disp)) + ,(%inline + ,ra ,(%constant return-address-toplink-disp)))]) + (%inline - ,t ,(%mref ,t 0)))))) + (define build-return-offset + (lambda (e-ra) + (bind #t ([ra e-ra]) + (build-fix + `(if ,(%inline logtest ,(%mref ,ra ,(constant compact-return-address-mask+size+mode-disp)) + ,(%constant compact-header-mask)) + ,(%inline - ,(%mref ,ra ,(constant compact-return-address-toplink-disp)) + ,(%constant compact-return-address-toplink-disp)) + ,(%inline - ,(%mref ,ra ,(constant return-address-toplink-disp)) + ,(%constant return-address-toplink-disp))))))) + (define build-return-livemask + (lambda (e-ra) + (bind #t ([ra e-ra]) + (bind #t ([mask+size+mode (%mref ,ra ,(constant compact-return-address-mask+size+mode-disp))]) + `(if ,(%inline logtest ,mask+size+mode ,(%constant compact-header-mask)) + ,(%inline sll ,(%inline srl ,mask+size+mode ,(%constant compact-frame-mask-offset)) + ,(%constant fixnum-offset)) + ,(%mref ,ra ,(constant return-address-livemask-disp))))))) + (define build-return-frame-words + (lambda (e-ra) + (bind #t ([ra e-ra]) + (bind #t ([mask+size+mode (%mref ,ra ,(constant compact-return-address-mask+size+mode-disp))]) + `(if ,(%inline logtest ,mask+size+mode ,(%constant compact-header-mask)) + ,(%inline sll ,(%inline logand ,(%inline srl ,mask+size+mode ,(%constant compact-frame-words-offset)) + ,(%constant compact-frame-words-mask)) + ,(%constant fixnum-offset)) + ,(%mref ,ra ,(constant return-address-frame-size-disp))))))) + + (define-inline 3 $continuation-return-code + [(e) (build-return-code (build-ra e))]) + (define-inline 3 $continuation-return-offset + [(e) (build-return-offset (build-ra e))]) + (define-inline 3 $continuation-return-livemask + [(e) (build-return-livemask (build-ra e))]) + (define-inline 3 $continuation-return-frame-words + [(e) (build-return-frame-words (build-ra e))]) + (define-inline 3 $continuation-stack-ref + [(e-k e-i) + (%mref + ,(%mref ,e-k ,(constant continuation-stack-disp)) + ,(translate e-i (constant fixnum-offset) (constant log2-ptr-bytes)) + 0)]) + (define-inline 3 $continuation-stack-return-code + [(e-k e-i) (build-return-code (build-stack-ra e-k e-i))]) + (define-inline 3 $continuation-stack-return-offset + [(e-k e-i) (build-return-offset (build-stack-ra e-k e-i))]) + (define-inline 3 $continuation-stack-return-frame-words + [(e-k e-i) (build-return-frame-words (build-stack-ra e-k e-i))])) + + (define-inline 2 $foreign-char? + [(e) + (bind #t (e) + (build-and + (%type-check mask-char type-char ,e) + (%inline < ,e (immediate ,(ptr->imm (integer->char #x100))))))]) + (define-inline 2 $foreign-wchar? + [(e) + (constant-case wchar-bits + [(16) + (bind #t (e) + (build-and + (%type-check mask-char type-char ,e) + (%inline < ,e (immediate ,(ptr->imm (integer->char #x10000))))))] + [(32) (%type-check mask-char type-char ,e)])]) + (define-inline 2 $integer-8? + [(e) + (unless (fx>= (constant fixnum-bits) 8) ($oops '$integer-8? "unexpected fixnum-bits")) + (bind #t (e) + (build-and + (%type-check mask-fixnum type-fixnum ,e) + (%inline u< + ,(%inline + ,e (immediate ,(fix #x80))) + (immediate ,(fix #x180)))))]) + (define-inline 2 $integer-16? + [(e) + (unless (fx>= (constant fixnum-bits) 16) ($oops '$integer-16? "unexpected fixnum-bits")) + (bind #t (e) + (build-and + (%type-check mask-fixnum type-fixnum ,e) + (%inline u< + ,(%inline + ,e (immediate ,(fix #x8000))) + (immediate ,(fix #x18000)))))]) + (define-inline 2 $integer-24? + [(e) + (unless (fx>= (constant fixnum-bits) 24) ($oops '$integer-24? "unexpected fixnum-bits")) + (bind #t (e) + (build-and + (%type-check mask-fixnum type-fixnum ,e) + (%inline u< + ,(%inline + ,e (immediate ,(fix #x800000))) + (immediate ,(fix #x1800000)))))]) + (define-inline 2 $integer-32? + [(e) + (bind #t (e) + (if (fx>= (constant fixnum-bits) 32) + (build-and + (%type-check mask-fixnum type-fixnum ,e) + (%inline u< + ,(%inline + ,e (immediate ,(fix #x80000000))) + (immediate ,(fix #x180000000)))) + (build-simple-or + (%type-check mask-fixnum type-fixnum ,e) + (build-and + (%type-check mask-typed-object type-typed-object ,e) + (bind #t ([t (%mref ,e ,(constant bignum-type-disp))]) + `(if ,(%type-check mask-signed-bignum type-positive-bignum ,t) + ,(build-libcall #f #f sexpr <= e `(quote #xffffffff)) + ,(build-and + (%type-check mask-signed-bignum type-negative-bignum ,t) + (build-libcall #f #f sexpr >= e `(quote #x-80000000)))))))))]) + (define-inline 2 $integer-40? + [(e) + (bind #t (e) + (if (fx>= (constant fixnum-bits) 32) + (build-and + (%type-check mask-fixnum type-fixnum ,e) + (%inline u< + ,(%inline + ,e (immediate ,(fix #x8000000000))) + (immediate ,(fix #x18000000000)))) + (build-simple-or + (%type-check mask-fixnum type-fixnum ,e) + (build-and + (%type-check mask-typed-object type-typed-object ,e) + (bind #t ([t (%mref ,e ,(constant bignum-type-disp))]) + `(if ,(%type-check mask-signed-bignum type-positive-bignum ,t) + ,(build-libcall #f #f sexpr <= e `(quote #xffffffffff)) + ,(build-and + (%type-check mask-signed-bignum type-negative-bignum ,t) + (build-libcall #f #f sexpr >= e `(quote #x-8000000000)))))))))]) + (define-inline 2 $integer-48? + [(e) + (bind #t (e) + (if (fx>= (constant fixnum-bits) 32) + (build-and + (%type-check mask-fixnum type-fixnum ,e) + (%inline u< + ,(%inline + ,e (immediate ,(fix #x800000000000))) + (immediate ,(fix #x1800000000000)))) + (build-simple-or + (%type-check mask-fixnum type-fixnum ,e) + (build-and + (%type-check mask-typed-object type-typed-object ,e) + (bind #t ([t (%mref ,e ,(constant bignum-type-disp))]) + `(if ,(%type-check mask-signed-bignum type-positive-bignum ,t) + ,(build-libcall #f #f sexpr <= e `(quote #xffffffffffff)) + ,(build-and + (%type-check mask-signed-bignum type-negative-bignum ,t) + (build-libcall #f #f sexpr >= e `(quote #x-800000000000)))))))))]) + (define-inline 2 $integer-56? + [(e) + (bind #t (e) + (if (fx>= (constant fixnum-bits) 32) + (build-and + (%type-check mask-fixnum type-fixnum ,e) + (%inline u< + ,(%inline + ,e (immediate ,(fix #x80000000000000))) + (immediate ,(fix #x180000000000000)))) + (build-simple-or + (%type-check mask-fixnum type-fixnum ,e) + (build-and + (%type-check mask-typed-object type-typed-object ,e) + (bind #t ([t (%mref ,e ,(constant bignum-type-disp))]) + `(if ,(%type-check mask-signed-bignum type-positive-bignum ,t) + ,(build-libcall #f #f sexpr <= e `(quote #xffffffffffffff)) + ,(build-and + (%type-check mask-signed-bignum type-negative-bignum ,t) + (build-libcall #f #f sexpr >= e `(quote #x-80000000000000)))))))))]) + (define-inline 2 $integer-64? + [(e) + (when (fx>= (constant fixnum-bits) 64) ($oops '$integer-64? "unexpected fixnum-bits")) + (bind #t (e) + (build-simple-or + (%type-check mask-fixnum type-fixnum ,e) + (build-and + (%type-check mask-typed-object type-typed-object ,e) + (bind #t ([t (%mref ,e ,(constant bignum-type-disp))]) + `(if ,(%type-check mask-signed-bignum type-positive-bignum ,t) + ,(build-libcall #f #f sexpr <= e `(quote #xffffffffffffffff)) + ,(build-and + (%type-check mask-signed-bignum type-negative-bignum ,t) + (build-libcall #f #f sexpr >= e `(quote #x-8000000000000000))))))))]) + (define-inline 3 char->integer + ; assumes types are set up so that fixnum tag will be right after the shift + [(e-char) (build-char->integer e-char)]) + (define-inline 2 char->integer + ; assumes types are set up so that fixnum tag will be right after the shift + [(e-char) + (bind #t (e-char) + `(if ,(%type-check mask-char type-char ,e-char) + ,(%inline srl ,e-char + (immediate ,(fx- (constant char-data-offset) (constant fixnum-offset)))) + ,(build-libcall #t src sexpr char->integer e-char)))]) + (define-inline 3 char- + ; assumes fixnum is zero + [(e1 e2) + (%inline srl + ,(%inline - ,e1 ,e2) + (immediate ,(fx- (constant char-data-offset) (constant fixnum-offset))))]) + (define-inline 3 integer->char + [(e-int) (build-integer->char e-int)]) + (define-inline 3 boolean=? + [(e1 e2) (%inline eq? ,e1 ,e2)] + [(e1 e2 . e*) (reduce-equality src sexpr moi e1 e2 e*)]) + (define-inline 3 symbol=? + [(e1 e2) (%inline eq? ,e1 ,e2)] + [(e1 e2 . e*) (reduce-equality src sexpr moi e1 e2 e*)]) + (let () + (define (go e flag) + (%inline logtest + ,(%mref ,e ,(constant record-type-flags-disp)) + (immediate ,(fix flag)))) + (define-inline 3 record-type-opaque? + [(e) (go e (constant rtd-opaque))]) + (define-inline 3 record-type-sealed? + [(e) (go e (constant rtd-sealed))]) + (define-inline 3 $record-type-act-sealed? + [(e) (go e (fxior (constant rtd-sealed) (constant rtd-act-sealed)))]) + (define-inline 3 record-type-generative? + [(e) (go e (constant rtd-generative))])) + (let () + (define build-record? + (lambda (e) + (bind #t (e) + (build-and + (%type-check mask-typed-object type-typed-object ,e) + (bind #t ([t (%mref ,e ,(constant typed-object-type-disp))]) + (build-and + (%type-check mask-record type-record ,t) + (build-not + (%inline logtest + ,(%mref ,t ,(constant record-type-flags-disp)) + (immediate ,(fix (constant rtd-opaque))))))))))) + (define build-sealed-isa? + (lambda (e e-rtd assume-record?) + (bind #t (e) + (bind #f (e-rtd) + (maybe-build-and + (and (not assume-record?) + (%type-check mask-typed-object type-typed-object ,e)) + (%inline eq? + ,(%mref ,e ,(constant typed-object-type-disp)) + ,e-rtd)))))) + (define build-unsealed-isa? + (lambda (e e-rtd assume-record?) + (let ([known-depth (nanopass-case (L7 Expr) e-rtd + [(quote ,d) (and (record-type-descriptor? d) + (vector-length (rtd-ancestors d)))] + [else #f])]) + ;; `t` is rtd of `e`, and it's used once + (define (compare-at-depth t known-depth) + (cond + [(eqv? known-depth (constant minimum-ancestry-vector-length)) + ;; no need to check ancestry array length + (%inline eq? ,e-rtd ,(%mref ,(%mref ,t ,(constant record-type-ancestry-disp)) + ,(fx+ (constant vector-data-disp) + (fx* (fx- known-depth 1) (constant ptr-bytes)))))] + [known-depth + ;; need to check ancestry array length + (let ([a (make-tmp 'a)]) + `(let ([,a ,(%mref ,t ,(constant record-type-ancestry-disp))]) + (if ,(%inline <= + (immediate ,(fxsll known-depth (constant vector-length-offset))) + ,(%mref ,a ,(constant vector-type-disp))) + ,(%inline eq? ,e-rtd ,(%mref ,a ,(fx+ (constant vector-data-disp) + (fx* (fx- known-depth 1) (constant ptr-bytes))))) + ,(%constant sfalse))))] + [else + (bind #t (e-rtd) + (let ([a (make-tmp 'a)] [rtd-a (make-tmp 'rtd-a)] [rtd-len (make-tmp 'rtd-len)]) + `(let ([,rtd-a ,(%mref ,e-rtd ,(constant record-type-ancestry-disp))]) + (let ([,a ,(%mref ,t ,(constant record-type-ancestry-disp))]) + (let ([,rtd-len ,(%mref ,rtd-a ,(constant vector-type-disp))]) + (if ,(%inline <= ,rtd-len ,(%mref ,a ,(constant vector-type-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))) + (%inline eq? ,e-rtd ,(%mref ,a + ,(translate rtd-len (constant vector-length-offset) (constant log2-ptr-bytes)) + ,(fx- (constant vector-data-disp) (constant ptr-bytes))))) + ,(%constant sfalse)))))))])) + (cond + [assume-record? + (compare-at-depth (%mref ,e ,(constant typed-object-type-disp)) known-depth)] + [else + (let ([t (make-tmp 't)]) + (bind #t (e) + (build-and + (%type-check mask-typed-object type-typed-object ,e) + `(let ([,t ,(%mref ,e ,(constant typed-object-type-disp))]) + ,(build-and + (%type-check mask-record type-record ,t) + (compare-at-depth t known-depth))))))])))) + (define-inline 3 record? + [(e) (build-record? e)] + [(e e-rtd) + (if (constant? (lambda (x) + (and (record-type-descriptor? x) + (record-type-sealed? x))) + e-rtd) + (build-sealed-isa? e e-rtd #f) + (build-unsealed-isa? e e-rtd #f))]) + (define-inline 3 record-instance? + [(e e-rtd) + (if (constant? (lambda (x) + (and (record-type-descriptor? x) + (record-type-sealed? x))) + e-rtd) + (build-sealed-isa? e e-rtd #t) + (build-unsealed-isa? e e-rtd #t))]) + (define-inline 2 r6rs:record? + [(e) (build-record? e)]) + (define-inline 2 record? + [(e) (build-record? e)] + [(e e-rtd) + (nanopass-case (L7 Expr) e-rtd + [(quote ,d) + (and (record-type-descriptor? d) + (if (record-type-sealed? d) + (build-sealed-isa? e e-rtd #f) + (build-unsealed-isa? e e-rtd #f)))] + [else #f])]) + (define-inline 2 $sealed-record? + [(e e-rtd) (build-sealed-isa? e e-rtd #f)]) + (define-inline 2 $sealed-record-instance? + [(e e-rtd) (build-sealed-isa? e e-rtd #t)]) + (define-inline 3 $record-type-field-count + [(e) (%inline srl ,(%inline - ,(%mref ,e ,(constant record-type-size-disp)) + (immediate ,(fxsll (fx- (constant record-data-disp) (constant record-type-disp)) + (constant fixnum-offset)))) + ,(%constant log2-ptr-bytes))]) + (define-inline 2 eq-hashtable? + [(e) (let ([rtd (let () (include "hashtable-types.ss") (record-type-descriptor eq-ht))]) + (let ([e-rtd `(quote ,rtd)]) + (if (record-type-sealed? rtd) + (build-sealed-isa? e e-rtd #f) + (build-unsealed-isa? e e-rtd #f))))])) + (define-inline 2 gensym? + [(e) + (bind #t (e) + (build-and + (%type-check mask-symbol type-symbol ,e) + (bind #t ([t (%mref ,e ,(constant symbol-name-disp))]) + `(if ,t + ,(build-and (%type-check mask-pair type-pair ,t) + (build-and (%mref ,t ,(constant pair-cdr-disp)) + (%constant strue))) + ,(%constant strue)))))]) + (define-inline 2 uninterned-symbol? + [(e) + (bind #t (e) + (build-and + (%type-check mask-symbol type-symbol ,e) + (bind #t ([t (%mref ,e ,(constant symbol-name-disp))]) + (build-and (%type-check mask-pair type-pair ,t) + (build-not (%mref ,t ,(constant pair-cdr-disp)))))))]) + (let () + (define build-make-symbol + (lambda (e-name) + (bind #t ([t (%constant-alloc type-symbol (constant size-symbol))]) + (%seq + (set! ,(%mref ,t ,(constant symbol-name-disp)) ,e-name) + (set! ,(%mref ,t ,(constant symbol-value-disp)) ,(%constant sunbound)) + (set! ,(%mref ,t ,(constant symbol-pvalue-disp)) + (literal + ,(make-info-literal #f 'library + (lookup-libspec nonprocedure-code) + (constant code-data-disp)))) + (set! ,(%mref ,t ,(constant symbol-plist-disp)) ,(%constant snil)) + (set! ,(%mref ,t ,(constant symbol-splist-disp)) ,(%constant snil)) + (set! ,(%mref ,t ,(constant symbol-hash-disp)) ,(%constant sfalse)) + ,t)))) + (define (go e-pname) + (bind #t ([t (%constant-alloc type-pair (constant size-pair))]) + (%seq + (set! ,(%mref ,t ,(constant pair-cdr-disp)) ,e-pname) + (set! ,(%mref ,t ,(constant pair-car-disp)) ,(%constant sfalse)) + ,(build-make-symbol t)))) + (define-inline 3 $gensym + [() (build-make-symbol (%constant sfalse))] + [(e-pname) (bind #f (e-pname) (go e-pname))] + [(e-pname e-uname) #f]) + (define-inline 3 gensym + [() (build-make-symbol (%constant sfalse))] + [(e-pname) (and (constant? immutable-string? e-pname) (go e-pname))] + [(e-pname e-uname) #f]) + (define-inline 2 gensym + [() (build-make-symbol (%constant sfalse))] + [(e-pname) (and (constant? immutable-string? e-pname) (go e-pname))] + [(e-pname e-uname) #f])) + (define-inline 3 symbol->string + [(e-sym) + (bind #t (e-sym) + (bind #t ([e-name (%mref ,e-sym ,(constant symbol-name-disp))]) + `(if ,e-name + (if ,(%type-check mask-pair type-pair ,e-name) + ,(bind #t ([e-cdr (%mref ,e-name ,(constant pair-cdr-disp))]) + `(if ,e-cdr + ,e-cdr + ,(%mref ,e-name ,(constant pair-car-disp)))) + ,e-name) + ,(%primcall #f sexpr $gensym->pretty-name ,e-sym))))]) + (define-inline 3 $fxaddress + [(e) (%inline logand + ,(let ([n (- (constant primary-type-bits) (constant fixnum-offset))]) + (if (> n 0) (%inline sra ,e (immediate ,n)) e)) + (immediate ,(- (constant fixnum-factor))))]) + (define-inline 3 $set-timer + [(e) (bind #f (e) + (bind #t ([t (build-fix (ref-reg %trap))]) + `(seq + (set! ,(ref-reg %trap) ,(build-unfix e)) + ,t)))]) + (define-inline 3 $get-timer + [() (build-fix (ref-reg %trap))]) + (define-inline 3 directory-separator? + [(e) (if-feature windows + (bind #t (e) + (build-simple-or + (%inline eq? ,e (immediate ,(ptr->imm #\/))) + (%inline eq? ,e (immediate ,(ptr->imm #\\))))) + (%inline eq? ,e (immediate ,(ptr->imm #\/))))]) + (let () + (define add-cdrs + (lambda (n e) + (if (fx= n 0) + e + (add-cdrs (fx- n 1) (%mref ,e ,(constant pair-cdr-disp)))))) + (define-inline 3 list-ref + [(e-ls e-n) + (nanopass-case (L7 Expr) e-n + [(quote ,d) + (and (and (fixnum? d) (fx< d 4)) + (%mref ,(add-cdrs d e-ls) ,(constant pair-car-disp)))] + [else #f])]) + (define-inline 3 list-tail + [(e-ls e-n) + (nanopass-case (L7 Expr) e-n + [(quote ,d) (and (and (fixnum? d) (fx<= d 4)) (add-cdrs d e-ls))] + [else #f])])) + (let () + (define (go0 src sexpr subtype) + (%primcall src sexpr $make-eq-hashtable + (immediate ,(fix (constant hashtable-default-size))) + (immediate ,(fix subtype)))) + (define (go1 src sexpr e-size subtype) + (nanopass-case (L7 Expr) e-size + [(quote ,d) + ; d must be a fixnum? for $hashtable-size-minlen and a + ; target-machine fixnum for cross compiling + (and (and (fixnum? d) (target-fixnum? d) (fx>= d 0)) + (%primcall src sexpr $make-eq-hashtable + (immediate ,(fix ($hashtable-size->minlen d))) + (immediate ,(fix subtype))))] + [else #f])) + (define-inline 3 make-eq-hashtable + [() (go0 src sexpr (constant eq-hashtable-subtype-normal))] + [(e-size) (go1 src sexpr e-size (constant eq-hashtable-subtype-normal))]) + (define-inline 3 make-weak-eq-hashtable + [() (go0 src sexpr (constant eq-hashtable-subtype-weak))] + [(e-size) (go1 src sexpr e-size (constant eq-hashtable-subtype-weak))]) + (define-inline 3 make-ephemeron-eq-hashtable + [() (go0 src sexpr (constant eq-hashtable-subtype-ephemeron))] + [(e-size) (go1 src sexpr e-size (constant eq-hashtable-subtype-ephemeron))])) + (let () + (define-syntax def-put-x + (syntax-rules () + [(_ name x-length) + (define-inline 3 name + [(e-bop e-x) + (bind #t (e-x) + (build-libcall #f src sexpr name e-bop e-x `(immediate 0) + (handle-prim #f #f 3 'x-length (list e-x))))] + [(e-bop e-x e-start) + (bind #t (e-x e-start) + (build-libcall #f src sexpr name e-bop e-x e-start + (%inline - + ,(handle-prim #f #f 3 'x-length (list e-x)) + ,e-start)))] + [(e-bop e-x e-start e-count) + (build-libcall #f src sexpr name e-bop e-x e-start e-count)])])) + (def-put-x put-bytevector bytevector-length) + (def-put-x put-bytevector-some bytevector-length) + (def-put-x put-string string-length) + (def-put-x put-string-some string-length)) + + (define-inline 3 $read-time-stamp-counter + [() + (constant-case architecture + [(x86) + (%seq + ; returns low-order 32 bits in eax, high-order in edx + (set! ,%eax (inline ,(make-info-kill* (reg-list %edx)) ,%read-time-stamp-counter)) + ,(u32xu32->ptr %edx %eax))] + [(x86_64) + (%seq + ; returns low-order 32 bits in rax, high-order in rdx + (set! ,%rax (inline ,(make-info-kill* (reg-list %rdx)) ,%read-time-stamp-counter)) + ,(unsigned->ptr + (%inline logor ,(%inline sll ,%rdx (immediate 32)) ,%rax) + 64))] + [(arm32 pb) (unsigned->ptr (%inline read-time-stamp-counter) 32)] + [(arm64) (unsigned->ptr (%inline read-time-stamp-counter) 64)] + [(ppc32) + (let ([t-hi (make-tmp 't-hi)]) + `(let ([,t-hi (inline ,(make-info-kill* (reg-list %real-zero)) + ,%read-time-stamp-counter)]) + ,(u32xu32->ptr t-hi %real-zero)))])]) + + (define-inline 3 $read-performance-monitoring-counter + [(e) + (constant-case architecture + [(x86) + (%seq + (set! ,%eax (inline ,(make-info-kill* (reg-list %edx)) ,%read-performance-monitoring-counter ,(build-unfix e))) + ,(u32xu32->ptr %edx %eax))] + [(x86_64) + (%seq + (set! ,%rax (inline ,(make-info-kill* (reg-list %rdx)) ,%read-performance-monitoring-counter ,(build-unfix e))) + ,(unsigned->ptr + (%inline logor ,(%inline sll ,%rdx (immediate 32)) ,%rax) + 64))] + [(arm32 ppc32 pb) (unsigned->ptr (%inline read-performance-monitoring-counter ,(build-unfix e)) 32)] + [(arm64) (unsigned->ptr (%inline read-performance-monitoring-counter ,(build-unfix e)) 64)])]) + + (define-inline 3 assert-unreachable + [() (%constant svoid)]) + + )) ; expand-primitives module + +(set! $np-expand-primitives np-expand-primitives) +) diff --git a/src/ChezScheme/s/cptypes-lattice.ss b/src/ChezScheme/s/cptypes-lattice.ss new file mode 100644 index 0000000000..08ad09ca9b --- /dev/null +++ b/src/ChezScheme/s/cptypes-lattice.ss @@ -0,0 +1,1146 @@ +;;; cptypes-lattice.ss +;;; Copyright 1984-2020 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. + +; bottom -> empty set / the expression raised an error +; <something> -> some other set +; ptr -> all single values expressions +; #f -> a result that may be single or multiple valued. + +; bottom => <something> => ptr => #f + +; properties of bottom: +; (implies? x bottom): only for x=bottom +; (implies? bottom y): always +; (disjoint? x bottom): always +; (disjoint? bottom y): always +; remember to check (implies? x bottom) before (implies? x something) + +(module cptypes-lattice + (primref-name/nqm->predicate + ptr-pred + eof/char-pred + maybe-char-pred + maybe-symbol-pred + $fixmediate-pred + $list-pred ; immutable lists + true-pred ; anything that is not #f + true-rec ; only the #t object + false-rec + void-rec + null-rec + eof-rec + bwp-rec + predicate-is-ptr? + predicate-implies? + predicate-disjoint? + predicate-intersect + predicate-union + make-pred-$record/rtd + make-pred-$record/ref) + + (define-record-type pred-or + (fields imm nor rec) + (nongenerative #{pred-or nlomo7xtc1nguv2umpzwho0dt-0}) + (sealed #t)) + + (define-record-type pred-$record/rtd + (fields rtd) + (nongenerative #{pred-$record/rtd wnquzwrp8wl515lhz2url8sjc-0}) + (sealed #t)) + + (define-record-type pred-$record/ref + (fields ref maybe-rtd) + (nongenerative #{pred-$record/ref zc0e8e4cs8scbwhdj7qpad6k3-1}) + (sealed #t)) + + (include "base-lang.ss") + (with-output-language (Lsrc Expr) + (define void-rec `(quote ,(void))) + (define true-rec `(quote #t)) + (define false-rec `(quote #f)) + (define null-rec `(quote ())) + (define eof-rec `(quote #!eof)) + (define bwp-rec `(quote #!bwp))) + + (define true-pred (make-pred-or 'true-immediate 'normalptr '$record)) + (define ptr-pred (make-pred-or 'immediate 'normalptr '$record)) + (define null-or-pair-pred (make-pred-or null-rec 'pair 'bottom)) + (define $list-pred (make-pred-or null-rec '$list-pair 'bottom)) + (define $fixmediate-pred (make-pred-or 'immediate 'fixnum 'bottom)) + (define maybe-fixnum-pred (make-pred-or false-rec 'fixnum 'bottom)) + (define eof/fixnum-pred (make-pred-or eof-rec 'fixnum 'bottom)) + (define maybe-exact-integer-pred (make-pred-or false-rec 'fixnum 'bottom)) + (define maybe-flonum-pred (make-pred-or false-rec 'flonum 'bottom)) + (define maybe-number-pred (make-pred-or false-rec 'number 'bottom)) + (define maybe-symbol-pred (make-pred-or false-rec 'symbol 'bottom)) + (define maybe-procedure-pred (make-pred-or false-rec 'procedure 'bottom)) + (define maybe-string-pred (make-pred-or false-rec 'string 'bottom)) + (define eof/string-pred (make-pred-or eof-rec 'string 'bottom)) + (define maybe-bytevector-pred (make-pred-or false-rec 'bytevector 'bottom)) + (define eof/bytevector-pred (make-pred-or eof-rec 'bytevector 'bottom)) + (define maybe-pair-pred (make-pred-or false-rec 'pair 'bottom)) + (define maybe-normalptr-pred (make-pred-or false-rec 'normalptr 'bottom)) + (define maybe-$record-pred (make-pred-or false-rec 'bottom '$record)) + ; These are just symbols, but we assign a name for uniformity. + (define maybe-char-pred 'maybe-char) + (define eof/char-pred 'eof/char) + + ; This can be implemented with implies? + ; but let's use the straightforward test. + (define (predicate-is-ptr? x) + (and (pred-or? x) + (eq? (pred-or-imm x) 'immediate) + (eq? (pred-or-nor x) 'normalptr) + (eq? (pred-or-rec x) '$record))) + + ; 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-ancestors (csv7:record-field-accessor #!base-rtd 'ancestors)) + (define rtd-flds (csv7:record-field-accessor #!base-rtd 'flds)) + + ;could be a ctrtd + (define (pred-$record-maybe-rtd x) + (cond + [(pred-$record/rtd? x) (pred-$record/rtd-rtd x)] + [(pred-$record/ref? x) (pred-$record/ref-maybe-rtd x)] + [else #f])) + + (define (rtd-obviously-incompatible? x y) + (let ([x-flds (rtd-flds x)] + [y-flds (rtd-flds y)]) + (or (and (fixnum? x-flds) (not (fixnum? y-flds))) + (and (not (fixnum? x-flds)) (fixnum? y-flds))))) + + ;true when x is an ancestor of y + ;includes the case when they are the same + (define (rtd-ancestor*? x y) + (or (eq? x y) + (let () + (define ax (rtd-ancestors x)) + (define lx (vector-length ax)) + (define ay (rtd-ancestors y)) + (define ly (vector-length ay)) + (and (fx<= lx ly) + (eq? x (vector-ref ay (fx- lx 1))))))) + + ;includes the case when they are the same + ;or when one is the ancestor of the other + (define (rdt-last-common-ancestor* x y) + (cond + [(eq? x y) x] + [else + (let () + (define ax (rtd-ancestors x)) + (define lx (vector-length ax)) + (define ay (rtd-ancestors y)) + (define ly (vector-length ay)) + (cond + [(and (fx<= lx ly) + (eq? x (vector-ref ay (fx- lx 1)))) + x] + [(and (fx<= ly lx) + (eq? y (vector-ref ax (fx- ly 1)))) + y] + [else + ;; binary search to find a common prefix, given that + ;; no elements are the same after a common prefix + (let loop ([lo 0] [hi (fxmin lx ly)]) + (cond + [(fx= lo hi) #f] + [else (let* ([i (fxquotient (fx+ lo hi) 2)] + [v (vector-ref ax i)]) + (cond + [(eq? v (vector-ref ay i)) + (or (loop (fx+ i 1) hi) + v)] + [else + (loop lo i)]))]))]))])) + + ; nqm: no question mark + ; Transform the types used in primdata.ss + ; to the internal representation used here + ; When extend is #f the result is a predicate that recognizes less values + ; than the one in name. This is useful for reductions like + ; (pred? x) ==> #t and (something x) ==> (#3%something x) + ; When extend is #t the result is a predicate that recognizes more values + ; than the one in name. This is useful for reductions like + ; (pred? x) ==> #f and (something x) ==> <error> + ; In case the non extended version is not #f, the extended version must be not #f + (define (primref-name/nqm->predicate name extend?) + (cond + [(not name) + #f] + [(pair? name) + (cond + [(equal? name '(ptr . ptr)) + 'pair] + [else + (if (not extend?) 'bottom 'pair)])] + [else + (let ([r (do-primref-name/nqm->predicate name extend?)]) + (cond + [(pair? r) + (if extend? (cdr r) (car r))] + [else + r]))])) + + (define (do-primref-name/nqm->predicate name extend?) + (case name + [bottom 'bottom] + [ptr ptr-pred] + [sub-ptr (cons 'bottom ptr-pred)] + + [char 'char] + [maybe-char maybe-char-pred] + [eof/char eof/char-pred] + [boolean 'boolean] + [true true-pred] + [false false-rec] + [void void-rec] + [null null-rec] + [eof-object eof-rec] + [bwp-object bwp-rec] + [$immediate 'immediate] + + [pair 'pair] + [maybe-pair maybe-pair-pred] + [list (cons $list-pred null-or-pair-pred)] + [list-assuming-immutable $list-pred] + [box 'box] + [vector 'vector] + [string 'string] + [sub-string '(bottom . string)] + [maybe-string maybe-string-pred] + [eof/string eof/string-pred] + [bytevector 'bytevector] + [maybe-bytevector maybe-bytevector-pred] + [eof/bytevector eof/bytevector-pred] + [fxvector 'fxvector] + [flvector 'flvector] + [pathname 'string] + [maybe-pathname maybe-string-pred] + [procedure 'procedure] + [maybe-procedure maybe-procedure-pred] + [maybe-who maybe-normalptr-pred] ;should be maybe-string/symbol + + [gensym 'gensym] + [uninterned-symbol 'uninterned-symbol] + [interned-symbol 'interned-symbol] + [symbol 'symbol] + [maybe-symbol maybe-symbol-pred] + [sub-symbol '(bottom . symbol)] + [maybe-sub-symbol (cons false-rec maybe-symbol-pred)] + + [fixnum 'fixnum] + [(sub-fixnum bit length sub-length ufixnum sub-ufixnum pfixnum index sub-index u8 s8 u8/s8) '(bottom . fixnum)] + [maybe-fixnum maybe-fixnum-pred] + [maybe-ufixnum (cons false-rec maybe-fixnum-pred)] + [(eof/length eof/u8) (cons eof-rec eof/fixnum-pred)] + [bignum 'bignum] + [(exact-integer sint) 'exact-integer] + [(uint sub-uint nzuint exact-uinteger sub-sint) '(bottom . exact-integer)] + [maybe-uint (cons false-rec maybe-exact-integer-pred)] + [flonum 'flonum] + [sub-flonum '(bottom . flonum)] + [maybe-flonum maybe-flonum-pred] + [real 'real] + [(integer rational) '(exact-integer . real)] + [(uinteger sub-integer) '(bottom . real)] + [cflonum '(flonum . number)] + [number 'number] + [sub-number '(bottom . number)] + [maybe-number maybe-number-pred] + + [$record '$record] + [(record rtd) '(bottom . $record)] ; not sealed + [(maybe-rtd) (cons false-rec maybe-$record-pred)] + [(transcoder textual-input-port textual-output-port binary-input-port binary-output-port) '(bottom . $record)] ; opaque + [(maybe-transcoder maybe-textual-input-port maybe-textual-output-port maybe-binary-input-port maybe-binary-output-port input-port output-port) (cons false-rec maybe-$record-pred)] + [(rcd sfd timeout) '(bottom . $record)] ; not opaque, sealed + [(maybe-rcd maybe-sub-rcd maybe-sfd maybe-timeout) (cons false-rec maybe-$record-pred)] + + [else (cons 'bottom true-pred)])); for all other types that exclude #f + + (define (check-constant-is? x pred?) + (and (Lsrc? x) + (nanopass-case (Lsrc Expr) x + [(quote ,d) (pred? d)] + [else #f]))) + + (define (check-constant-eqv? x v) + (and (Lsrc? x) + (nanopass-case (Lsrc Expr) x + [(quote ,d) (eqv? d v)] + [else #f]))) + + (define (exact-integer? x) + (and (integer? x) (exact? x))) + + (define (interned-symbol? x) + (and (symbol? x) + (not (gensym? x)) + (not (uninterned-symbol? x)))) + + ;only false-rec, boolean, maybe-char and immediate may be '#f + ;use when the other argument is truthy bur not exactly '#t + (define (union/true x) + (cond + [(or (eq? x 'boolean) + (eq? x 'maybe-char) + (check-constant-eqv? x #f)) + 'immediate] + [else + 'true-immediate])) + + (define (predicate-union/immediate x y) + (cond + [(eq? x y) y] + [(eq? x 'bottom) y] + [(eq? y 'bottom) x] + [(eq? y 'immediate) y] + [(eq? x 'immediate) x] + [(Lsrc? y) + (nanopass-case (Lsrc Expr) y + [(quote ,d1) + (define dy d1) + (cond + [(check-constant-eqv? x dy) + y] + [(not dy) + (cond + [(or (eq? x 'boolean) + (check-constant-eqv? x #t)) + 'boolean] + [(or (eq? x 'char) + (eq? x 'maybe-char) + (check-constant-is? x char?)) + 'maybe-char] + [else + 'immediate])] + [(eq? dy #t) + (cond + [(or (eq? x 'boolean) + (check-constant-eqv? x #f)) + 'boolean] + [(eq? x 'maybe-char) + 'immediate] + [else + 'true-immediate])] + [(char? dy) + (cond + [(or (eq? x 'char) + (check-constant-is? x char?)) + 'char] + [(or (eq? x 'maybe-char) + (check-constant-eqv? x #f)) + 'maybe-char] + [(or (eq? x 'eof/char) + (check-constant-is? x eof-object?)) + 'eof/char] + [else + (union/true x)])] + [(eof-object? dy) + (cond + [(or (eq? x 'eof/char) + (eq? x 'char) + (check-constant-is? x char?)) + 'eof/char] + [else + (union/true x)])] + [else + (union/true x)])])] + [else + (case y + [(boolean) + (cond + [(check-constant-is? x boolean?) + y] + [else + 'immediate])] + [(char) + (cond + [(or (eq? x 'maybe-char) + (check-constant-eqv? x #f)) + 'maybe-char] + [(or (eq? x 'eof/char) + (check-constant-is? x eof-object?)) + 'eof/char] + [(check-constant-is? x char?) + y] + [else + (union/true x)])] + [(eof/char) + (cond + [(or (eq? x 'char) + (check-constant-is? x char?) + (check-constant-is? x eof-object?)) + y] + [else + (union/true x)])] + [(maybe-char) + (cond + [(or (eq? x 'char) + (check-constant-is? x char?) + (check-constant-eqv? x #f)) + y] + [else + 'immediate])] + [else + (union/true x)])])) + + (define (union/simple x pred? y) + (cond + [(or (check-constant-is? x pred?) + (eq? x y)) + y] + [else + 'normalptr])) + + (define (union/symbol x pred? y) + (cond + [(or (check-constant-is? x pred?) + (eq? x y)) + y] + [(or (eq? x 'gensym) + (eq? x 'interned-symbol) + (eq? x 'uninterned-symbol) + (eq? x 'symbol) + (check-constant-is? x symbol?)) + 'symbol] + [else + 'normalptr])) + + (define (union/fixnum x) + (cond + [(check-constant-is? x target-fixnum?) + 'fixnum] + [(or (eq? x 'bignum) + (eq? x 'exact-integer) + (check-constant-is? x exact-integer?)) + 'exact-integer] + [(or (eq? x 'flonum) + (eq? x 'real) + (check-constant-is? x real?)) + 'real] + [(or (eq? x 'number) + (check-constant-is? x number?)) + 'number] + [else + 'normalptr])) + + (define (union/bignum x) + (cond + [(check-constant-is? x target-bignum?) + 'bignum] + [(or (eq? x 'fixnum) + (eq? x 'exact-integer) + (check-constant-is? x exact-integer?)) + 'exact-integer] + [(or (eq? x 'flonum) + (eq? x 'real) + (check-constant-is? x real?)) + 'real] + [(or (eq? x 'number) + (check-constant-is? x number?)) + 'number] + [else + 'normalptr])) + + (define (union/exact-integer x) + (cond + [(or (eq? x 'fixnum) + (eq? x 'bignum) + (check-constant-is? x exact-integer?)) + 'exact-integer] + [(or (eq? x 'flonum) + (eq? x 'real) + (check-constant-is? x real?)) + 'real] + [(or (eq? x 'number) + (check-constant-is? x number?)) + 'number] + [else + 'normalptr])) + + (define (union/flonum x) + (cond + [(or (check-constant-is? x flonum?)) + 'flonum] + [(or (eq? x 'real) + (check-constant-is? x real?)) + 'real] + [(or (eq? x 'number) + (check-constant-is? x number?)) + 'number] + [else + 'normalptr])) + + (define (union/real x) + (cond + [(or (eq? x 'fixnum) + (eq? x 'bignum) + (eq? x 'exact-integer) + (eq? x 'flonum) + (check-constant-is? x real?)) + 'real] + [(or (eq? x 'number) + (check-constant-is? x number?)) + 'number] + [else + 'normalptr])) + + (define (union/number x) + (cond + [(or (eq? x 'fixnum) + (eq? x 'bignum) + (eq? x 'exact-integer) + (eq? x 'flonum) + (eq? x 'real) + (check-constant-is? x number?)) + 'number] + [else + 'normalptr])) + + (define (predicate-union/normal x y) + (cond + [(eq? x y) y] + [(eq? x 'bottom) y] + [(eq? y 'bottom) x] + [(eq? y 'normalptr) y] + [(eq? x 'normalptr) x] + [(Lsrc? y) + (nanopass-case (Lsrc Expr) y + [(quote ,d1) + (define dy d1) + (cond + [(check-constant-eqv? x dy) + y] + [(fixnum? dy) + (union/fixnum x)] + [(bignum? dy) + (union/bignum x)] + [(exact-integer? dy) + (union/exact-integer x)] + [(flonum? dy) + (union/flonum x)] + [(real? dy) + (union/real x)] + [(number? dy) + (union/number x)] + [(gensym? dy) (union/symbol x gensym? 'gensym)] + [(uninterned-symbol? dy) (union/symbol x uninterned-symbol? 'uninterned-symbol)] + [(interned-symbol? dy) (union/symbol x interned-symbol? 'interned-symbol)] + [(vector? dy) (union/simple x vector? 'vector)]; i.e. #() + [(string? dy) (union/simple x string? 'string)]; i.e. "" + [(bytevector? dy) (union/simple x bytevector? 'bytevector)] ; i.e. '#vu8() + [(fxvector? dy) (union/simple x fxvector? 'fxvector)] ; i.e. '#vfx() + [(flvector? dy) (union/simple x flvector? 'flvector)] ; i.e. '#vfl() + [else + 'normalptr])])] + [else + (case y + [(fixnum) + (union/fixnum x)] + [(bignum) + (union/bignum x)] + [(exact-integer) + (union/exact-integer x)] + [(flonum) + (union/flonum x)] + [(real) + (union/real x)] + [(number) + (union/number x)] + [(gensym) + (union/symbol x gensym? 'gensym)] + [(uninterned-symbol) + (union/symbol x uninterned-symbol? 'uninterned-symbol)] + [(interned-symbol) + (union/symbol x interned-symbol? 'interned-symbol)] + [(symbol) + (union/symbol x symbol? 'symbol)] + [(pair $list-pair) + (cond + [(or (eq? x 'pair) + (eq? x '$list-pair)) + 'pair] + [else + 'normalptr])] + [(vector) (union/simple x vector? y)]; i.e. #() + [(string) (union/simple x string? y)]; i.e. "" + [(bytevector) (union/simple x bytevector? y)] ; i.e. '#vu8() + [(fxvector) (union/simple x fxvector? y)] ; i.e. '#vfx() + [(flvector) (union/simple x flvector? y)] ; i.e. '#vfl() + [else + 'normalptr])])) + + (define (predicate-union/record x y) + (cond + [(eq? x y) y] + [(eq? x 'bottom) y] + [(eq? y 'bottom) x] + [(eq? y '$record) y] + [(eq? x '$record) x] + [(pred-$record/rtd? y) + (cond + [(pred-$record/rtd? x) + (let ([x-rtd (pred-$record/rtd-rtd x)] + [y-rtd (pred-$record/rtd-rtd y)]) + (cond + [(eqv? x-rtd y-rtd) + y] + [(record-type-sealed? x-rtd) + (if (rtd-ancestor*? y-rtd x-rtd) y '$record)] + [(record-type-sealed? y-rtd) + (if (rtd-ancestor*? x-rtd y-rtd) x '$record)] + [else + (let ([lca-rtd (rdt-last-common-ancestor* x-rtd y-rtd)]) + (cond + [(not lca-rtd) '$record] + [(eqv? lca-rtd y-rtd) y] + [(eqv? lca-rtd x-rtd) x] + [else (make-pred-$record/rtd lca-rtd)]))]))] + [else + '$record])] + [(pred-$record/ref? y) + (cond + [(pred-$record/ref? x) + (if (eq? (pred-$record/ref-ref x) + (pred-$record/ref-ref y)) + y + '$record)] + [else + '$record])] + [else + '$record])) + + (define (intersect/true x y) + (cond + [(eq? x 'true-immediate) + y] + [else + 'bottom])) + + (define (predicate-intersect/immediate x y) + (cond + [(eq? x y) x] + [(eq? y 'bottom) 'bottom] + [(eq? x 'bottom) 'bottom] + [(eq? y 'immediate) x] + [(eq? x 'immediate) y] + [(Lsrc? y) + (nanopass-case (Lsrc Expr) y + [(quote ,d1) + (define dy d1) + (cond + [(check-constant-eqv? x dy) + x] + [(not dy) + (cond + [(or (eq? x 'boolean) + (eq? x 'maybe-char)) + y] + [else + 'bottom])] + [(eq? dy #t) + (cond + [(eq? x 'boolean) + y] + [else + (intersect/true x y)])] + [(char? dy) + (cond + [(or (eq? x 'char) + (eq? x 'maybe-char) + (eq? x 'eof/char)) + y] + [else + (intersect/true x y)])] + [(eof-object? dy) + (cond + [(eq? x 'eof/char) + y] + [else + (intersect/true x y)])] + [else + (intersect/true x y)])])] + [else + (case y + [(boolean) + (cond + [(eq? x 'true-immediate) + true-rec] + [(eq? x 'maybe-char) + false-rec] + [(check-constant-is? x boolean?) + x] + [else + 'bottom])] + [(true-immediate) + (cond + [(eq? x 'boolean) + true-rec] + [(eq? x 'maybe-char) + 'char] + [(check-constant-eqv? x #f) + 'bottom] + [else + x])] + [(char) + (cond + [(or (eq? x 'maybe-char) + (eq? x 'eof/char)) + y] + [(check-constant-is? x char?) + x] + [else + (intersect/true x y)])] + [(eof/char) + (cond + [(eq? x 'maybe-char) + 'char] + [(or (eq? x 'char) + (check-constant-is? x char?) + (check-constant-is? x eof-object?)) + x] + [else + (intersect/true x y)])] + [(maybe-char) + (cond + [(or (eq? x 'eof/char) + (eq? x 'true-immediate)) + 'char] + [(or (eq? x 'char) + (check-constant-is? x char?) + (check-constant-eqv? x #f)) + x] + [(eq? x 'boolean) + false-rec] + [else + 'bottom])] + [else + (intersect/true x y)])])) + + (define (intersect/simple x pred? qpred y) + (cond + [(and pred? (check-constant-is? x pred?)) + x] + [(eq? x qpred) + y] + [else + 'bottom])) + + (define (intersect/symbol x pred? qpred y) + (cond + [(and pred? (check-constant-is? x pred?)) + x] + [(or (eq? x qpred) + (eq? x 'symbol)) + y] + [else + 'bottom])) + + (define (intersect/fixnum x check? y) + (cond + [(and check? (check-constant-is? x fixnum?)) + x] + [(or (eq? x 'fixnum) + (eq? x 'exact-integer) + (eq? x 'real) + (eq? x 'number)) + y] + [else + 'bottom])) + + (define (intersect/bignum x check? y) + (cond + [(and check? (check-constant-is? x bignum?)) + x] + [(or (eq? x 'bignum) + (eq? x 'exact-integer) + (eq? x 'real) + (eq? x 'number)) + y] + [else + 'bottom])) + + (define (intersect/exact-integer x check? y) + (cond + [(and check? (or (check-constant-is? x exact-integer?) + (eq? x 'fixnum) + (eq? x 'bignum))) + x] + [(or (eq? x 'exact-integer) + (eq? x 'real) + (eq? x 'number)) + y] + [else + 'bottom])) + + (define (intersect/flonum x check? y) + (cond + [(and check? (check-constant-is? x flonum?)) + x] + [(or (eq? x 'flonum) + (eq? x 'real) + (eq? x 'number)) + y] + [else + 'bottom])) + + (define (intersect/real x check? y) + (cond + [(and check? (or (check-constant-is? x real?) + (eq? x 'fixnum) + (eq? x 'bignum) + (eq? x 'exact-integer) + (eq? x 'flonum))) + x] + [(or (eq? x 'real) + (eq? x 'number)) + y] + [else + 'bottom])) + + (define (intersect/number x check? y) + (cond + [(and check? (eq? x 'fixnum)) + x] + [(and check? (or (check-constant-is? x number?) + (eq? x 'fixnum) + (eq? x 'bignum) + (eq? x 'exact-integer) + (eq? x 'flonum) + (eq? x 'real))) + x] + [(eq? x 'number) + y] + [else + 'bottom])) + + (define (predicate-intersect/normal x y) + (cond + [(eq? x y) x] + [(eq? y 'bottom) 'bottom] + [(eq? x 'bottom) 'bottom] + [(eq? y 'normalptr) x] + [(eq? x 'normalptr) y] + [(Lsrc? y) + (nanopass-case (Lsrc Expr) y + [(quote ,d1) + (define dy d1) + (cond + [(check-constant-eqv? x dy) + x] + [(fixnum? dy) + (intersect/fixnum x #f y)] + [(bignum? dy) + (intersect/bignum x #f y)] + [(exact-integer? dy) + (intersect/exact-integer x #f y)] + [(flonum? dy) + (intersect/flonum x #f y)] + [(real? dy) + (intersect/real x #f y)] + [(number? dy) + (intersect/number x #f y)] + [(gensym? dy) (intersect/symbol x #f 'gensym y)] + [(uninterned-symbol? dy) (intersect/symbol x #f 'uninterned-symbol y)] + [(interned-symbol? dy) (intersect/symbol x #f 'interned-symbol y)] + [(vector? dy) (intersect/simple x #f 'vector y)]; i.e. #() + [(string? dy) (intersect/simple x #f 'string y)]; i.e. "" + [(bytevector? dy) (intersect/simple x bytevector? 'bytevector y)] ; i.e. '#vu8() + [(fxvector? dy) (intersect/simple x #f 'fxvector y)] ; i.e. '#vfx() + [(flvector? dy) (intersect/simple x #f 'flvector y)] ; i.e. '#vfl() + [else + 'bottom])])] + [else + (case y + [(fixnum) + (intersect/fixnum x #t y)] + [(bignum) + (intersect/bignum x #t y)] + [(exact-integer) + (intersect/exact-integer x #t y)] + [(flonum) + (intersect/flonum x #t y)] + [(real) + (intersect/real x #t y)] + [(number) + (intersect/number x #t y)] + [(gensym) + (intersect/symbol x gensym? 'gensym y)] + [(uninterned-symbol) + (intersect/symbol x uninterned-symbol? 'uninterned-symbol y)] + [(interned-symbol) + (intersect/symbol x interned-symbol? 'interned-symbol y)] + [(symbol) + (cond + [(or (eq? x 'gensym) + (eq? x 'uninterned-symbol) + (eq? x 'interned-symbol) + (eq? x 'symbol) + (check-constant-is? x symbol?)) + x] + [else + 'bottom])] + [(pair $list-pair) + (cond + [(or (eq? x 'pair) + (eq? x '$list-pair)) + '$list-pair] + [else + 'bottom])] + [(vector) (intersect/simple x vector? 'vector y)]; i.e. #() + [(string) (intersect/simple x string? 'string y)]; i.e. "" + [(bytevector) (intersect/simple x bytevector? 'bytevector y)] ; i.e. '#vu8() + [(fxvector) (intersect/simple x fxvector? 'fxvector y)] ; i.e. '#vfx() + [(flvector) (intersect/simple x flvector? 'flvector y)] ; i.e. '#vfl() + [else + 'bottom])])) + + (define (intersect/record x y) + (cond + [(or (pred-$record/ref? x) + (pred-$record/rtd? x)) + x] + [(eq? x '$record) + y] + [else + 'bottom])) + + (define (predicate-intersect/record x y) + (cond + [(eq? x y) x] + [(not y) x] + [(not x) y] + [(eq? y 'bottom) 'bottom] + [(eq? x 'bottom) 'bottom] + [(eq? y '$record) x] + [(eq? x '$record) y] + [(pred-$record/rtd? y) + (cond + [(pred-$record/rtd? x) + (let ([x-rtd (pred-$record/rtd-rtd x)] + [y-rtd (pred-$record/rtd-rtd y)]) + (cond + [(eqv? x-rtd y-rtd) + x] + [(record-type-sealed? x-rtd) + (if (rtd-ancestor*? y-rtd x-rtd) x 'bottom)] + [(record-type-sealed? y-rtd) + (if (rtd-ancestor*? x-rtd y-rtd) y 'bottom)] + [else + (cond + [(rtd-ancestor*? y-rtd x-rtd) x] + [(rtd-ancestor*? x-rtd y-rtd) y] + [else 'bottom])]))] + [(pred-$record/ref? x) + (let ([x-rtd (pred-$record/ref-maybe-rtd x)] + [y-rtd (pred-$record/rtd-rtd y)]) + (if (and x-rtd (rtd-obviously-incompatible? x-rtd y-rtd)) + 'bottom + (intersect/record x y)))] + [else + (intersect/record x y)])] + [(pred-$record/ref? y) + (let ([y-rtd (pred-$record/ref-maybe-rtd y)] + [x-rtd (pred-$record-maybe-rtd x)]) + (if (and x-rtd y-rtd (rtd-obviously-incompatible? x-rtd y-rtd)) + 'bottom + (intersect/record x y)))] + [else + (case y + [($record) + (intersect/record x y)] + [else + 'bottom])])) + + + (define (predicate-implies? x y) + (eq? (predicate-union x y) y)) + + (define (predicate-disjoint? x y) + (eq? (predicate-intersect x y) 'bottom)) + + (define (predicate->class x) + (cond + #;[(eq? x 'bottom) 'bottom] + [(or (check-constant-is? x $immediate?) + (memq x '(boolean char maybe-char eof/char true-immediate immediate))) + 'immediate] + [(or (eq? x '$record) + (pred-$record/rtd? x) + (pred-$record/ref? x)) + '$record] + [else + 'normalptr])) + + (define build-pred-or + (case-lambda + [(i n r) + (build-pred-or i n r #f #f)] + [(i n r x) + (build-pred-or i n r x #f)] + [(i n r x y) + (cond + [(and x + (eq? (pred-or-imm x) i) + (eq? (pred-or-nor x) n) + (eq? (pred-or-rec x) r)) + x] + [(and y + (eq? (pred-or-imm y) i) + (eq? (pred-or-nor y) n) + (eq? (pred-or-rec y) r)) + y] + [(eq? i 'bottom) + (cond + [(eq? n 'bottom) r] + [(eq? r 'bottom) n] + [else (make-pred-or i n r)])] + [else + (cond + [(and (eq? n 'bottom) (eq? r 'bottom)) i] + [else (make-pred-or i n r)])])])) + + ;If x and y are equivalent, they result must be eq? to y + ;so it's easy to test in predicate-implies?. + ;The result may be bigger than the actual union. + (define (predicate-union x y) + (cond + [(or (not x) (not y)) #f] + [(eq? x 'bottom) y] + [(eq? y 'bottom) x] + [(and (pred-or? x) + (pred-or? y)) + (let () + (define i (predicate-union/immediate (pred-or-imm x) (pred-or-imm y))) + (define n (predicate-union/normal (pred-or-nor x) (pred-or-nor y))) + (define r (predicate-union/record (pred-or-rec x) (pred-or-rec y))) + (build-pred-or i n r y x))] + [(pred-or? x) + (case (predicate->class y) + [(immediate) + (build-pred-or (predicate-union/immediate (pred-or-imm x) y) + (pred-or-nor x) + (pred-or-rec x) + x)] + [(normalptr) + (build-pred-or (pred-or-imm x) + (predicate-union/normal (pred-or-nor x) y) + (pred-or-rec x) + x)] + [($record) + (build-pred-or (pred-or-imm x) + (pred-or-nor x) + (predicate-union/record (pred-or-rec x) y) + x)])] + [(pred-or? y) + (case (predicate->class x) + [(immediate) + (build-pred-or (predicate-union/immediate x (pred-or-imm y)) + (pred-or-nor y) + (pred-or-rec y) + y)] + [(normalptr) + (build-pred-or (pred-or-imm y) + (predicate-union/normal x (pred-or-nor y)) + (pred-or-rec y) + y)] + [($record) + (build-pred-or (pred-or-imm y) + (pred-or-nor y) + (predicate-union/record x (pred-or-rec y)) + y)])] + [else + (let () + (define cx (predicate->class x)) + (define cy (predicate->class y)) + (cond + [(eq? cx cy) + (case cx + [(immediate) + (predicate-union/immediate x y)] + [(normalptr) + (predicate-union/normal x y)] + [($record) + (predicate-union/record x y)])] + [else + (let () + (define i (cond + [(eq? cx 'immediate) x] + [(eq? cy 'immediate) y] + [else 'bottom])) + (define n (cond + [(eq? cx 'normalptr) x] + [(eq? cy 'normalptr) y] + [else 'bottom])) + (define r (cond + [(eq? cx '$record) x] + [(eq? cy '$record) y] + [else 'bottom])) + (build-pred-or i n r))]))])) + + ;The result may be bigger than the actual intersection + ;if there is no exact result, it must be at least included in x + ;so it's possible to make decreasing sequences. + ;Anyway, for now the result is exact. + (define (predicate-intersect x y) + (cond + [(not x) y] + [(not y) x] + [(or (eq? x 'bottom) + (eq? y 'bottom)) + 'bottom] + [(and (pred-or? x) + (pred-or? y)) + (let () + (define i (predicate-intersect/immediate (pred-or-imm x) (pred-or-imm y))) + (define n (predicate-intersect/normal (pred-or-nor x) (pred-or-nor y))) + (define r (predicate-intersect/record (pred-or-rec x) (pred-or-rec y))) + (build-pred-or i n r x y))] + [(pred-or? x) + (case (predicate->class y) + [(immediate) + (predicate-intersect/immediate (pred-or-imm x) y)] + [(normalptr) + (predicate-intersect/normal (pred-or-nor x) y)] + [($record) + (predicate-intersect/record (pred-or-rec x) y)])] + [(pred-or? y) + (case (predicate->class x) + [(immediate) + (predicate-intersect/immediate x (pred-or-imm y))] + [(normalptr) + (predicate-intersect/normal x (pred-or-nor y))] + [($record) + (predicate-intersect/record x (pred-or-rec y))])] + [else + (let () + (define cx (predicate->class x)) + (define cy (predicate->class y)) + (cond + [(not (eq? cx cy)) + 'bottom] + [else + (case cx + [(immediate) + (predicate-intersect/immediate x y)] + [(normalptr) + (predicate-intersect/normal x y)] + [($record) + (predicate-intersect/record x y)])]))])) +) diff --git a/src/ChezScheme/s/cptypes.ss b/src/ChezScheme/s/cptypes.ss index 19e646d5b3..8e09679e40 100644 --- a/src/ChezScheme/s/cptypes.ss +++ b/src/ChezScheme/s/cptypes.ss @@ -54,6 +54,9 @@ Notes: * a record #[pred-$record/ref <ref>] to signal that it's a record of a type that is stored in the variable <ref> (these may collide with other records) + * a record #[pred-or <imm> <nor> <rec>] where <imm> a predicate for + an immediate, <rec> is a predicate for a record and <nor> is a + predicate for anything else. * TODO?: add something to indicate that x is a procedure to create/setter/getter/predicate of a record of that type @@ -61,6 +64,11 @@ Notes: - Most of the time I'm using eq? and eqv? as if they were equivalent. I assume that the differences are hidden by unspecified behavior. + - The result of predicate-union may be bigger than the actual union. + - The result of predicate-intersect is exact for now, but it may change in the future. + In that case it's necesary to ensure that the order of the arguments is correct + to make decreasing sequences of predicates. + |# @@ -69,6 +77,8 @@ Notes: (import (nanopass)) (include "base-lang.ss") (include "fxmap.ss") + (include "cptypes-lattice.ss") + (import cptypes-lattice) (define (prelex-counter x plxc) (or (prelex-operand x) @@ -78,12 +88,6 @@ Notes: c))) (with-output-language (Lsrc Expr) - (define void-rec `(quote ,(void))) - (define true-rec `(quote #t)) - (define false-rec `(quote #f)) - (define null-rec `(quote ())) - (define eof-rec `(quote #!eof)) - (define bwp-rec `(quote #!bwp)) (module (simple?) ; Simplified version copied from cp0. TODO: copy the rest. (define default-fuel 5) @@ -119,8 +123,13 @@ Notes: [(if ,e1 ,e2, e3) (and (sv? e2 fuel) (sv? e3 fuel))] + [(call ,preinfo ,e0 ,e* ...) + (guard (preinfo-call-single-valued? preinfo)) + #t] [(call ,preinfo ,pr ,e* ...) - (all-set? (prim-mask single-valued) (primref-flags pr))] + (let ([flags (primref-flags pr)]) + (or (all-set? (prim-mask abort-op) flags) + (all-set? (prim-mask single-valued) flags)))] [(call ,preinfo1 (case-lambda ,preinfo2 (clause (,x* ...) ,interface ,body)) ,e* ...) ; let-like expressions (guard (fx= interface (length e*))) (sv? body fuel)] @@ -222,6 +231,25 @@ Notes: ) ) + (define (unsafe-unreachable? ir) + (nanopass-case (Lsrc Expr) ir + [(call ,preinfo ,pr) + (guard (and (eq? (primref-name pr) 'assert-unreachable) + (all-set? (prim-mask unsafe) (primref-flags pr)))) + #t] + [else #f])) + + (define make-nontail + (lambda (ctxt e) + (case ctxt + [(value) + (if (single-valued? e) + e + `(call ,(make-preinfo-call) ,(lookup-primref 3 '$value) ,e))] + [else + ;; 'test and 'effect contexts cannot have an active attachment + e]))) + (define make-seq ; ensures that the right subtree of the output seq is not a seq if the ; last argument is similarly constrained, to facilitate result-exp @@ -230,7 +258,6 @@ Notes: (make-seq/no-drop ctxt (drop e1) e2)] [(ctxt e1 e2 e3) (make-seq ctxt (make-seq 'effect e1 e2) e3)])) - (define make-seq/no-drop ; like make-seq, but don't call drop on the not-last arguments to avoid @@ -240,7 +267,7 @@ Notes: (if (simple? e1) e2 (if (and (eq? ctxt 'effect) (simple? e2)) - e1 ; TODO: double check that it is not necessary to wrap e1 with $value + (make-nontail ctxt e1) (nanopass-case (Lsrc Expr) e2 [(seq ,e21 ,e22) `(seq (seq ,e1 ,e21) ,e22)] [else `(seq ,e1 ,e2)])))] @@ -287,22 +314,13 @@ Notes: (loop (car e*) (cdr e*)))))])) ) - (define-record-type pred-$record/rtd - (fields rtd) - (nongenerative #{pred-$record/rtd wnquzwrp8wl515lhz2url8sjc-0}) - (sealed #t)) - - (define-record-type pred-$record/ref - (fields ref) - (nongenerative #{pred-$record/ref zc0e8e4cs8scbwhdj7qpad6k3-0}) - (sealed #t)) - (module (pred-env-empty pred-env-bottom pred-env-add pred-env-remove/base pred-env-lookup pred-env-intersect/base pred-env-union/super-base pred-env-rebase - pred-intersect pred-union) + predicate-intersect predicate-union) (import fxmap) + (import cptypes-lattice) ; a fake fxmap that is full of 'bottom (define-record-type $bottom @@ -318,13 +336,13 @@ Notes: (define (pred-env-add/key types key pred) (cond [(and pred - (not (eq? pred 'ptr)) ; filter 'ptr to reduce the size + (not (predicate-is-ptr? pred)) ; filter 'ptr to reduce the size (not (eq? types bottom-fxmap))) (let ([old (fxmap-ref types key #f)]) (cond [(not old) (fxmap-set types key pred)] - [else (let ([new (pred-intersect old pred)]) + [else (let ([new (predicate-intersect old pred)]) (cond [(eq? new old) types] [(eq? new 'bottom) bottom-fxmap] @@ -366,6 +384,7 @@ Notes: (eq? from bottom-fxmap)) bottom-fxmap] [(fx> (fxmap-changes from) (fxmap-changes types)) + ;TODO: don't swap the order in case the result of predicate-intersect is not exact. (pred-env-intersect/base from types base)] [else (let ([ret types]) @@ -374,7 +393,7 @@ Notes: ;x-> from ;y-> base ;z-> types - (set! ret (pred-env-add/key ret key (pred-intersect x z))))) + (set! ret (pred-env-add/key ret key (predicate-intersect x z))))) (lambda (key x) (set! ret (pred-env-add/key ret key x))) (lambda (key x) @@ -383,18 +402,6 @@ Notes: base) ret)])) - (define (pred-intersect x y) - (cond - [(predicate-implies? x y) x] - [(predicate-implies? y x) y] - [(or (predicate-implies-not? x y) - (predicate-implies-not? y x)) - 'bottom] - [(or (and (eq? x 'boolean) (eq? y 'true)) - (and (eq? y 'boolean) (eq? x 'true))) - true-rec] - [else (or x y)])) ; if there is no exact option, at least keep the old value - ; This is conceptually the union of the types in `types` and `from` ; but since 'ptr is not stored to save space and time, the implementation ; looks like an intersection of the fxmaps. @@ -411,12 +418,12 @@ Notes: ;x-> from ;y-> base ;z-> types - (set! ret (pred-env-add/key ret key (pred-union x z))))) + (set! ret (pred-env-add/key ret key (predicate-union x z))))) (lambda (key x) (let ([z (fxmap-ref types key #f)]) ;x-> from ;z-> types - (set! ret (pred-env-add/key ret key (pred-union x z))))) + (set! ret (pred-env-add/key ret key (predicate-union x z))))) (lambda (key x) ($impoops 'pred-env-union/from "unexpected value ~s in base environment ~s" x base)) from @@ -453,19 +460,6 @@ Notes: ; temp is never bottom-fxmap here ($pred-env-union/from types types/b from temp))]))])) - (define (pred-union x y) - (cond - [(predicate-implies? y x) x] - [(predicate-implies? x y) y] - [(find (lambda (t) - (and (predicate-implies? x t) - (predicate-implies? y t))) - '(char null-or-pair $record - gensym uninterned-symbol interned-symbol symbol - fixnum bignum exact-integer flonum real number - boolean true ptr))] ; ensure they are order from more restrictive to less restrictive - [else #f])) - (define (pred-env-rebase types base new-base) (cond [(or (eq? types bottom-fxmap) @@ -536,6 +530,7 @@ Notes: [(#3%$record? d) '$record] ;check first to avoid double representation of rtd [(okay-to-copy? d) ir] [(and (integer? d) (exact? d)) 'exact-integer] + [(list? d) '$list-pair] ; quoted list should not be modified. [(pair? d) 'pair] [(box? d) 'box] [(vector? d) 'vector] @@ -554,20 +549,19 @@ Notes: (make-pred-$record/rtd d)] [(ref ,maybe-src ,x) (guard (not (prelex-assigned x))) - (make-pred-$record/ref x)] + (make-pred-$record/ref x #f)] + [(record-type ,rtd (ref ,maybe-src ,x)) + (guard (not (prelex-assigned x))) + (make-pred-$record/ref x rtd)] [(record-type ,rtd ,e) (rtd->record-predicate e extend?)] [else (if (not extend?) 'bottom '$record)])] [else (if (not extend?) 'bottom '$record)])) - ; when extend is #f the result is a predicate that recognizes less values - ; than the one in name. This is useful for reductions like - ; (pred? x) ==> #t and (something x) ==> (#3%something x) - ; when extend is #t the result is a predicate that recognizes more values - ; than the one in name. This is useful for reductions like - ; (pred? x) ==> #f and (something x) ==> <error> - ; in case the non extended version is not #f, the extended version must be not #f - (define (primref-name->predicate name extend?) + ; Recognize predicates and get the corresponding + ; type using the notation in primdata.ss + ; TODO: Move this info to primdata.ss + (define (primref-name->predicate name) (case name [pair? 'pair] [box? 'box] @@ -584,202 +578,32 @@ Notes: [flvector? 'flvector] [gensym? 'gensym] [uninterned-symbol? 'uninterned-symbol] - #;[interned-symbol? 'interned-symbol] [symbol? 'symbol] [char? 'char] [boolean? 'boolean] [procedure? 'procedure] - [not false-rec] - [null? null-rec] - [eof-object? eof-rec] - [bwp-object? bwp-rec] - [(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)] - [(integer? rational?) '(exact-integer . real)] - [(cflonum?) '(flonum . number)] - [else '(#f . #f)]))])) ; this is used only to detect predicates. - - (define (maybe-predicate? name) - (let ([name (symbol->string name)]) - (and (>= (string-length name) 6) - (let loop ([n 0]) - (or (fx= n 6) - (and (eq? (string-ref name n) - (string-ref "maybe-" n)) - (loop (fx+ n 1)))))))) - - ; nqm: no question mark - ; this is almost duplicated code, but with more cases - ; it's also useful to avoid the allocation - ; of the temporal strings to transform: vector -> vector? - (define (primref-name/nqm->predicate name extend?) - (case name - [pair 'pair] - [box 'box] - [$record '$record] - [fixnum 'fixnum] - [bignum 'bignum] - [flonum 'flonum] - [real 'real] - [number 'number] - [vector 'vector] - [string 'string] - [bytevector 'bytevector] - [fxvector 'fxvector] - [flvector 'flvector] - [gensym 'gensym] - [uninterned-symbol 'uninterned-symbol] - [interned-symbol 'interned-symbol] - [symbol 'symbol] - [char 'char] - [bottom 'bottom] ;pseudo-predicate - [ptr 'ptr] ;pseudo-predicate - [boolean 'boolean] - [true 'true] - [procedure 'procedure] - [exact-integer 'exact-integer] ;fake-predicate - [void void-rec] ;fake-predicate - [null null-rec] - [eof-object eof-rec] - [bwp-object bwp-rec] - [list (if (not extend?) null-rec 'null-or-pair)] ;fake-predicate - [else ((if extend? cdr car) - (case name - [(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)] - [(cflonum) '(flonum . number)] - [(sub-ptr) '(bottom . ptr)] - [else - (cond - [(not name) ; TODO: Move this case to the top? - '(#f . #f)] - [(pair? name) ; TODO: Move this case to the top? - (cond - [(equal? name '(ptr . ptr)) - '(pair . pair)] - [else - '(bottom . pair)])] - [(maybe-predicate? name) - '(bottom . ptr)] ; for types like maybe-* - [else - '(bottom . true)])]))])) ; for all other types that exclude #f + [not 'false] + [null? 'null] + [eof-object? 'eof-object] + [bwp-object? 'bwp-object] + [$immediate? '$immediate] + [list? 'list] + [list-assuming-immutable? 'list-assuming-immutable] + [record? 'record] + [record-type-descriptor? 'rtd] + [integer? 'integer] + [rational? 'rational] + [cflonum? 'cflonum] + [else #f])) ; this function is used only to detect predicates. (define (primref->predicate pr extend?) - (primref-name->predicate (primref-name pr) extend?)) + (primref-name/nqm->predicate (primref-name->predicate (primref-name pr)) extend?)) (define (check-constant-is? x pred?) - (nanopass-case (Lsrc Expr) x - [(quote ,d) (pred? d)] - [else #f])) - - ; strange properties of bottom here: - ; (implies? x bottom): only for x=bottom - ; (implies? bottom y): always - ; (implies-not? x bottom): never - ; (implies-not? bottom y): never - ; check (implies? x bottom) before (implies? x something) - (define (predicate-implies? x y) - (and x - y - (or (eq? x y) - (eq? x 'bottom) - (cond - [(Lsrc? y) - (and (Lsrc? x) - (nanopass-case (Lsrc Expr) y - [(quote ,d1) - (nanopass-case (Lsrc Expr) x - [(quote ,d2) (eqv? d1 d2)] - [else #f])] - [else #f]))] - [(pred-$record/rtd? y) - (and (pred-$record/rtd? x) - (let ([x-rtd (pred-$record/rtd-rtd x)] - [y-rtd (pred-$record/rtd-rtd y)]) - (cond - [(record-type-sealed? y-rtd) - (eqv? x-rtd y-rtd)] - [else - (let loop ([x-rtd x-rtd]) - (or (eqv? x-rtd y-rtd) - (let ([xp-rtd (record-type-parent x-rtd)]) - (and xp-rtd (loop xp-rtd)))))])))] - [(pred-$record/ref? y) - (and (pred-$record/ref? x) - (eq? (pred-$record/ref-ref x) - (pred-$record/ref-ref y)))] - [(case y - [(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) - (check-constant-is? x number?))] - [(gensym) (check-constant-is? x gensym?)] - [(uninterned-symbol) (check-constant-is? x uninterned-symbol?)] - [(interned-symbol) (check-constant-is? x (lambda (x) - (and (symbol? x) - (not (gensym? x)) - (not (uninterned-symbol? x)))))] - [(symbol) (or (eq? x 'gensym) - (eq? x 'uninterned-symbol) - (eq? x 'interned-symbol) - (check-constant-is? x symbol?))] - [(char) (check-constant-is? x char?)] - [(boolean) (check-constant-is? x boolean?)] - [(true) (and (not (check-constant-is? x not)) - (not (eq? x 'boolean)) - (not (eq? x 'ptr)))] ; only false-rec, boolean and ptr may be `#f - [($record) (or (pred-$record/rtd? x) - (pred-$record/ref? x) - (check-constant-is? x #3%$record?))] - [(vector) (check-constant-is? x vector?)] ; i.e. '#() - [(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])))) - - (define (predicate-implies-not? x y) - (and x - y - ; a pred-$record/ref may be any other kind or record - (not (and (pred-$record/ref? x) - (predicate-implies? y '$record))) - (not (and (pred-$record/ref? y) - (predicate-implies? x '$record))) - ; boolean and true may be a #t - (not (and (eq? x 'boolean) - (eq? y 'true))) - (not (and (eq? y 'boolean) - (eq? x 'true))) - ; the other types are included or disjoint - (not (predicate-implies? x y)) - (not (predicate-implies? y x)))) + (and (Lsrc? x) + (nanopass-case (Lsrc Expr) x + [(quote ,d) (pred? d)] + [else #f]))) (define (primref->result-predicate pr arity) (define parameterlike? box?) @@ -790,8 +614,8 @@ Notes: [(parameterlike? type) (cond [(not arity) ; unknown - (pred-union void-rec - (primref-name/nqm->predicate (parameterlike-type type) #t))] + (predicate-union void-rec + (primref-name/nqm->predicate (parameterlike-type type) #t))] [(fx= arity 0) (primref-name/nqm->predicate (parameterlike-type type) #t)] [else @@ -822,6 +646,12 @@ Notes: (define (primref->unsafe-primref pr) (lookup-primref 3 (primref-name pr))) + (define (non-literal-fixmediate? e x) + (and (not (check-constant-is? e (lambda (e) #t))) + (predicate-implies? x $fixmediate-pred))) + + (define (unwrapped-error ctxt e) + (values (make-nontail ctxt e) 'bottom pred-env-bottom #f #f)) (module () (with-output-language (Lsrc Expr) @@ -996,12 +826,45 @@ Notes: [(_ id) (or (lookup #'id #'get-type-key) ($oops 'get-type "invalid identifier ~s" #'id))]))) + (define (try-compare-constants e1 e2 prim-name) + ; yes => true-rec + ; no => false-rec + ; unknown => #f + (and (Lsrc? e1) + (Lsrc? e2) + (nanopass-case (Lsrc Expr) e1 + [(quote ,d1) + (nanopass-case (Lsrc Expr) e2 + [(quote ,d2) + (cond + [(eqv? d1 d2) + (cond + [(eq? prim-name 'eq?) + (cond + [(or (not (number? d1)) + ; To avoid problems with cross compilation and eq?-ness + ; ensure that it's a fixnum in both machines. + (and (fixnum? d1) + (target-fixnum? d1))) + true-rec] + [else + #f])] + [else + true-rec])] + [else + false-rec])] + [else #f])] + [else #f]))) + (define-specialize 2 (eq? eqv?) [(e1 e2) (let ([r1 (get-type e1)] [r2 (get-type e2)]) (cond - [(or (predicate-implies-not? r1 r2) - (predicate-implies-not? r2 r1)) + [(try-compare-constants r1 r2 prim-name) + => (lambda (ret) + (values (make-seq ctxt e1 e2 ret) + ret ntypes #f #f))] + [(predicate-disjoint? r2 r1) (values (make-seq ctxt e1 e2 false-rec) false-rec ntypes #f #f)] [else @@ -1018,22 +881,67 @@ Notes: [() (values null-rec null-rec ntypes #f #f)] ; should have been reduced by cp0 [e* (values `(call ,preinfo ,pr ,e* ...) 'pair ntypes #f #f)]) + (define-specialize 2 cdr + [(v) (values `(call ,preinfo ,pr ,v) + (cond + [(predicate-implies? ret 'bottom) + ret] + [(predicate-implies? (predicate-intersect (get-type v) 'pair) '$list-pair) + $list-pred] + [else + ptr-pred]) + ntypes #f #f)]) + (define-specialize 2 $record [(rtd . e*) (values `(call ,preinfo ,pr ,rtd ,e* ...) (rtd->record-predicate rtd #t) ntypes #f #f)]) - (define-specialize 2 (record? $sealed-record?) - [(val rtd) (let* ([val-type (get-type val)] + (let () + (define-syntax define-set-immediate + (syntax-rules () + [(_ set (args ... val)) + (define-set-immediate set (args ... val) void-rec)] + [(_ set (args ... val) ret) + (define-specialize 2 set + [(args ... val) (values `(call ,preinfo ,pr + ,args ... + ,(if (non-literal-fixmediate? val (get-type val)) + `(call ,(make-preinfo-call) + ,(lookup-primref 3 '$fixmediate) + ,val) + val)) + ret ntypes #f #f)])])) + (define-set-immediate $record-set! (rec i val)) + (define-set-immediate $record-cas! (rec i old new) 'boolean) + (define-set-immediate vector-set! (vec i val)) + (define-set-immediate vector-cas! (vec i old new) 'boolean) + (define-set-immediate set-box! (b val)) + (define-set-immediate box-cas! (b old new) 'boolean) + (define-set-immediate set-car! (p val)) + (define-set-immediate set-cdr! (p val))) + + (define-specialize 2 (record? $sealed-record? record-instance? $sealed-record-instance?) + [(val rtd) (let* ([alt-if-record (case (primref-name pr) + [record? 'record-instance?] + [$sealed-record? '$sealed-record-instance?] + [else #f])] + [val-type (get-type val)] [to-unsafe (and (fx= level 2) - (expr-is-rtd? rtd oldtypes))] ; use the old types + (expr-is-rtd? rtd oldtypes) ; use the old types + (or alt-if-record + (predicate-implies? val-type '$record)))] [level (if to-unsafe 3 level)] [pr (if to-unsafe (primref->unsafe-primref pr) + pr)] + [pr (if (and alt-if-record + (predicate-implies? val-type '$record)) + (lookup-primref (primref-level pr) alt-if-record) pr)]) (cond [(predicate-implies? val-type (rtd->record-predicate rtd #f)) (values (make-seq ctxt val rtd true-rec) true-rec ntypes #f #f)] - [(predicate-implies-not? val-type (rtd->record-predicate rtd #t)) + [(predicate-disjoint? val-type (rtd->record-predicate rtd #t)) (cond [(fx= level 3) (let ([rtd (ensure-single-value rtd (get-type rtd))]) ; ensure that rtd is a single valued expression @@ -1111,7 +1019,7 @@ Notes: (define-specialize 2 atan [(n) (let ([r (get-type n)]) (cond - [(predicate-implies-not? r 'number) + [(predicate-disjoint? r 'number) (values `(call ,preinfo ,pr ,n) 'bottom pred-env-bottom #f #f)] [else @@ -1120,8 +1028,8 @@ Notes: [(x y) (let ([rx (get-type x)] [ry (get-type y)]) (cond - [(or (predicate-implies-not? rx 'real) - (predicate-implies-not? ry 'real)) + [(or (predicate-disjoint? rx 'real) + (predicate-disjoint? ry 'real)) (values `(call ,preinfo ,pr ,x ,y) 'bottom pred-env-bottom #f #f)] [else @@ -1136,33 +1044,33 @@ Notes: [ir `(call ,preinfo ,pr ,n)]) (cond [(predicate-implies? r 'char) - (values ir 'ptr ntypes #f #f)] ; should be maybe-symbol + (values ir maybe-symbol-pred ntypes #f #f)] [(predicate-implies? r 'symbol) - (values ir 'ptr ntypes #f #f)] ; should be maybe-char - [(and (predicate-implies-not? r 'char) - (predicate-implies-not? r 'symbol)) + (values ir maybe-char-pred ntypes #f #f)] + [(and (predicate-disjoint? r 'char) + (predicate-disjoint? r 'symbol)) (values ir 'bottom pred-env-bottom #f #f)] [else - (values ir 'ptr ; should be maybe-(union 'char 'symbol) - (pred-env-add/ref ntypes n 'true plxc) #f #f)]))] ; should be (union 'char 'symbol) + (values ir (predicate-union maybe-char-pred 'symbol) + (pred-env-add/ref ntypes n (predicate-union 'char 'symbol) plxc) #f #f)]))] [(n c) (let ([rn (get-type n)] [rc (get-type c)] [ir `(call ,preinfo ,pr ,n ,c)]) (cond - [(or (predicate-implies-not? rn 'symbol) - (predicate-implies-not? rc 'ptr)) ; should be maybe-char + [(or (predicate-disjoint? rn 'symbol) + (predicate-disjoint? rc maybe-char-pred)) (values ir 'bottom pred-env-bottom #f #f)] [else (values ir void-rec (pred-env-add/ref (pred-env-add/ref ntypes n 'symbol plxc) - c 'ptr plxc) ; should be maybe-char + c maybe-char-pred plxc) #f #f)]))]) (define-specialize/unrestricted 2 call-with-values - [(e1 e2) (let-values ([(e1 ret1 types1 t-types1 f-types1) + [(e1 e2) (let-values ([(e1 ret1 types1 t-types1 f-types1 bottom1?) (Expr/call e1 'value oldtypes oldtypes plxc)]) - (let-values ([(e2 ret2 types2 t-types2 f-types2) + (let-values ([(e2 ret2 types2 t-types2 f-types2 bottom2?) (Expr/call e2 ctxt types1 oldtypes plxc)]) (values `(call ,preinfo ,pr ,e1 ,e2) (if (predicate-implies? ret1 'bottom) ; check if necesary @@ -1172,45 +1080,77 @@ Notes: (define-specialize/unrestricted 2 apply [(proc . e*) (let-values ([(e* r* t* t-t* f-t*) - (map-values 5 (lambda (e) (Expr/main e 'value oldtypes plxc)) e*)]) - (let ([mtypes (fold-left (lambda (f t) (pred-env-intersect/base f t oldtypes)) oldtypes t*)]) - (let-values ([(proc retproc typesproc t-typesproc f-typesproc) - (Expr/call proc ctxt mtypes oldtypes plxc)]) - (values `(call ,preinfo ,pr ,proc ,e* ...) - retproc typesproc t-typesproc f-typesproc))))]) - + (map-values 5 (lambda (e) (Expr e 'value oldtypes plxc)) e*)]) + (cond + [(ormap (lambda (e r) (and (predicate-implies? r 'bottom) e)) e* r*) + => (lambda (e) (unwrapped-error ctxt e))] + [else + (let ([mtypes (fold-left (lambda (f t) (pred-env-intersect/base f t oldtypes)) oldtypes t*)]) + (let-values ([(proc retproc typesproc t-typesproc f-typesproc proc-bottom?) + (Expr/call proc ctxt mtypes oldtypes plxc)]) + (cond + [proc-bottom? (unwrapped-error ctxt proc)] + [else + (values `(call ,preinfo ,pr ,proc ,e* ...) + retproc typesproc t-typesproc f-typesproc)])))]))]) + (define-specialize/unrestricted 2 $apply [(proc n args) (let*-values ([(n rn tn t-tn f-tn) - (Expr/main n 'value oldtypes plxc)] + (Expr n 'value oldtypes plxc)] [(args rargs targs t-targs f-targs) - (Expr/main args 'value oldtypes plxc)]) + (Expr args 'value oldtypes plxc)]) (let* ([predn (primref->argument-predicate pr 1 3 #t)] - [tn (if (predicate-implies-not? rn predn) + [tn (if (predicate-disjoint? rn predn) 'bottom tn)] [tn (pred-env-add/ref tn n predn plxc)] [predargs (primref->argument-predicate pr 2 3 #t)] - [targs (if (predicate-implies-not? rargs predargs) + [targs (if (predicate-disjoint? rargs predargs) 'bottom targs)] [targs (pred-env-add/ref targs args predargs plxc)] [mtypes (pred-env-intersect/base tn targs oldtypes)]) - (let-values ([(proc retproc typesproc t-typesproc f-typesproc) + (let-values ([(proc retproc typesproc t-typesproc f-typesproc proc-bottom?) (Expr/call proc ctxt mtypes oldtypes plxc)]) (values `(call ,preinfo ,pr ,proc ,n ,args) retproc typesproc t-typesproc f-typesproc))))]) (let () + (define (handle-call-attachment preinfo pr e1 e2 ctxt oldtypes plxc body-ctxt) + (let-values ([(e1 ret1 types1 t-types1 f-types1) + (Expr e1 'value oldtypes plxc)]) + (cond + [(predicate-implies? ret1 'bottom) (unwrapped-error ctxt e1)] + [else + (let-values ([(e2 ret2 types2 t-types2 f-types2 bottom2?) + (Expr/call e2 body-ctxt types1 oldtypes plxc)]) + (values `(call ,preinfo ,pr ,e1 ,e2) + (if (predicate-implies? ret1 'bottom) ; check if necesary + 'bottom + ret2) + types2 t-types2 f-types2))]))) + + (define-specialize/unrestricted 2 call-setting-continuation-attachment + ;; body is in 'value context, because called with a mark + [(e1 e2) (handle-call-attachment preinfo pr e1 e2 ctxt oldtypes plxc 'value)]) + + (define-specialize/unrestricted 2 call-getting-continuation-attachment + [(e1 e2) (handle-call-attachment preinfo pr e1 e2 ctxt oldtypes plxc ctxt)]) + + (define-specialize/unrestricted 2 call-consuming-continuation-attachment + [(e1 e2) (handle-call-attachment preinfo pr e1 e2 ctxt oldtypes plxc ctxt)])) + + (let () (define (handle-dynamic-wind critical? in body out ctxt oldtypes plxc) (let*-values ([(critical? rcritical? tcritical? t-tcritical? f-tcritical?) (if critical? - (Expr/main critical? 'value oldtypes plxc) + (Expr critical? 'value oldtypes plxc) (values #f #f oldtypes #f #f))] - [(ìn rin tin t-tin f-tin) + [(ìn rin tin t-tin f-tin in-bottom?) (Expr/call in 'value tcritical? oldtypes plxc)] - [(body rbody tbody t-tbody f-tbody) + [(body rbody tbody t-tbody f-tbody body-bottom?) (Expr/call body 'value tin oldtypes plxc)] ; it's almost possible to use ctxt instead of 'value here - [(out rout tout t-tout f-tout) + [(out rout tout t-tout f-tout out-bottom?) (Expr/call out 'value tin oldtypes plxc)]) ; use tin instead of tbody in case of error or jump. (let* ([n-types (pred-env-intersect/base tbody tout tin)] [t-types (and (eq? ctxt 'test) @@ -1250,7 +1190,7 @@ Notes: [(predicate-implies? val-type (primref->predicate pr #f)) (values (make-seq ctxt val true-rec) true-rec ntypes #f #f)] - [(predicate-implies-not? val-type (primref->predicate pr #t)) + [(predicate-disjoint? val-type (primref->predicate pr #t)) (values (make-seq ctxt val false-rec) false-rec ntypes #f #f)] [else @@ -1284,35 +1224,39 @@ 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* ([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 len #t)]) - (loop (cdr e*) - (cdr r*) - (fx+ n 1) - (if (predicate-implies-not? (car r*) pred) - 'bottom - ret) - (pred-env-add/ref t (car e*) pred plxc)))))]) - (cond - [(or (predicate-implies? ret 'bottom) - (not (arity-okay? (primref-arity pr) (length e*)))) - (fold-primref/default preinfo pr e* 'bottom r* ctxt pred-env-bottom oldtypes plxc)] - [else - (let* ([to-unsafe (and (not (all-set? (prim-mask unsafe) (primref-flags pr))) - (all-set? (prim-mask safeongoodargs) (primref-flags pr)) - (andmap (lambda (r n) - (predicate-implies? r - (primref->argument-predicate pr n (length e*) #f))) - r* (enumerate r*)))] - [pr (if to-unsafe - (primref->unsafe-primref pr) - pr)]) - (fold-primref/normal preinfo pr e* ret r* ctxt t oldtypes plxc))]))))) + (cond + [(ormap (lambda (e r) (and (predicate-implies? r 'bottom) e)) e* r*) + => (lambda (e) (unwrapped-error ctxt e))] + [else + (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 len #t)]) + (loop (cdr e*) + (cdr r*) + (fx+ n 1) + (if (predicate-disjoint? (car r*) pred) + 'bottom + ret) + (pred-env-add/ref t (car e*) pred plxc)))))]) + (cond + [(or (predicate-implies? ret 'bottom) + (not (arity-okay? (primref-arity pr) (length e*)))) + (fold-primref/default preinfo pr e* 'bottom r* ctxt pred-env-bottom oldtypes plxc)] + [else + (let* ([to-unsafe (and (not (all-set? (prim-mask unsafe) (primref-flags pr))) + (all-set? (prim-mask safeongoodargs) (primref-flags pr)) + (andmap (lambda (r n) + (predicate-implies? r + (primref->argument-predicate pr n (length e*) #f))) + r* (enumerate r*)))] + [pr (if to-unsafe + (primref->unsafe-primref pr) + pr)]) + (fold-primref/normal preinfo pr e* ret r* ctxt t oldtypes plxc))])))]))) (define (fold-primref/normal preinfo pr e* ret r* ctxt ntypes oldtypes plxc) (cond @@ -1342,14 +1286,14 @@ Notes: (define (finish preinfo preinfo2 x* interface body e* r* ntypes) (let ([ntypes/x (fold-left (lambda (t x p) (pred-env-add t x p plxc)) ntypes x* r*)]) (let*-values ([(body ret n-types/x t-types/x f-types/x) - (Expr/main body ctxt ntypes/x plxc)] + (Expr body ctxt ntypes/x plxc)] [(n-types t-types f-types) (pred-env-triple-filter/base n-types/x t-types/x f-types/x x* ctxt ntypes plxc)]) (values `(call ,preinfo (case-lambda ,preinfo2 (clause (,x* ...) ,interface ,body)) ,e* ...) ret n-types t-types f-types)))) (define (bad-arity preinfo e0 e* ctxt ntypes) (let*-values ([(e0 ret0 n-types0 t-types0 f-types0) - (Expr/main e0 'value ntypes plxc)]) + (Expr e0 'value ntypes plxc)]) (values `(call ,preinfo ,e0 ,e* ...) 'bottom pred-env-bottom #f #f))) (define (cut-r* r* n) @@ -1359,26 +1303,30 @@ Notes: (cons (car r*) (loop (fx- i 1) (cdr r*)))))) (let*-values ([(ntypes e* r* t* t-t* f-t*) (map-Expr/delayed e* oldtypes plxc)]) - (nanopass-case (Lsrc Expr) e0 - [(case-lambda ,preinfo2 (clause (,x** ...) ,interface* ,body*) ...) - (let ([len (length e*)]) - (let loop ([x** x**] [interface* interface*] [body* body*]) - (cond - [(null? interface*) - (bad-arity preinfo e0 e* ctxt ntypes)] - [else - (let ([interface (car interface*)]) - (cond - [(fx< interface 0) - (let ([nfixed (fxlognot interface)]) - (if (fx>= len nfixed) - (let ([r* (cut-r* r* nfixed)]) - (finish preinfo preinfo2 (car x**) interface (car body*) e* r* ntypes)) - (loop (cdr x**) (cdr interface*) (cdr body*))))] - [else - (if (fx= interface len) - (finish preinfo preinfo2 (car x**) interface (car body*) e* r* ntypes) - (loop (cdr x**) (cdr interface*) (cdr body*)))]))])))]))) + (cond + [(ormap (lambda (e r) (and (predicate-implies? r 'bottom) e)) e* r*) + => (lambda (e) (unwrapped-error ctxt e))] + [else + (nanopass-case (Lsrc Expr) e0 + [(case-lambda ,preinfo2 (clause (,x** ...) ,interface* ,body*) ...) + (let ([len (length e*)]) + (let loop ([x** x**] [interface* interface*] [body* body*]) + (cond + [(null? interface*) + (bad-arity preinfo e0 e* ctxt ntypes)] + [else + (let ([interface (car interface*)]) + (cond + [(fx< interface 0) + (let ([nfixed (fxlognot interface)]) + (if (fx>= len nfixed) + (let ([r* (cut-r* r* nfixed)]) + (finish preinfo preinfo2 (car x**) interface (car body*) e* r* ntypes)) + (loop (cdr x**) (cdr interface*) (cdr body*))))] + [else + (if (fx= interface len) + (finish preinfo preinfo2 (car x**) interface (car body*) e* r* ntypes) + (loop (cdr x**) (cdr interface*) (cdr body*)))]))])))])]))) (define (pred-env-triple-filter/base ntypes ttypes ftypes x* ctxt base plxc) (let* ([ttypes (and (not (eq? ntypes ttypes)) ttypes)] @@ -1396,10 +1344,15 @@ Notes: (define (fold-call/other preinfo e0 e* ctxt oldtypes plxc) (let*-values ([(ntypes e* r* t* t-t* f-t*) (map-Expr/delayed e* oldtypes plxc)] - [(e0 ret0 types0 t-types0 f-types0) + [(e0 ret0 types0 t-types0 f-types0 e0-bottom?) (Expr/call e0 'value ntypes oldtypes plxc)]) - (values `(call ,preinfo ,e0 ,e* ...) - (if (preinfo-call-no-return? preinfo) 'bottom ret0) types0 t-types0 f-types0))) + (cond + [(or (and e0-bottom? e0) + (ormap (lambda (e r) (and (predicate-implies? r 'bottom) e)) e* r*)) + => (lambda (e) (unwrapped-error ctxt e))] + [else + (values `(call ,preinfo ,e0 ,e* ...) + (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) @@ -1409,7 +1362,7 @@ Notes: [else (cons 'ready (call-with-values - (lambda () (Expr/main e 'value oldtypes plxc)) + (lambda () (Expr e 'value oldtypes plxc)) list))])) e*)) (define fp-types (fold-left (lambda (t x) @@ -1422,7 +1375,7 @@ Notes: (cond [(eq? (car e) 'delayed) (call-with-values - (lambda () (Expr/main (cdr e) 'value fp-types plxc)) + (lambda () (Expr (cdr e) 'value fp-types plxc)) list)] [else (cdr e)])) @@ -1448,19 +1401,19 @@ Notes: (define (Expr/fix-tf-types ir ctxt types plxc) (let-values ([(ir ret types t-types f-types) - (Expr/main ir ctxt types plxc)]) + (Expr ir ctxt types plxc)]) (values ir ret types (if (predicate-implies? ret false-rec) pred-env-bottom (or t-types types)) - (if (predicate-implies? ret 'true) + (if (predicate-implies? ret true-pred) pred-env-bottom (or f-types types))))) (define (Expr/call ir ctxt types outtypes plxc) ; TODO: Add arity (nanopass-case (Lsrc Expr) ir - [,pr (values pr (primref->result-predicate pr #f) types #f #f)] + [,pr (values pr (primref->result-predicate pr #f) types #f #f #f)] [(case-lambda ,preinfo ,cl* ...) (let loop ([cl* cl*] [rev-rcl* '()] @@ -1472,12 +1425,12 @@ Notes: [(null? cl*) (let ([retcl* (reverse rev-rcl*)]) (values `(case-lambda ,preinfo ,retcl* ...) - rret rtypes rt-types rf-types))] + rret rtypes rt-types rf-types #f))] [else (nanopass-case (Lsrc CaseLambdaClause) (car cl*) [(clause (,x* ...) ,interface ,body) (let-values ([(body ret2 types2 t-types2 f-types2) - (Expr/main body ctxt types plxc)]) + (Expr body ctxt types plxc)]) (let* ([cl2 (with-output-language (Lsrc CaseLambdaClause) `(clause (,x* ...) ,interface ,body))] [t-types2 (or t-types2 types2)] @@ -1497,7 +1450,7 @@ Notes: types)]) (loop (cdr cl*) (cons cl2 rev-rcl*) - (pred-union rret ret2) + (predicate-union rret ret2) ntypes (cond [(not (eq? ctxt 'test)) @@ -1523,14 +1476,14 @@ Notes: ntypes)])))])))])]))] [else (let-values ([(ir ret n-types t-types f-types) - (Expr/main ir 'value outtypes plxc)]) + (Expr ir 'value outtypes plxc)]) (values ir - (if (predicate-implies-not? ret 'procedure) + (if (predicate-disjoint? ret 'procedure) 'bottom #f) (pred-env-add/ref (pred-env-intersect/base n-types types outtypes) ir 'procedure plxc) - #f #f))])) + #f #f (predicate-implies? ret 'bottom)))])) ) (define-pass cptypes : Lsrc (ir ctxt types plxc) -> Lsrc (ret types t-types f-types) @@ -1542,14 +1495,14 @@ Notes: [(test) (let ([t (pred-env-lookup types x plxc)]) (cond - [(predicate-implies? t 'true) + [(predicate-implies? t true-pred) (values true-rec true-rec types #f #f)] [(predicate-implies? t false-rec) (values false-rec false-rec types #f #f)] [else (values ir t types - (pred-env-add/ref types ir 'true plxc) ; don't confuse it with true-rec + (pred-env-add/ref types ir true-pred plxc) ; don't confuse it with true-rec (pred-env-add/ref types ir false-rec plxc))]))] [else (let ([t (pred-env-lookup types x plxc)]) @@ -1557,30 +1510,35 @@ Notes: [(Lsrc? t) (nanopass-case (Lsrc Expr) t [(quote ,d) + (guard (or (not (number? d)) + ; To avoid problems with cross compilation and eq?-ness + ; ensure that it's a fixnum in both machines. + (and (fixnum? d) + (target-fixnum? d)))) (values t t types #f #f)] [else (values ir t types #f #f)])] [else - (values ir (or t 'ptr) types #f #f)]))])] ; In case there is no saved type, use 'ptr to mark it as single valued + (values ir (or t ptr-pred) types #f #f)]))])] ; In case there is no saved type, use ptr-pred to mark it as single valued [(seq ,[e1 'effect types plxc -> e1 ret1 types t-types f-types] ,e2) (cond [(predicate-implies? ret1 'bottom) - (values e1 'bottom pred-env-bottom #f #f)] + (unwrapped-error ctxt e1)] [else (let-values ([(e2 ret types t-types f-types) - (Expr/main e2 ctxt types plxc)]) + (Expr e2 ctxt types plxc)]) (values (make-seq/no-drop ctxt e1 e2) ret types t-types f-types))])] [(if ,[Expr/fix-tf-types : e1 'test types plxc -> e1 ret1 types1 t-types1 f-types1] ,e2 ,e3) (cond [(predicate-implies? ret1 'bottom) ;check bottom first - (values e1 'bottom pred-env-bottom #f #f)] - [(predicate-implies? ret1 'true) + (unwrapped-error ctxt e1)] + [(predicate-implies? ret1 true-pred) (let-values ([(e2 ret types t-types f-types) - (Expr/main e2 ctxt types1 plxc)]) + (Expr e2 ctxt types1 plxc)]) (values (make-seq ctxt e1 e2) ret types t-types f-types))] [(predicate-implies? ret1 false-rec) (let-values ([(e3 ret types t-types f-types) - (Expr/main e3 ctxt types1 plxc)]) + (Expr e3 ctxt types1 plxc)]) (values (make-seq ctxt e1 e3) ret types t-types f-types))] [else (let-values ([(e2 ret2 types2 t-types2 f-types2) @@ -1593,10 +1551,14 @@ Notes: (predicate-implies? ret3 'bottom)) ;check bottom first (values ir 'bottom pred-env-bottom #f #f)] [(predicate-implies? ret2 'bottom) ;check bottom first - (values (make-seq ctxt `(if ,e1 ,e2 ,void-rec) e3) + (values (if (unsafe-unreachable? e2) + (make-seq ctxt e1 e3) + (make-seq ctxt `(if ,e1 ,e2 ,void-rec) e3)) ret3 types3 t-types3 f-types3)] [(predicate-implies? ret3 'bottom) ;check bottom first - (values (make-seq ctxt `(if ,e1 ,void-rec ,e3) e2) + (values (if (unsafe-unreachable? e3) + (make-seq ctxt e1 e2) + (make-seq ctxt `(if ,e1 ,void-rec ,e3) e2)) ret2 types2 t-types2 f-types2)] [else (let ([new-types (pred-env-union/super-base types2 t-types1 @@ -1604,7 +1566,7 @@ Notes: types1 types1)]) (values ir - (pred-union ret2 ret3) + (predicate-union ret2 ret3) new-types (cond [(not (eq? ctxt 'test)) @@ -1629,7 +1591,14 @@ Notes: types1 new-types)])))])))])] [(set! ,maybe-src ,x ,[e 'value types plxc -> e ret types t-types f-types]) - (values `(set! ,maybe-src ,x ,e) void-rec types #f #f)] + (cond + [(predicate-implies? ret 'bottom) + (unwrapped-error ctxt e)] + [else + (values `(set! ,maybe-src ,x ,(if (non-literal-fixmediate? e ret) + `(call ,(make-preinfo-call) ,(lookup-primref 3 '$fixmediate) ,e) + e)) + void-rec types #f #f)])] [(call ,preinfo ,pr ,e* ...) (fold-call/primref preinfo pr e* ctxt types plxc)] [(case-lambda ,preinfo ,cl* ...) @@ -1637,7 +1606,7 @@ Notes: (nanopass-case (Lsrc CaseLambdaClause) cl [(clause (,x* ...) ,interface ,body) (let-values ([(body ret types t-types f-types) - (Expr/main body 'value types plxc)]) + (Expr body 'value types plxc)]) (for-each (lambda (x) (prelex-operand-set! x #f)) x*) (with-output-language (Lsrc CaseLambdaClause) `(clause (,x* ...) ,interface ,body)))])) @@ -1652,7 +1621,7 @@ Notes: (map-Expr/delayed e* types plxc)]) (let ([ntypes/x (fold-left (lambda (t x p) (pred-env-add t x p plxc)) ntypes x* r*)]) (let*-values ([(body ret n-types/x t-types/x f-types/x) - (Expr/main body ctxt ntypes/x plxc)] + (Expr body ctxt ntypes/x plxc)] [(n-types t-types f-types) (pred-env-triple-filter/base n-types/x t-types/x f-types/x x* ctxt ntypes plxc)]) (values `(letrec ([,x* ,e*] ...) ,body) @@ -1663,11 +1632,11 @@ Notes: (if (null? x*) (values (reverse rev-e*) types) (let-values ([(e ret types t-types f-types) - (Expr/main (car e*) 'value types plxc)]) + (Expr (car e*) 'value types plxc)]) (let ([types (pred-env-add types (car x*) ret plxc)]) (loop (cdr x*) (cdr e*) types (cons e rev-e*))))))] [(body ret n-types/x t-types/x f-types/x) - (Expr/main body ctxt ntypes/x plxc)] + (Expr body ctxt ntypes/x plxc)] [(n-types t-types f-types) (pred-env-triple-filter/base n-types/x t-types/x f-types/x x* ctxt types plxc)]) (values `(letrec* ([,x* ,e*] ...) ,body) @@ -1695,7 +1664,14 @@ Notes: #f #f)] [(record-set! ,rtd ,type ,index ,[e1 'value types plxc -> e1 ret1 types1 t-types1 f-types1] ,[e2 'value types plxc -> e2 ret2 types2 t-types2 f-types2]) - (values `(record-set! ,rtd ,type ,index ,e1 ,e2) + (values `(record-set! ,rtd ,type ,index ,e1 + ,(cond + [(and (eq? type 'scheme-object) + (non-literal-fixmediate? e2 ret2)) + `(call ,(make-preinfo-call) + ,(lookup-primref 3 '$fixmediate) + ,e2)] + [else e2])) void-rec (pred-env-add/ref (pred-env-intersect/base types1 types2 types) e1 '$record plxc) @@ -1709,7 +1685,7 @@ Notes: [(immutable-list (,[e* 'value types plxc -> e* r* t* t-t* f-t*] ...) ,[e 'value types plxc -> e ret types t-types f-types]) (values `(immutable-list (,e* ...) ,e) - ret types #f #f)] + (if (null? e*) null-rec '$list-pair) types #f #f)] [(moi) (values ir #f types #f #f)] [(pariah) (values ir void-rec types #f #f)] [(cte-optimization-loc ,box ,[e 'value types plxc -> e ret types t-types f-types] ,exts) @@ -1726,12 +1702,12 @@ Notes: ; friendly name to use in other internal functions ; so it is similar to Expr/call and Expr/fix-tf-types - (define Expr/main cptypes) + (define Expr cptypes) ; external version of cptypes: Lsrc -> Lsrc (define (Scptypes ir) (let-values ([(ir ret types t-types f-types) - (Expr/main ir 'value pred-env-empty (box 0))]) + (Expr ir 'value pred-env-empty (box 0))]) ir)) (set! $cptypes Scptypes) diff --git a/src/ChezScheme/s/fasl.ss b/src/ChezScheme/s/fasl.ss index b56b6d0222..3f0ffe2c10 100644 --- a/src/ChezScheme/s/fasl.ss +++ b/src/ChezScheme/s/fasl.ss @@ -500,6 +500,11 @@ [(record-type-descriptor? x) (put-u8 p (constant fasl-type-rtd)) (wrf (record-type-uid x) p t a?) + (unless (eq? x (let ([a (rtd-ancestors x)]) + (vector-ref a (sub1 (vector-length a))))) + (error 'fasl "mismatch")) + (unless (eq-hashtable-ref (table-hash t) x #f) + (error 'fasl "not in table!?")) (if (and a? (fxlogtest a? (constant fasl-omit-rtds))) (put-uptr p 0) ; => must be registered already at load time (wrf-fields (maybe-remake-rtd x) p t a?))] @@ -677,7 +682,7 @@ (module (start) (define start - (lambda (p t situation x proc) + (lambda (p t situation x a? proc) (shift-externals! t) (dump-graph) (let-values ([(bv* size) @@ -693,7 +698,7 @@ (for-each (lambda (x) (if (eq? 'begin (cdr (eq-hashtable-ref (table-hash t) x #f))) (proc x p) - (wrf x p t (constant annotation-all)))) + (wrf x p t a?))) begins))) (proc x p) (extractor))]) @@ -733,7 +738,7 @@ (constant fasl-omit-rtds) 0))]) (bld x t a? 0) - (start p t (constant fasl-type-visit-revisit) x (lambda (x p) (wrf x p t a?)))))) + (start p t (constant fasl-type-visit-revisit) x a? (lambda (x p) (wrf x p t a?)))))) (define-who fasl-write (case-lambda @@ -775,7 +780,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) x (lambda (x p) (wrf-graph x p t #f really-wrf-record)))))) + (start p t (constant fasl-type-visit-revisit) x #f (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)) ) @@ -789,7 +794,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 x proc) ((target-fasl-start (fasl-target)) p t situation x proc))) + (set! $fasl-start (lambda (p t situation x a? proc) ((target-fasl-start (fasl-target)) p t situation x a? 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/i3fb.def b/src/ChezScheme/s/i3fb.def deleted file mode 100644 index 8f11c4db46..0000000000 --- a/src/ChezScheme/s/i3fb.def +++ /dev/null @@ -1,19 +0,0 @@ -;;; i3fb.def -;;; 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. - -(define-constant machine-type (constant machine-type-i3fb)) -(features iconv expeditor) -(include "i3.def") -(include "default.def") diff --git a/src/ChezScheme/s/i3le.def b/src/ChezScheme/s/i3le.def deleted file mode 100644 index 7b77ecc303..0000000000 --- a/src/ChezScheme/s/i3le.def +++ /dev/null @@ -1,19 +0,0 @@ -;;; i3le.def -;;; 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. - -(define-constant machine-type (constant machine-type-i3le)) -(features iconv expeditor) -(include "i3.def") -(include "default.def") diff --git a/src/ChezScheme/s/i3nb.def b/src/ChezScheme/s/i3nb.def deleted file mode 100644 index ae10180ed8..0000000000 --- a/src/ChezScheme/s/i3nb.def +++ /dev/null @@ -1,19 +0,0 @@ -;;; i3nb.def -;;; 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. - -(define-constant machine-type (constant machine-type-i3nb)) -(features iconv expeditor) -(include "i3.def") -(include "default.def") diff --git a/src/ChezScheme/s/i3ob.def b/src/ChezScheme/s/i3ob.def deleted file mode 100644 index 36a8fc1dfc..0000000000 --- a/src/ChezScheme/s/i3ob.def +++ /dev/null @@ -1,19 +0,0 @@ -;;; i3ob.def -;;; 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. - -(define-constant machine-type (constant machine-type-i3ob)) -(features iconv expeditor) -(include "i3.def") -(include "default.def") diff --git a/src/ChezScheme/s/i3osx.def b/src/ChezScheme/s/i3osx.def deleted file mode 100644 index 4c5baeac9b..0000000000 --- a/src/ChezScheme/s/i3osx.def +++ /dev/null @@ -1,19 +0,0 @@ -;;; i3osx.def -;;; 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. - -(define-constant machine-type (constant machine-type-i3osx)) -(features iconv expeditor) -(include "i3.def") -(include "default.def") diff --git a/src/ChezScheme/s/i3s2.def b/src/ChezScheme/s/i3s2.def deleted file mode 100644 index 0acd01bd38..0000000000 --- a/src/ChezScheme/s/i3s2.def +++ /dev/null @@ -1,19 +0,0 @@ -;;; i3s2.def -;;; 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. - -(define-constant machine-type (constant machine-type-i3s2)) -(features iconv expeditor) -(include "i3.def") -(include "default.def") diff --git a/src/ChezScheme/s/inspect.ss b/src/ChezScheme/s/inspect.ss index 7f07fb6f2b..17dbfe2883 100644 --- a/src/ChezScheme/s/inspect.ss +++ b/src/ChezScheme/s/inspect.ss @@ -2591,7 +2591,7 @@ (define cookie (cons 'date 'nut)) ; recreate on each call to $compute-size (define compute-size (lambda (x) - (if (or ($immediate? x) + (if (or (fixmediate? x) (let ([g ($generation x)]) (or (not g) (fx> g maxgen)))) 0 @@ -2784,7 +2784,7 @@ rtd-counts phantom) (define compute-composition! (lambda (x) - (unless (or ($immediate? x) + (unless (or (fixmediate? x) (let ([g ($generation x)]) (or (not g) (fx> g maxgen)))) (let ([a (eq-hashtable-cell seen-ht x #f)]) @@ -2945,7 +2945,7 @@ (lambda (x path next-proc) (let ([path (cons x path)]) (cond - [(or ($immediate? x) (let ([g ($generation x)]) (or (not g) (fx> g maxgen)))) + [(or (fixmediate? x) (let ([g ($generation x)]) (or (not g) (fx> g maxgen)))) (if (pred x) (begin (set! saved-next-proc next-proc) path) (next-proc))] diff --git a/src/ChezScheme/s/library.ss b/src/ChezScheme/s/library.ss index 09542d98c7..c1c3dfa412 100644 --- a/src/ChezScheme/s/library.ss +++ b/src/ChezScheme/s/library.ss @@ -1473,7 +1473,7 @@ [else #f]))) (define-library-entry (memv x ls) - (if (or (symbol? x) (#%$immediate? x)) + (if (or (symbol? x) (fixmediate? x)) (memq x ls) (let memv ([ls ls]) (and (not (null? ls)) diff --git a/src/ChezScheme/s/mkgc.ss b/src/ChezScheme/s/mkgc.ss index e65a9bbd84..3e66dc1dce 100644 --- a/src/ChezScheme/s/mkgc.ss +++ b/src/ChezScheme/s/mkgc.ss @@ -84,8 +84,10 @@ ;; - (trace-now <field>) : direct recur; implies pure ;; - (trace-early-rtd <field>) : for record types, avoids recur on #!base-rtd; implies pure ;; - (trace-pure-code <field>) : like `trace-pure`, but special handling in parallel mode +;; - (trace-reference <field>) : like `trace`, but for a reference bytevector element ;; - (trace-ptrs <field> <count>) : trace an array of pointerrs ;; - (trace-pure-ptrs <field> <count>) : pure analog of `trace-ptrs` +;; - (trace-reference-ptrs <field> <count>) : like `trace-ptrs`, but for a reference bytevector ;; - (copy <field>) : copy for copy, ignore otherwise ;; - (copy-bytes <field> <count>) : copy an array of bytes ;; - (copy-flonum <field>) : copy flonum and forward @@ -162,6 +164,11 @@ [pair (case-space + [(< space-weakpair) + (space space-impure) + (try-double-pair trace pair-car + trace pair-cdr + countof-pair)] [space-ephemeron (space space-ephemeron) (size size-ephemeron) @@ -187,12 +194,17 @@ (try-double-pair copy pair-car trace pair-cdr countof-weakpair)] - [else - (space space-impure) - (try-double-pair trace pair-car - trace pair-cdr - countof-pair)])] - + [else ; => space-reference-array as used for dirty resweep by owner thread + (case-mode + [(sweep) + (space space-reference-array) + (size size-pair) + (mark) + (trace-reference pair-car) + (trace-reference pair-cdr) + (count countof-pair)] + [else + (S_error_abort "misplaced pair")])])] [closure (define code : ptr (CLOSCODE _)) (trace-code-early code) ; not traced in parallel mode @@ -393,7 +405,7 @@ (count countof-vector)] [stencil-vector - ;; Assumes stencil-vector masks look like fixnums; + ;; Assumes stencil-vector tags look like immediates or fixnums; ;; if not, stencil vectors will need their own space (space (cond @@ -434,12 +446,25 @@ (count countof-flvector)] [bytevector - (space space-data) - (define sz : uptr (size_bytevector (Sbytevector_length _))) - (size (just sz)) - (mark) - (copy-bytes bytevector-type sz) - (count countof-bytevector)] + (case-space + [space-reference-array + (space space-reference-array) + (define sz : uptr (size_bytevector (Sbytevector_length _))) + (size (just sz)) + (mark) + (copy-type bytevector-type) + (define len : uptr (Sbytevector_reference_length _)) + (trace-reference-ptrs bytevector-data len) + (pad (when (== (& len 1) 0) + (set! (INITBVREFIT _copy_ len) (FIX 0)))) + (count countof-bytevector)] + [else + (space space-data) + (define sz : uptr (size_bytevector (Sbytevector_length _))) + (size (just sz)) + (mark) + (copy-bytes bytevector-type sz) + (count countof-bytevector)])] [tlc (space @@ -1118,10 +1143,10 @@ [(-> t_si use_marks) (cond [(! (marked t_si t)) - (mark_typemod_data_object _tgc_ t n t_si)])] + (mark_untyped_data_object _tgc_ t n t_si)])] [else (let* ([oldt : ptr t]) - (find_gc_room _tgc_ space_data from_g typemod n t) + (find_gc_room _tgc_ space_data from_g type-untyped n t) (memcpy_aligned (TO_VOIDP t) (TO_VOIDP oldt) n))])] [else (RECORD_REMOTE t_si)]))) @@ -1478,10 +1503,18 @@ "else" (code-block (statements body config)))] [`([,spc . ,body] . ,rest) + (unless (or (symbol? spc) + (and (pair? spc) + (memq (car spc) '(< <= == >= >)) + (pair? (cdr spc)) + (symbol? (cadr spc)) + (null? (cddr spc)))) + (error 'case-space "bad space spec: ~s" spc)) (code - (format "~aif (p_at_spc == ~a)" + (format "~aif (p_at_spc ~a ~a)" (if else? "else " "") - (as-c spc)) + (if (pair? spc) (car spc) "==") + (as-c (if (pair? spc) (cadr spc) spc))) (code-block (statements body config)) (loop rest #t))]))) (statements (cdr l) config))] @@ -1547,6 +1580,9 @@ (and (not (lookup 'as-dirty? config #f)) (trace-statement field config #f 'pure))]) (statements (cdr l) config))] + [`(trace-reference ,field) + (code (trace-statement field config #f 'reference) + (statements (cdr l) config))] [`(copy ,field) (code (copy-statement field config) (statements (cdr l) config))] @@ -1606,26 +1642,24 @@ (statements (cons `(trace-ptrs ,offset ,len pure) (cdr l)) config)] - [`(trace-ptrs ,offset ,len ,purity) + [`(trace-reference-ptrs ,offset ,len) + (statements (cons `(trace-ptrs ,offset ,len reference) + (cdr l)) + config)] + [`(trace-ptrs ,offset ,len ,purity/kind) (case (lookup 'mode config) [(copy) (statements (cons `(copy-bytes ,offset (* ptr_bytes ,len)) (cdr l)) config)] - [(sweep measure sweep-in-old check) + [(sweep measure sweep-in-old check self-test) (code (loop-over-pointers (field-expression offset config "p" #t) len - (trace-statement `(array-ref p_p idx) config #f purity) - config) - (statements (cdr l) config))] - [(self-test) - (code - (loop-over-pointers (field-expression offset config "p" #t) - len - (code "if (p_p[idx] == p) return 1;") - config) + (trace-statement `(array-ref p_p idx) config #f purity/kind) + config + purity/kind) (statements (cdr l) config))] [else (statements (cdr l) config)])] [`(count ,counter) @@ -2005,60 +2039,68 @@ [`() (error 'case-mode "no matching case for ~s in ~s" mode all-clauses)]))) - (define (loop-over-pointers ptr-e len body config) + (define (loop-over-pointers ptr-e len body config purity/kind) (code-block (format "uptr idx, p_len = ~a;" (expression len config)) - (format "ptr *p_p = &~a;" ptr-e) + (format "ptr *p_p = ~a&~a;" (if (eq? purity/kind 'reference) "(ptr*)" "") + ptr-e) "for (idx = 0; idx < p_len; idx++)" (code-block body))) - (define (trace-statement field config early? purity) + (define (trace-statement field config early? purity/kind) (define mode (lookup 'mode config)) + (define (reference->object e) + (if (eq? purity/kind 'reference) + (format "S_maybe_reference_to_object(~a)" e) + e)) (cond [(or (eq? mode 'sweep) (eq? mode 'sweep-in-old) (and early? (or (eq? mode 'copy) (eq? mode 'mark)))) - (relocate-statement purity (field-expression field config "p" #t) config)] + (relocate-statement purity/kind (field-expression field config "p" #t) config)] [(eq? mode 'copy) (copy-statement field config)] [(eq? mode 'measure) - (measure-statement (field-expression field config "p" #f))] + (measure-statement (reference->object (field-expression field config "p" #f)))] [(eq? mode 'self-test) - (format "if (p == ~a) return 1;" (field-expression field config "p" #f))] + (format "if (p == ~a) return 1;" (reference->object (field-expression field config "p" #f)))] [(eq? mode 'check) - (format "check_pointer(&(~a), ~a, ~a, seg, s_in, aftergc);" + (format "check_pointer(&(~a), ~a, ~a, ~a, seg, s_in, aftergc);" (field-expression field config "p" #f) (match field [`(just ,_) "0"] [else "1"]) + (if (eq? purity/kind 'reference) "1" "0") (expression '_ config))] [else #f])) - (define (relocate-statement purity e config) + (define (relocate-statement purity/kind e config) (define mode (lookup 'mode config)) (case mode [(sweep-in-old) - (if (eq? purity 'pure) - (format "relocate_pure(&~a);" e) - (format "relocate_indirect(~a);" e))] + (case purity/kind + [(pure) (format "relocate_pure(&~a);" e)] + [(reference) (format "relocate_reference_indirect(~a);" e)] + [else (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);" e)) + (case purity/kind + [(pure) (error 'relocate-statement "pure as dirty?")] + [(reference) (format "relocate_reference_dirty(&~a, youngest);" e)] + [else (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" ""))))])) + (format "relocate_~a~a(&~a~a);" purity/kind in-owner e (if (eq? purity/kind 'pure) "" ", from_g"))))])) (define (measure-statement e) (code "{ /* measure */" (format " ptr r_p = ~a;" e) - " if (!IMMEDIATE(r_p))" + " if (!FIXMEDIATE(r_p))" " push_measure(tgc, r_p);" "}")) @@ -2134,7 +2176,7 @@ final "}"))] [type (let ([t (lookup 'basetype config)]) - (if (eq? t 'typemod) + (if (eq? t 'type-untyped) #f (as-c 'type (lookup 'basetype config))))] [untype (lambda () @@ -2484,13 +2526,13 @@ (parallel? ,parallel?)))) (print-code (generate "object_directly_refers_to_self" `((mode self-test)))) - (print-code (code "static void mark_typemod_data_object(thread_gc *tgc, ptr p, uptr p_sz, seginfo *si)" + (print-code (code "static void mark_untyped_data_object(thread_gc *tgc, ptr p, uptr p_sz, seginfo *si)" (code-block (ensure-segment-mark-mask "si" "") (mark-statement '(one-bit no-sweep) (cons (list 'used (make-eq-hashtable)) - '((basetype typemod))))))) + '((basetype type-untyped))))))) (when measure? (print-code (generate "measure" `((mode measure)))))))) diff --git a/src/ChezScheme/s/mkheader.ss b/src/ChezScheme/s/mkheader.ss index 6c5ca768b2..778156d30c 100644 --- a/src/ChezScheme/s/mkheader.ss +++ b/src/ChezScheme/s/mkheader.ss @@ -339,9 +339,9 @@ (def "Sstencil_vector_length(x)" (format "Spopcount(((uptr)~a)>>~d)" - (access "x" vector type) + (access "x" stencil-vector type) ($ stencil-vector-mask-offset))) - (defref Sstencil_vector_ref vector data) + (defref Sstencil_vector_ref stencil-vector data) (export "iptr" "Sinteger_value" "(ptr)") (def "Sunsigned_value(x)" "(uptr)Sinteger_value(x)") @@ -445,6 +445,7 @@ (export "int" "Sscheme_script" "(const char *, int, const char *[])") (export "int" "Sscheme_program" "(const char *, int, const char *[])") (export "void" "Sscheme_deinit" "(void)") + (export "void" "Sscheme_register_signal_registerer" "(void (*f)(int))") (when-feature pthreads (nl) (comment "Thread support.") @@ -734,7 +735,7 @@ (nl) (pr "#define SPINLOCK(addr) \\~%") (pr " __asm__ __volatile__ (\"0:\\n\\t\"\\~%") - (pr " \"ldrex r12, [%0, #0]\\n\\t\"\\~%") + (pr " \"ldrex r12, [%0]\\n\\t\"\\~%") (pr " \"cmp r12, #0\\n\\t\"\\~%") (pr " \"bne 1f\\n\\t\"\\~%") (pr " \"mov r12, #1\\n\\t\"\\~%") @@ -763,7 +764,7 @@ (pr "#define LOCKED_INCR(addr, ret) \\~%") (pr " __asm__ __volatile__ (\"mov %0, #0\\n\\t\"\\~%") (pr " \"0:\\n\\t\"\\~%") - (pr " \"ldrex r12, [%1, #0]\\n\\t\"\\~%") + (pr " \"ldrex r12, [%1]\\n\\t\"\\~%") (pr " \"add r12, r12, #1\\n\\t\"\\~%") (pr " \"strex r7, r12, [%1]\\n\\t\"\\~%") (pr " \"cmp r7, #0\\n\\t\"\\~%") @@ -779,7 +780,7 @@ (pr "#define LOCKED_DECR(addr, ret) \\~%") (pr " __asm__ __volatile__ (\"mov %0, #0\\n\\t\"\\~%") (pr " \"0:\\n\\t\"\\~%") - (pr " \"ldrex r12, [%1, #0]\\n\\t\"\\~%") + (pr " \"ldrex r12, [%1]\\n\\t\"\\~%") (pr " \"sub r12, r12, #1\\n\\t\"\\~%") (pr " \"strex r7, r12, [%1]\\n\\t\"\\~%") (pr " \"cmp r7, #0\\n\\t\"\\~%") @@ -1183,6 +1184,8 @@ (nl) (comment "threads") + (when-feature pthreads + (pr "#define scheme_feature_pthreads 1~%")) (defref THREADTYPE thread type) (defref THREADTC thread tc) diff --git a/src/ChezScheme/s/np-help.ss b/src/ChezScheme/s/np-help.ss new file mode 100644 index 0000000000..aa2fb1c2ab --- /dev/null +++ b/src/ChezScheme/s/np-help.ss @@ -0,0 +1,206 @@ +;; Helpers for "cpnanopass.ss" and "cpprim.ss", especially +;; "%"-prefixed macros that abbreviate expression constructions + +(define-syntax tc-disp + (lambda (x) + (syntax-case x () + [(_ name) + (case (datum name) + [(%ac0) (constant tc-ac0-disp)] + [(%ac1) (constant tc-ac1-disp)] + [(%sfp) (constant tc-sfp-disp)] + [(%cp) (constant tc-cp-disp)] + [(%esp) (constant tc-esp-disp)] + [(%ap) (constant tc-ap-disp)] + [(%eap) (constant tc-eap-disp)] + [(%trap) (constant tc-trap-disp)] + [(%xp) (constant tc-xp-disp)] + [(%yp) (constant tc-yp-disp)] + [(%save1) (constant tc-save1-disp)] + [else #f])]))) + +(define-syntax %type-check + (lambda (x) + (syntax-case x () + [(k mask type expr) + (with-implicit (k $type-check quasiquote) + #'($type-check (constant mask) (constant type) `expr))]))) + +(define-syntax %typed-object-check ; NB: caller must bind e + (lambda (x) + (syntax-case x () + [(k mask type expr) + (with-implicit (k quasiquote %type-check %constant %mref) + #'`(if ,(%type-check mask-typed-object type-typed-object expr) + ,(%type-check mask type + ,(%mref expr ,(constant typed-object-type-disp))) + ,(%constant sfalse)))]))) + +(define-syntax %seq + (lambda (x) + (syntax-case x () + [(k e1 ... e2) + (with-implicit (k quasiquote) + #``#,(fold-right (lambda (x body) #`(seq #,x #,body)) + #'e2 #'(e1 ...)))]))) + +(define-syntax %mref + (lambda (x) + (syntax-case x () + [(k e0 e1 imm type) + (with-implicit (k quasiquote) + #'`(mref e0 e1 imm type))] + [(k e0 e1 imm) + (with-implicit (k quasiquote) + #'`(mref e0 e1 imm uptr))] + [(k e0 imm) + (with-implicit (k quasiquote) + #'`(mref e0 ,%zero imm uptr))]))) + +(define-syntax %inline + (lambda (x) + (syntax-case x () + [(k name e ...) + (with-implicit (k quasiquote) + #'`(inline ,null-info ,(%primitive name) e ...))]))) + +(define-syntax %lea + (lambda (x) + (syntax-case x () + [(k base offset) + (with-implicit (k quasiquote) + #'`(inline ,(make-info-lea offset) ,%lea1 base))] + [(k base index offset) + (with-implicit (k quasiquote) + #'`(inline ,(make-info-lea offset) ,%lea2 base index))]))) + +(define-syntax %constant + (lambda (x) + (syntax-case x () + [(k x) + (with-implicit (k quasiquote) + #'`(immediate ,(constant x)))]))) + +(define-syntax %tc-ref + (lambda (x) + (define-who field-type + (lambda (struct field) + (cond + [(assq field (getprop struct '*fields* '())) => + (lambda (a) + (apply + (lambda (field type disp len) type) + a))] + [else ($oops who "undefined field ~s-~s" struct field)]))) + (syntax-case x () + [(k field) #'(k ,%tc field)] + [(k e-tc field) + (if (memq (field-type 'tc (datum field)) '(ptr xptr uptr iptr)) + (with-implicit (k %mref) + #`(%mref e-tc + #,(lookup-constant + (string->symbol + (format "tc-~a-disp" (datum field)))))) + (syntax-error x "non-ptr-size tc field"))]))) + +(define-syntax %constant-alloc + (lambda (x) + (syntax-case x () + [(k tag size) #'(k tag size #f #f)] + [(k tag size save-flrv?) #'(k tag size save-flrv? #f)] + [(k tag size save-flrv? save-asm-ra?) + (with-implicit (k quasiquote) + #'`(alloc + ,(make-info-alloc (constant tag) save-flrv? save-asm-ra?) + (immediate ,(c-alloc-align size))))]))) + +(define-syntax %mv-jump + (lambda (x) + (syntax-case x () + [(k ret-reg (live ...)) + (with-implicit (k quasiquote %mref %inline %constant) + #'`(if ,(%inline logtest ,(%mref ret-reg ,(constant compact-return-address-mask+size+mode-disp)) + ,(%constant compact-header-mask)) + ;; compact: use regular return or error? + (if ,(%inline logtest ,(%mref ret-reg ,(constant compact-return-address-mask+size+mode-disp)) + ,(%constant compact-header-values-error-mask)) + ;; values error: + (jump (literal ,(make-info-literal #f 'library-code + (lookup-libspec values-error) + (constant code-data-disp))) + (live ...)) + ;; regular return point: + (jump ret-reg (live ...))) + ;; non-compact rp-header + (jump ,(%mref ret-reg ,(constant return-address-mv-return-address-disp)) (live ...))))]))) + + + +; for use only after mdcl field has been added to the call syntax +(define-syntax %primcall + (lambda (x) + (syntax-case x () + [(k src sexpr prim arg ...) + (identifier? #'prim) + (with-implicit (k quasiquote) + #``(call ,(make-info-call src sexpr #f #f #f) #f + ,(lookup-primref 3 'prim) + arg ...))]))) + +(define-syntax define-$type-check + (lambda (x) + (syntax-case x () + [(k L) (with-implicit (k $type-check) + #'(define $type-check + (lambda (mask type expr) + (with-output-language L + (cond + [(fx= type 0) (%inline log!test ,expr (immediate ,mask))] + [(= mask (constant byte-constant-mask)) (%inline eq? ,expr (immediate ,type))] + [else (%inline type-check? ,expr (immediate ,mask) (immediate ,type))])))))]))) + +(define target-fixnum? + (if (and (= (constant most-negative-fixnum) (most-negative-fixnum)) + (= (constant most-positive-fixnum) (most-positive-fixnum))) + fixnum? + (lambda (x) + (and (or (fixnum? x) (bignum? x)) + (<= (constant most-negative-fixnum) x (constant most-positive-fixnum)))))) + +(define unfix + (lambda (imm) + (ash imm (fx- (constant fixnum-offset))))) + +(define fix + (lambda (imm) + (ash imm (constant fixnum-offset)))) + +(define ptr->imm + (lambda (x) + (cond + [(eq? x #f) (constant sfalse)] + [(eq? x #t) (constant strue)] + [(eq? x (void)) (constant svoid)] + [(null? x) (constant snil)] + [(eof-object? x) (constant seof)] + [($unbound-object? x) (constant sunbound)] + [(bwp-object? x) (constant sbwp)] + [(eq? x '#1=#1#) (constant black-hole)] + [(target-fixnum? x) (fix x)] + [(char? x) (+ (* (constant char-factor) (char->integer x)) (constant type-char))] + [else #f]))) + +(define-syntax ref-reg + (lambda (x) + (syntax-case x () + [(k reg) + (identifier? #'reg) + (if (real-register? (datum reg)) + #'reg + (with-implicit (k %mref) #`(%mref ,%tc ,(tc-disp reg))))]))) + +(define (fp-type? type) + (nanopass-case (Ltype Type) type + [(fp-double-float) #t] + [(fp-single-float) #t] + [else #f])) diff --git a/src/ChezScheme/s/np-info.ss b/src/ChezScheme/s/np-info.ss new file mode 100644 index 0000000000..675fe1332e --- /dev/null +++ b/src/ChezScheme/s/np-info.ss @@ -0,0 +1,253 @@ +;; Records used by "cpnanopass.ss" and "cpprim.ss" + +(define-record-type ctci ; compile-time version of code-info + (nongenerative #{ctci bcpkdd2y9yyv643zicd4jbe3y-0}) + (sealed #t) + (fields (mutable live) (mutable rpi*) (mutable closure-fv-names)) + (protocol + (lambda (new) + (lambda () + (new #f '() #f))))) + +(define-record-type ctrpi ; compile-time version of rp-info + (nongenerative #{ctrpi bcpkdd2y9yyv643zicd4jbe3y-1}) + (sealed #t) + (fields label src sexpr mask)) + +(define-record-type info-lambda + (nongenerative #{info-lambda bcpkdd2y9yyv643zicd4jbe3y-2}) + (parent info) + (sealed #t) + (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) + (rec cons-info-lambda + (case-lambda + [(src sexpr libspec interface*) (cons-info-lambda src sexpr libspec interface* #f 0)] + [(src sexpr libspec interface* name) (cons-info-lambda src sexpr libspec interface* name 0)] + [(src sexpr libspec interface* name flags) + ((pargs->new) src sexpr libspec interface* + (map (lambda (iface) (make-direct-call-label 'dcl)) interface*) + (if (eq? (subset-mode) 'system) (fxlogor flags (constant code-flag-system)) flags) + '() name #f 'closure (and (generate-inspector-information) (make-ctci)) '() ($np-next-lambda-seqno))]))))) + +(define-record-type info-call + (nongenerative #{info-call bcpkdd2y9yyv643zicd4jbe3y-3}) + (parent info) + (sealed #t) + (fields src sexpr (mutable check?) pariah? error? shift-attachment? shift-consumer-attachment?*) + (protocol + (lambda (pargs->new) + (case-lambda + [(src sexpr check? pariah? error? shift-attachment? shift-consumer-attachment?*) + ((pargs->new) src sexpr check? pariah? error? shift-attachment? shift-consumer-attachment?*)] + [(src sexpr check? pariah? error?) + ((pargs->new) src sexpr check? pariah? error? #f '())])))) + +(define-record-type info-newframe + (nongenerative #{info-newframe bcpkdd2y9yyv643zicd4jbe3y-4}) + (parent info) + (sealed #t) + (fields + src + sexpr + cnfv* + nfv* + nfv** + (mutable weight) + (mutable call-live*) + (mutable frame-words) + (mutable local-save*)) + (protocol + (lambda (pargs->new) + (lambda (src sexpr cnfv* nfv* nfv**) + ((pargs->new) src sexpr cnfv* nfv* nfv** 0 #f #f #f))))) + +(define-record-type info-kill* + (nongenerative #{info-kill* bcpkdd2y9yyv643zicd4jbe3y-5}) + (parent info) + (fields kill*)) + +(define-record-type info-kill*-live* + (nongenerative #{info-kill*-live* bcpkdd2y9yyv643zicd4jbe3y-6}) + (parent info-kill*) + (fields live*) + (protocol + (lambda (new) + (case-lambda + [(kill* live*) + ((new kill*) live*)] + [(kill*) + ((new kill*) (reg-list))])))) + +(define-record-type info-asmlib + (nongenerative #{info-asmlib bcpkdd2y9yyv643zicd4jbe3y-7}) + (parent info-kill*-live*) + (sealed #t) + (fields libspec save-ra?) + (protocol + (lambda (new) + (case-lambda + [(kill* libspec save-ra? live*) + ((new kill* live*) libspec save-ra?)] + [(kill* libspec save-ra?) + ((new kill*) libspec save-ra?)])))) + +(module (intrinsic-info-asmlib intrinsic-return-live* intrinsic-entry-live* intrinsic-modify-reg* dorest-intrinsics) + (define-record-type intrinsic + (nongenerative #{intrinsic bcpkdd2y9yyv643zicd4jbe3y-A}) + (sealed #t) + (fields libspec kill* live* rv*)) + (define intrinsic-info-asmlib + (lambda (intrinsic save-ra?) + (make-info-asmlib (intrinsic-kill* intrinsic) + (intrinsic-libspec intrinsic) + save-ra? + (intrinsic-live* intrinsic)))) + (define intrinsic-return-live* + ; used a handful of times, just while compiling library.ss...don't bother optimizing + (lambda (intrinsic) + (fold-left (lambda (live* kill) (remq kill live*)) + (vector->list regvec) (intrinsic-kill* intrinsic)))) + (define intrinsic-entry-live* + ; used a handful of times, just while compiling library.ss...don't bother optimizing + (lambda (intrinsic) ; return-live* - rv + live* + (fold-left (lambda (live* live) (if (memq live live*) live* (cons live live*))) + (fold-left (lambda (live* rv) (remq rv live*)) + (intrinsic-return-live* intrinsic) + (intrinsic-rv* intrinsic)) + (intrinsic-live* intrinsic)))) + (define intrinsic-modify-reg* + (lambda (intrinsic) + (append (intrinsic-rv* intrinsic) + (intrinsic-kill* intrinsic)))) + (define-syntax declare-intrinsic + (syntax-rules (unquote) + [(_ name entry-name (kill ...) (live ...) (rv ...)) + (begin + (define name + (make-intrinsic + (lookup-libspec entry-name) + (reg-list kill ...) + (reg-list live ...) + (reg-list rv ...))) + (export name))])) + ; must include in kill ... any register explicitly assigned by the intrinsic + ; plus additional registers as needed to avoid spilled unspillables. the + ; list could be machine-dependent but at this point it doesn't matter. + (declare-intrinsic dofargint32 dofargint32 (%ts %td %xp) (%ac0) (%ac0)) + (constant-case ptr-bits + [(32) (declare-intrinsic dofargint64 dofargint64 (%ts %td %xp) (%ac0) (%ac0 %ac1))] + [(64) (declare-intrinsic dofargint64 dofargint64 (%ts %td %xp) (%ac0) (%ac0))]) + (declare-intrinsic dofretint32 dofretint32 (%ts %td %xp) (%ac0) (%ac0)) + (constant-case ptr-bits + [(32) (declare-intrinsic dofretint64 dofretint64 (%ts %td %xp) (%ac0 %ac1) (%ac0))] + [(64) (declare-intrinsic dofretint64 dofretint64 (%ts %td %xp) (%ac0) (%ac0))]) + (declare-intrinsic dofretuns32 dofretuns32 (%ts %td %xp) (%ac0) (%ac0)) + (constant-case ptr-bits + [(32) (declare-intrinsic dofretuns64 dofretuns64 (%ts %td %xp) (%ac0 %ac1) (%ac0))] + [(64) (declare-intrinsic dofretuns64 dofretuns64 (%ts %td %xp) (%ac0) (%ac0))]) + (declare-intrinsic dofretu8* dofretu8* (%ac0 %ts %td %cp %ac1) (%ac0) (%xp)) + (declare-intrinsic dofretu16* dofretu16* (%ac0 %ts %td %cp %ac1) (%ac0) (%xp)) + (declare-intrinsic dofretu32* dofretu32* (%ac0 %ts %td %cp %ac1) (%ac0) (%xp)) + (declare-intrinsic get-room get-room () (%xp) (%xp)) + (declare-intrinsic scan-remembered-set scan-remembered-set () () ()) + (declare-intrinsic reify-1cc reify-1cc (%xp %ac0 %ts %reify1 %reify2) () (%td)) ; %reify1 & %reify2 are defined as needed per machine... + (declare-intrinsic maybe-reify-cc maybe-reify-cc (%xp %ac0 %ts %reify1 %reify2) () (%td)) ; ... to have enough registers to allocate + (declare-intrinsic dooverflow dooverflow () () ()) + (declare-intrinsic dooverflood dooverflood () (%xp) ()) + ; a dorest routine takes all of the register and frame arguments from the rest + ; argument forward and also modifies the rest argument. for the rest argument, + ; this is a wash (it's live both before and after). the others should also be + ; listed as live. it's inconvenient and currently unnecessary to do so. + ; (actually currently impossible to list the infinite set of frame arguments) + (define-syntax dorest-intrinsic-max (identifier-syntax 5)) + (export dorest-intrinsic-max) + (define (list-xtail ls n) + (if (or (null? ls) (fx= n 0)) + ls + (list-xtail (cdr ls) (fx1- n)))) + (define dorest-intrinsics + (let () + (define-syntax dorests + (lambda (x) + #`(vector #,@ + (let f ([i 0]) + (if (fx> i dorest-intrinsic-max) + '() + (cons #`(make-intrinsic + (lookup-libspec #,(construct-name #'k "dorest" i)) + (reg-list %ac0 %xp %ts %td) + (reg-cons* %ac0 (list-xtail arg-registers #,i)) + (let ([ls (list-xtail arg-registers #,i)]) (if (null? ls) '() (list (car ls))))) + (f (fx+ i 1)))))))) + dorests))) + +(define-record-type info-alloc + (nongenerative #{info-alloc bcpkdd2y9yyv643zicd4jbe3y-9}) + (parent info) + (sealed #t) + (fields tag save-flrv? save-ra?)) + +(define-record-type info-foreign + (nongenerative #{info-foreign bcpkdd2y9yyv643zicd4jbe3y-10}) + (parent info) + (sealed #t) + (fields conv* arg-type* result-type unboxed? (mutable name)) + (protocol + (lambda (pargs->new) + (lambda (conv* arg-type* result-type unboxed?) + ((pargs->new) conv* arg-type* result-type unboxed? #f))))) + +(define-record-type info-literal + (nongenerative #{info-literal bcpkdd2y9yyv643zicd4jbe3y-11}) + (parent info) + (sealed #t) + (fields indirect? type addr offset)) + +(define-record-type info-lea + (nongenerative #{info-lea bcpkdd2y9yyv643zicd4jbe3y-12}) + (parent info) + (sealed #t) + (fields offset)) + +(define-record-type info-load + (nongenerative #{info-load bcpkdd2y9yyv643zicd4jbe3y-13}) + (parent info) + (sealed #t) + (fields type swapped?)) + +(define-record-type info-condition-code + (nongenerative #{info-condition-code bcpkdd2y9yyv643zicd4jbe3y-14}) + (parent info) + (sealed #t) + (fields type reversed? invertible?)) + +(define-record-type info-c-simple-call + (nongenerative #{info-c-simple-call bcpkdd2y9yyv643zicd4jbe3y-15}) + (parent info-kill*-live*) + (sealed #t) + (fields save-ra? entry) + (protocol + (lambda (new) + (case-lambda + [(save-ra? entry) ((new '() '()) save-ra? entry)] + [(live* save-ra? entry) ((new '() live*) save-ra? entry)])))) + +(define-record-type info-c-return + (nongenerative #{info-c-return bcpkdd2y9yyv643zicd4jbe3y-16}) + (parent info) + (sealed #t) + (fields offset)) + +(define-record-type info-inline + (nongenerative #{info-inline bcpkdd2y9yyv643zicd4jbe3y-17}) + (parent info) + (sealed #t) + (fields)) + +(define-record-type info-unboxed-args + (nongenerative #{info-unboxed-args bcpkdd2y9yyv643zicd4jbe3y-18}) + (parent info) + (fields unboxed?*)) diff --git a/src/ChezScheme/s/np-languages.ss b/src/ChezScheme/s/np-languages.ss index eab5f30c35..c52daea3d8 100644 --- a/src/ChezScheme/s/np-languages.ss +++ b/src/ChezScheme/s/np-languages.ss @@ -32,6 +32,7 @@ fv-offset fv-type var-spillable-conflict* var-spillable-conflict*-set! var-unspillable-conflict* var-unspillable-conflict*-set! + var-spillinfo-redirect! make-redirect-var uvar-degree uvar-degree-set! uvar-info-lambda uvar-info-lambda-set! uvar-iii uvar-iii-set! @@ -86,14 +87,89 @@ (define datum? (lambda (x) #t)) (define-record-type var - (fields (mutable index) (mutable spillable-conflict*) (mutable unspillable-conflict*)) - (nongenerative) + (fields (mutable index-or-redirect) (mutable spillable-conflict*-or-redirect) (mutable unspillable-conflict*-or-redirect)) + (nongenerative #{var fjh3mleeyv82pb1x1uhd4vsbv-1}) (protocol (lambda (new) (lambda () (new #f #f #f))))) + ;; relies on pairs being distinct from conflict sets and indices: + (define (make-spillinfo-redirect index) (cons index '())) + (define (spillinfo-redirect? v) (pair? v)) + (define (spillinfo-redirect-index r) (car r)) + + (define-record-type precolor-var + (parent var) + (fields (mutable precolored)) + (nongenerative #{precolor-var fjh3mleeyv82pb1x1uhd4vsbv-5}) + (protocol (lambda (pargs->new) (lambda () ((pargs->new) #f))))) + + (define (make-redirect-var name) + (make-precolor-var)) + + (define (var-spillinfo-redirect! v index) + (let ([r (make-spillinfo-redirect index)]) + (var-index-or-redirect-set! v r) + (var-spillable-conflict*-or-redirect-set! v r) + (var-unspillable-conflict*-or-redirect-set! v r))) + + (define var-index + (case-lambda + [(v) ; when index is not used for spill information + (safe-assert (not (spillinfo-redirect? (var-index-or-redirect v)))) + (var-index-or-redirect v)] + [(v reg-spillinfo) ; when index is used for spill information + (let ([i (var-index-or-redirect v)]) + (if (spillinfo-redirect? i) + (var-index-or-redirect + (vector-ref reg-spillinfo (spillinfo-redirect-index i))) + i))])) + + (define var-index-set! + (case-lambda + [(v i) ; when index is not used for spill information + (safe-assert (not (spillinfo-redirect? (var-index-or-redirect v)))) + (var-index-or-redirect-set! v i)] + [(v reg-spillinfo i) ; when index is used for spill information + (let ([old-i (var-index-or-redirect v)]) + (if (spillinfo-redirect? old-i) + (var-index-or-redirect-set! + (vector-ref reg-spillinfo (spillinfo-redirect-index old-i)) + i) + (var-index-or-redirect-set! v i)))])) + + (define (var-spillable-conflict* v reg-spillinfo) + (let ([c* (var-spillable-conflict*-or-redirect v)]) + (if (spillinfo-redirect? c*) + (var-spillable-conflict*-or-redirect + (vector-ref reg-spillinfo (spillinfo-redirect-index c*))) + c*))) + + (define (var-unspillable-conflict* v reg-spillinfo) + (let ([c* (var-unspillable-conflict*-or-redirect v)]) + (if (spillinfo-redirect? c*) + (var-unspillable-conflict*-or-redirect + (vector-ref reg-spillinfo (spillinfo-redirect-index c*))) + c*))) + + (define (var-spillable-conflict*-set! v reg-spillinfo c*) + (let ([old-c* (var-spillable-conflict*-or-redirect v)]) + (if (spillinfo-redirect? old-c*) + (var-spillable-conflict*-or-redirect-set! + (vector-ref reg-spillinfo (spillinfo-redirect-index old-c*)) + c*) + (var-spillable-conflict*-or-redirect-set! v c*)))) + + (define (var-unspillable-conflict*-set! v reg-spillinfo c*) + (let ([old-c* (var-unspillable-conflict*-or-redirect v)]) + (if (spillinfo-redirect? old-c*) + (var-unspillable-conflict*-or-redirect-set! + (vector-ref reg-spillinfo (spillinfo-redirect-index old-c*)) + c*) + (var-unspillable-conflict*-or-redirect-set! v c*)))) + (define-record-type (fv $make-fv fv?) (parent var) (fields offset type) - (nongenerative) + (nongenerative #{fv fjh3mleeyv82pb1x1uhd4vsbv-2}) (sealed #t) (protocol (lambda (pargs->new) @@ -107,13 +183,20 @@ (define-record-type reg (parent var) - (fields name mdinfo tc-disp callee-save? type (mutable precolored)) - (nongenerative) + (fields name mdinfo tc-disp callee-save? type) + (nongenerative #{reg fjh3mleeyv82pb1x1uhd4vsbv-6}) (sealed #t) (protocol (lambda (pargs->new) (lambda (name mdinfo tc-disp callee-save? type) - ((pargs->new) name mdinfo tc-disp callee-save? type #f))))) + ((pargs->new) name mdinfo tc-disp callee-save? type))))) + + (define (reg-precolored reg reg-spillinfo) + (let ([i (var-index-or-redirect reg)]) + (precolor-var-precolored (vector-ref reg-spillinfo (spillinfo-redirect-index i))))) + (define (reg-precolored-set! reg reg-spillinfo v) + (let ([i (var-index-or-redirect reg)]) + (precolor-var-precolored-set! (vector-ref reg-spillinfo (spillinfo-redirect-index i)) v))) (module () (record-writer (record-type-descriptor reg) @@ -181,7 +264,7 @@ (mutable save-weight) ; must be a fixnum! (mutable live-count) ; must be a fixnum! ) - (nongenerative) + (nongenerative #{uvar fjh3mleeyv82pb1x1uhd4vsbv-4}) (sealed #t) (protocol (lambda (pargs->new) @@ -232,7 +315,8 @@ (eq-hashtable-set! ht x sym) sym))))) - (define-record-type info (nongenerative)) + (define-record-type info + (nongenerative #{info n93q6qho9id46fha8itaytldd-5})) (define null-info (make-info)) @@ -242,12 +326,12 @@ (fprintf p "#<info>")))) (define-record-type label - (nongenerative) + (nongenerative #{var n93q6qho9id46fha8itaytldd-6}) (fields name)) (define-record-type libspec-label (parent label) - (nongenerative) + (nongenerative #{var n93q6qho9id46fha8itaytldd-7}) (sealed #t) (fields libspec live-reg*) (protocol @@ -259,7 +343,7 @@ ; different purposes in different passes. (define-record-type local-label (parent label) - (nongenerative) + (nongenerative #{var n93q6qho9id46fha8itaytldd-8}) (fields (mutable func) (mutable offset) (mutable iteration) (mutable block) ; following used by place-overflow-and-trap-check pass (mutable overflow-check) (mutable trap-check)) @@ -270,7 +354,7 @@ (define-record-type direct-call-label (parent local-label) - (nongenerative) + (nongenerative #{var n93q6qho9id46fha8itaytldd-9}) (sealed #t) (fields (mutable referenced)) (protocol @@ -280,7 +364,7 @@ (define-record-type return-point-label (parent local-label) - (nongenerative) + (nongenerative #{var n93q6qho9id46fha8itaytldd-10}) (sealed #t) (fields (mutable compact?)) (protocol @@ -319,6 +403,7 @@ ; records, and make sure other record types have been discarded. also formally sets up ; CaseLambdaClause as entry point for language. (define-language L1 + (nongenerative-id #{L1 jczowy6yjfz400ntojb6av7y0-1}) (terminals (uvar (x)) (datum (d)) @@ -356,24 +441,28 @@ ; introducing let (define-language L2 (extends L1) + (nongenerative-id #{L2 jczowy6yjfz400ntojb6av7y0-2}) (entry CaseLambdaExpr) (Expr (e body) (+ (let ([x e] ...) body)))) ; removes moi; also adds name to info-lambda & info-foreign (define-language L3 (extends L2) + (nongenerative-id #{L3 jczowy6yjfz400ntojb6av7y0-3}) (entry CaseLambdaExpr) (Expr (e body) (- (moi)))) ; removes assignable indefinite-extent variables from the language (define-language L4 (extends L3) + (nongenerative-id #{L4 jczowy6yjfz400ntojb6av7y0-4}) (entry CaseLambdaExpr) (Expr (e body) (- (set! x e)))) ; introducing mvlet, and mvcall (define-language L4.5 (extends L4) + (nongenerative-id #{L4.5 jczowy6yjfz400ntojb6av7y0-4.5}) (terminals (+ (label (l)) (maybe-label (mdcl)) @@ -387,6 +476,7 @@ ; removes foreign, adds foreign-call, updates fcallable (define-language L4.75 (extends L4.5) + (nongenerative-id #{L4.75 jczowy6yjfz400ntojb6av7y0-4.75}) (entry CaseLambdaExpr) (Expr (e body) (- (foreign info e) @@ -397,6 +487,7 @@ ; adds loop form (define-language L4.875 (extends L4.75) + (nongenerative-id #{L4.875 jczowy6yjfz400ntojb6av7y0-4.875}) (entry CaseLambdaExpr) (Expr (e body) (+ (loop x (x* ...) body) => (loop x body)))) @@ -411,6 +502,7 @@ ; exposes continuation-attachment operations (define-language L4.9375 (extends L4.875) + (nongenerative-id #{L4.9375 jczowy6yjfz400ntojb6av7y0-4.9375}) (terminals (+ (attachment-op (aop))) (+ (continuation-op (cop))) @@ -425,12 +517,14 @@ ; moves all case lambda expressions into rhs of letrec (define-language L5 (extends L4.9375) + (nongenerative-id #{L5 jczowy6yjfz400ntojb6av7y0-5}) (entry CaseLambdaExpr) (Expr (e body) (- le))) ; replaces letrec with labels and closures forms (define-language L6 (extends L5) + (nongenerative-id #{L6 jczowy6yjfz400ntojb6av7y0-6}) (terminals (+ (maybe-var (mcp)))) (entry CaseLambdaExpr) @@ -449,6 +543,7 @@ ; move labels to top level and expands closures forms to more primitive operations (define-language L7 (extends L6) + (nongenerative-id #{L7 jczowy6yjfz400ntojb6av7y0-7}) (terminals (- (uvar (x)) (fixnum (interface))) @@ -486,7 +581,7 @@ (define-record-type primitive (fields name type pure? (mutable handler)) - (nongenerative) + (nongenerative #{var n93q6qho9id46fha8itaytldd-11}) (sealed #t) (protocol (lambda (new) @@ -519,7 +614,7 @@ [(_ name type pure?) (with-syntax ([%name (construct-name #'name "%" #'name)]) #'(begin - (define %name (make-primitive 'name 'type pure?)) + (define-once %name (make-primitive '%name 'type pure?)) (export %name)))]))) (define-syntax %primitive @@ -672,6 +767,7 @@ ; '(), (eof-object), ($unbound-object), #!bwp, characters, and fixnums as ; scheme-object ptrs and inlines primitive calls (define-language L9 (extends L7) + (nongenerative-id #{L9 jczowy6yjfz400ntojb6av7y0-9}) (entry Program) (terminals (- (datum (d)) @@ -686,6 +782,7 @@ ; determine where we should be placing interrupt and overflow (define-language L9.5 (extends L9) + (nongenerative-id #{L9.5 jczowy6yjfz400ntojb6av7y0-9.5}) (entry Program) (terminals (+ (boolean (ioc)))) @@ -695,6 +792,7 @@ ; remove the loop form (define-language L9.75 (extends L9.5) + (nongenerative-id #{L9.75 jczowy6yjfz400ntojb6av7y0-9.75}) (entry Program) (Expr (e body) (- (loop x (x* ...) body)))) @@ -706,6 +804,7 @@ ; Rhs expressions can appear on the right-hand-side of a set! or anywhere arbitrary ; Exprs can appear. Exprs appear in the body of a case-lambda clause. (define-language L10 (extends L9.75) + (nongenerative-id #{L10 jczowy6yjfz400ntojb6av7y0-10}) (terminals (+ (uvar (local)))) (entry Program) @@ -751,6 +850,7 @@ (set! lvalue rhs)))) (define-language L10.5 (extends L10) + (nongenerative-id #{L10.5 jczowy6yjfz400ntojb6av7y0-10.5}) (entry Program) (Rhs (rhs) (- (call info mdcl (maybe t0) t1 ...) @@ -768,6 +868,7 @@ ; labels used as arguments to make-closure, closure-ref, and closure-set! are ; marked as literals so they will not be turned into scheme constants again. (define-language L11 (extends L10.5) + (nongenerative-id #{L11 jczowy6yjfz400ntojb6av7y0-11}) (terminals (- (primitive (prim))) (+ (value-primitive (value-prim)) @@ -831,6 +932,7 @@ (tail tl)))) (define-language L12 (extends L11) + (nongenerative-id #{L12 jczowy6yjfz400ntojb6av7y0-12}) (terminals (- (fixnum (interface offset)) (label (l))) @@ -854,6 +956,7 @@ (mverror-point)))) (define-language L12.5 (extends L12) + (nongenerative-id #{L12.5 jczowy6yjfz400ntojb6av7y0-12.5}) (entry Program) (terminals (- (boolean (ioc)))) @@ -869,6 +972,7 @@ ; longer have arguments; case-lambda is resposible for dispatching to correct ; clause, even when the game is being played (define-language L13 + (nongenerative-id #{L13 jczowy6yjfz400ntojb6av7y0-13}) (terminals (fixnum (max-fv offset)) (fv (fv)) @@ -943,6 +1047,7 @@ (goto l))) (define-language L13.5 (extends L13) + (nongenerative-id #{L13.5 jczowy6yjfz400ntojb6av7y0-13.5}) (terminals (- (symbol (sym)))) (entry Program) @@ -950,6 +1055,7 @@ (- (hand-coded sym)))) (define-language L14 (extends L13.5) + (nongenerative-id #{L14 jczowy6yjfz400ntojb6av7y0-14}) (entry Program) (Rhs (rhs) (- (alloc info t)))) @@ -968,7 +1074,7 @@ (mutable loop-headers) (mutable index) (mutable weight)) - (nongenerative) + (nongenerative #{var n93q6qho9id46fha8itaytldd-12}) (protocol (lambda (new) (lambda () @@ -983,7 +1089,7 @@ (loop-header #b100000)) (define-record-type live-info - (nongenerative) + (nongenerative #{var n93q6qho9id46fha8itaytldd-13}) (sealed #t) (fields (mutable live) @@ -1002,6 +1108,7 @@ (fprintf p "#<live-info ~s>" (live-info-live x)))))) (define-language L15a + (nongenerative-id #{L15a jczowy6yjfz400ntojb6av7y0-15a}) (terminals (var (x cnfv var)) (reg (reg)) @@ -1057,6 +1164,7 @@ (asm-c-return info reg* ...))) (define-language L15b (extends L15a) + (nongenerative-id #{L15b jczowy6yjfz400ntojb6av7y0-15b}) (terminals (- (var (x cnfv var)) (reg (reg)) @@ -1090,6 +1198,7 @@ (eq? (uvar-type x) 'fp))))) (define-language L15c (extends L15b) + (nongenerative-id #{L15c jczowy6yjfz400ntojb6av7y0-15c}) (terminals (- (var (x var))) (+ (ur (x)))) @@ -1101,6 +1210,7 @@ (- (fp-offset live-info imm)))) (define-language L15d (extends L15c) + (nongenerative-id #{L15d jczowy6yjfz400ntojb6av7y0-15d}) (terminals (- (pred-primitive (pred-prim)) (value-primitive (value-prim)) @@ -1129,6 +1239,7 @@ (+ (jump t)))) (define-language L15e (extends L15d) + (nongenerative-id #{L15e jczowy6yjfz400ntojb6av7y0-15e}) (terminals (- (ur (x))) (+ (reg (x)))) @@ -1142,6 +1253,7 @@ (+ (set! lvalue rhs)))) (define-language L16 (extends L15e) + (nongenerative-id #{L16 jczowy6yjfz400ntojb6av7y0-16}) (entry Program) (Effect (e) (- (overflow-check p e* ...)))) diff --git a/src/ChezScheme/s/np-register.ss b/src/ChezScheme/s/np-register.ss new file mode 100644 index 0000000000..49e49c8c00 --- /dev/null +++ b/src/ChezScheme/s/np-register.ss @@ -0,0 +1,168 @@ +(define-syntax architecture + (let ([fn (format "~a.ss" (constant architecture))]) + (with-source-path 'architecture fn + (lambda (fn) + (let* ([p ($open-file-input-port 'include fn)] + [sfd ($source-file-descriptor fn p)] + [p (transcoded-port p (current-transcoder))]) + (let ([do-read ($make-read p sfd 0)]) + (let* ([regs (do-read)] [inst (do-read)] [asm (do-read)]) + (when (eof-object? asm) ($oops #f "too few expressions in ~a" fn)) + (unless (eof-object? (do-read)) ($oops #f "too many expressions in ~a" fn)) + (close-input-port p) + (lambda (x) + (syntax-case x (registers instructions assembler) + [(k registers) (datum->syntax #'k regs)] + [(k instructions) (datum->syntax #'k inst)] + [(k assembler) (datum->syntax #'k asm)]))))))))) + +(define-syntax define-reserved-registers + (lambda (x) + (syntax-case x () + [(_ [regid alias ... callee-save? mdinfo type] ...) + (syntax-case #'(regid ...) (%tc %sfp) [(%tc %sfp . others) #t] [_ #f]) + #'(begin + (begin + (define-once regid (make-reg 'regid 'mdinfo (tc-disp regid) callee-save? 'type)) + (module (alias ...) (define x regid) (define alias x) ...)) + ...)]))) + +(define-syntax define-register-aliases + (syntax-rules () + [(_ regid reg-alias ...) (begin (define reg-alias regid) ...)])) + +(define-syntax define-allocable-registers + (lambda (x) + (assert (fx<= (constant asm-arg-reg-cnt) (constant asm-arg-reg-max))) + (syntax-case x () + [(_ regvec arg-registers extra-registers extra-fpregisters make-reg-spillinfo + [regid reg-alias ... callee-save? mdinfo type] ...) + (with-syntax ([((tc-disp ...) (arg-regid ...) (extra-regid ...) (extra-fpregid ...)) + (syntax-case #'([regid type] ...) (%ac0 %xp %ts %td uptr) + [([%ac0 _] [%xp _] [%ts _] [%td _] [other other-type] ...) + (let f ([other* #'(other ...)] + [other-type* #'(other-type ...)] + [rtc-disp* '()] + [arg-offset (constant tc-arg-regs-disp)] + [fp-offset (constant tc-fpregs-disp)] + [rextra* '()] + [rfpextra* '()]) + (if (null? other*) + (cond + [(not (fx= (length rextra*) (constant asm-arg-reg-max))) + (syntax-error x (format "asm-arg-reg-max extra registers are not specified ~s" (syntax->datum rextra*)))] + [(not (fx= (length rfpextra*) (constant asm-fpreg-max))) + (syntax-error x (format "asm-fpreg-max extra registers are not specified ~s" (syntax->datum rfpextra*)))] + [else + (let ([extra* (reverse rextra*)] + [fpextra* (reverse rfpextra*)]) + (list + (list* + (constant tc-ac0-disp) + (constant tc-xp-disp) + (constant tc-ts-disp) + (constant tc-td-disp) + (reverse rtc-disp*)) + (list-head extra* (constant asm-arg-reg-cnt)) + (list-tail extra* (constant asm-arg-reg-cnt)) + fpextra*))]) + (let ([other (car other*)]) + (if (memq (syntax->datum other) '(%ac1 %yp %cp %ret)) + (f (cdr other*) (cdr other-type*) (cons #`(tc-disp #,other) rtc-disp*) + 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 (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")])] + [(reg-spillinfo-index ...) (iota (length #'(regid ...)))]) + #'(begin + (define-once regid (let ([r (make-reg 'regid 'mdinfo tc-disp callee-save? 'type)]) + (var-spillinfo-redirect! r reg-spillinfo-index) + r)) + ... + (define-register-aliases regid reg-alias ...) ... + (define regvec (vector regid ...)) + (define arg-registers (list arg-regid ...)) + (define extra-registers (list extra-regid ...)) + (define extra-fpregisters (list extra-fpregid ...)) + (define (make-reg-spillinfo) + (vector (make-redirect-var 'regid) + ...))))]))) + +(define-syntax define-machine-dependent-registers + (lambda (x) + (syntax-case x () + [(_ [regid alias ... callee-save? mdinfo type] ...) + #'(begin + (begin + (define-once regid (make-reg 'regid 'mdinfo #f callee-save? 'type)) + (module (alias ...) (define x regid) (define alias x) ...)) + ...)]))) + +(define-syntax define-registers + (lambda (x) + (syntax-case x (reserved allocable machine-dependent) + [(k (reserved [rreg rreg-alias ... rreg-callee-save? rreg-mdinfo rreg-type] ...) + (allocable [areg areg-alias ... areg-callee-save? areg-mdinfo areg-type] ...) + (machine-depdendent [mdreg mdreg-alias ... mdreg-callee-save? mdreg-mdinfo mdreg-type] ...)) + (with-implicit (k regvec arg-registers extra-registers extra-fpregisters real-register? make-reg-spillinfo) + #`(begin + (define-reserved-registers [rreg rreg-alias ... rreg-callee-save? rreg-mdinfo rreg-type] ...) + (define-allocable-registers regvec arg-registers extra-registers extra-fpregisters make-reg-spillinfo + [areg areg-alias ... areg-callee-save? areg-mdinfo areg-type] ...) + (define-machine-dependent-registers [mdreg mdreg-alias ... mdreg-callee-save? mdreg-mdinfo mdreg-type] ...) + (define-syntax real-register? + (with-syntax ([real-reg* #''(rreg ... rreg-alias ... ... areg ... areg-alias ... ... mdreg ... mdreg-alias ... ...)]) + (syntax-rules () + [(_ e) (memq e real-reg*)])))))]))) + +(architecture registers) + +; pseudo register used for mref's with no actual index +(define-once %zero (make-reg 'zero #f #f #f #f)) + +;; define %ref-ret to be sfp[0] on machines w/no ret register +;; +;; The ret register, if any, is used to pass a return address to a +;; function. All functions currently stash the ret register in +;; sfp[0] and return to sfp[0] instead of the ret register, so the +;; register doesn't have to be saved and restored for non-tail +;; calls --- so use sfp[0] instead of the ret registerr to refer +;; to the current call's return address. (A leaf procedure could +;; do better, but doesn't currently.) +(define-syntax %ref-ret + (lambda (x) + (meta-cond + [(real-register? '%ret) #'%ret] + [else (with-syntax ([%mref (datum->syntax x '%mref)]) + #'(%mref ,%sfp 0))]))) + +(define-syntax reg-cons* + (lambda (x) + (syntax-case x () + [(_ ?reg ... ?reg*) + (fold-right + (lambda (reg reg*) + (cond + [(real-register? (syntax->datum reg)) + #`(cons #,reg #,reg*)] + [else reg*])) + #'?reg* #'(?reg ...))]))) + +(define-syntax reg-list + (syntax-rules () + [(_ ?reg ...) (reg-cons* ?reg ... '())])) + +(define-syntax with-saved-ret-reg + (lambda (x) + (syntax-case x () + [(k ?e) + (if (real-register? '%ret) + (with-implicit (k %seq %mref) + #'(%seq + (set! ,(%mref ,%sfp 0) ,%ret) + ,?e + (set! ,%ret ,(%mref ,%sfp 0)))) + #'?e)]))) diff --git a/src/ChezScheme/s/ppc32.ss b/src/ChezScheme/s/ppc32.ss index 82bf687983..c2a7f4336b 100644 --- a/src/ChezScheme/s/ppc32.ss +++ b/src/ChezScheme/s/ppc32.ss @@ -674,14 +674,14 @@ (k x u)))]))))) ;; compiler implements init-lock! and unlock! as 32-bit store of zero (define-instruction pred (lock!) - [(op (x ur) (y ur) (w shifted-integer16 integer16)) + [(op (x ur) (y ur) (w imm-constant)) (lea->reg x y w (lambda (base index) (values '() `(asm ,info-cc-eq ,(asm-lock info-cc-eq) ,base ,index))))]) (define-instruction effect (locked-incr! locked-decr!) - [(op (x ur) (y ur) (w shifted-integer16 integer16)) + [(op (x ur) (y ur) (w imm-constant)) (lea->reg x y w (lambda (base index) (let ([u (make-tmp 'u)]) @@ -689,7 +689,7 @@ `(set! ,(make-live-info) ,u (asm ,null-info ,asm-kill)) `(asm ,null-info ,(asm-lock+/- op) ,base ,index ,u)))))]) (define-instruction effect (cas) - [(op (x ur) (y ur) (w shifted-integer16 integer16) (old ur) (new ur)) + [(op (x ur) (y ur) (w imm-constant) (old ur) (new ur)) (lea->reg x y w (lambda (base index) (let ([u (make-tmp 'u)]) diff --git a/src/ChezScheme/s/ppc32le.def b/src/ChezScheme/s/ppc32le.def deleted file mode 100644 index 7417c64796..0000000000 --- a/src/ChezScheme/s/ppc32le.def +++ /dev/null @@ -1,19 +0,0 @@ -;;; ppc32le.def -;;; 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. - -(define-constant machine-type (constant machine-type-ppc32le)) -(features iconv expeditor) -(include "ppc32.def") -(include "default.def") diff --git a/src/ChezScheme/s/ppc32nb.def b/src/ChezScheme/s/ppc32nb.def new file mode 100644 index 0000000000..b0c24e3b6d --- /dev/null +++ b/src/ChezScheme/s/ppc32nb.def @@ -0,0 +1,5 @@ +(define-constant machine-type (constant machine-type-ppc32nb)) +(features iconv expeditor) +(define-constant time-t-bits 64) +(include "ppc32.def") +(include "default.def") diff --git a/src/ChezScheme/s/primdata.ss b/src/ChezScheme/s/primdata.ss index 2c65a56cbf..0a49a56280 100644 --- a/src/ChezScheme/s/primdata.ss +++ b/src/ChezScheme/s/primdata.ss @@ -257,7 +257,7 @@ (cons [sig [(ptr ptr) -> (#1=(ptr . ptr))]] [flags unrestricted alloc ieee r5rs]) ; c..r non-alphabetic so marks come before references (car [sig [(#1#) -> (ptr)]] [flags mifoldable discard cp02 safeongoodargs ieee r5rs]) - (cdr [sig [(#1#) -> (ptr)]] [flags mifoldable discard cp02 safeongoodargs ieee r5rs]) + (cdr [sig [(#1#) -> (ptr)]] [flags mifoldable discard cp02 cptypes2 safeongoodargs ieee r5rs]) (caar [sig [(#2=(#1# . ptr)) -> (ptr)]] [flags mifoldable discard ieee r5rs]) (cdar [sig [(#2#) -> (ptr)]] [flags mifoldable discard ieee r5rs]) (cadr [sig [(#3=(ptr . #1#)) -> (ptr)]] [flags mifoldable discard ieee r5rs]) @@ -329,7 +329,7 @@ (vector [sig [(ptr ...) -> (vector)]] [flags unrestricted alloc ieee r5rs cp02]) (vector-length [sig [(vector) -> (length)]] [flags pure true ieee r5rs mifoldable discard safeongoodargs]) (vector-ref [sig [(vector sub-index) -> (ptr)]] [flags ieee r5rs mifoldable discard cp02]) - (vector-set! [sig [(vector sub-index ptr) -> (void)]] [flags true ieee r5rs]) + (vector-set! [sig [(vector sub-index ptr) -> (void)]] [flags true ieee r5rs cptypes2]) (vector->list [sig [(vector) -> (list)]] [flags alloc safeongoodargs ieee r5rs]) (list->vector [sig [(list) -> (vector)]] [flags alloc ieee r5rs]) (vector-fill! [sig [(vector ptr) -> (void)]] [flags true ieee r5rs]) @@ -604,7 +604,7 @@ (get-char [sig [(textual-input-port) -> (eof/char)]] [flags true]) (lookahead-char [sig [(textual-input-port) -> (eof/char)]] [flags true]) (get-string-n [sig [(textual-input-port length) -> (eof/string)]] [flags true]) - (get-string-n! [sig [(textual-input-port string length length) -> (èof/length)]] [flags true]) + (get-string-n! [sig [(textual-input-port string length length) -> (eof/length)]] [flags true]) (get-string-all [sig [(textual-input-port) -> (eof/string)]] [flags true]) (get-line [sig [(textual-input-port) -> (eof/string)]] [flags true]) (get-datum [sig [(textual-input-port) -> (ptr)]] [flags]) @@ -710,8 +710,8 @@ ) (define-symbol-flags* ([libraries (rnrs mutable-pairs)] [flags primitive proc]) - (set-car! [sig [((ptr . ptr) ptr) -> (void)]] [flags true ieee r5rs]) - (set-cdr! [sig [((ptr . ptr) ptr) -> (void)]] [flags true ieee r5rs]) + (set-car! [sig [((ptr . ptr) ptr) -> (void)]] [flags true ieee r5rs cptypes2]) + (set-cdr! [sig [((ptr . ptr) ptr) -> (void)]] [flags true ieee r5rs cptypes2]) ) (define-symbol-flags* ([libraries (rnrs mutable-strings)] [flags primitive proc]) @@ -799,7 +799,7 @@ (free-identifier=? [sig [(identifier identifier) -> (boolean)]] [flags pure mifoldable discard cp03]) (syntax->datum [sig [(ptr) -> (ptr)]] [flags pure unrestricted mifoldable discard]) (datum->syntax [sig [(identifier ptr) -> (syntax)]] [flags pure mifoldable discard true]) - (generate-temporaries [sig [(list) -> (list)]] [flags alloc]) + (generate-temporaries [sig [(ptr) -> (list)]] [flags alloc]) ; the argument can be a list or a syntax with a list or an annotation (syntax-violation [sig [(maybe-who string ptr) (maybe-who string ptr ptr) -> (bottom)]] [flags abort-op]) ) @@ -854,13 +854,13 @@ (add-duration (sig [(time time) -> (time)]) [flags alloc]) (add-duration! (sig [(time time) -> (time)]) [flags alloc]) (current-date [sig [() (sub-fixnum) -> (date)]] [flags alloc]) - (current-time [sig [() (sub-fixnum) -> (time)]] [flags alloc]) + (current-time [sig [() (sub-symbol) -> (time)]] [flags alloc]) (date-day [sig [(date) -> (fixnum)]] [flags pure mifoldable discard true]) (date? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) (date-hour [sig [(date) -> (fixnum)]] [flags pure mifoldable discard true]) (date-minute [sig [(date) -> (fixnum)]] [flags pure mifoldable discard true]) (date-month [sig [(date) -> (fixnum)]] [flags pure mifoldable discard true]) - (date-nanosecond [sig [(date) -> (fixnum)]] [flags pure mifoldable discard true]) + (date-nanosecond [sig [(date) -> (uint)]] [flags pure mifoldable discard true]) (date-second [sig [(date) -> (fixnum)]] [flags pure mifoldable discard true]) (date-week-day [sig [(date) -> (fixnum)]] [flags pure mifoldable discard true]) (date-year-day [sig [(date) -> (fixnum)]] [flags pure mifoldable discard true]) @@ -869,10 +869,10 @@ (date-zone-offset [sig [(date) -> (fixnum)]] [flags pure mifoldable discard true]) (date-zone-name [sig [(date) -> (ptr)]] [flags pure mifoldable discard]) (date->time-utc [sig [(date) -> (time-utc)]] [flags alloc]) - (make-date [sig [(sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum) -> (date)] - [(sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-fixnum) -> (date)]] + (make-date [sig [(sub-uint sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum) -> (date)] + [(sub-uint sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-ufixnum sub-fixnum) -> (date)]] [flags alloc]) - (make-time [sig [(sub-symbol sub-ufixnum exact-integer) -> (time)]] [flags alloc]) + (make-time [sig [(sub-symbol sub-uint exact-integer) -> (time)]] [flags alloc]) (set-time-nanosecond! [sig [(time sub-uint) -> (void)]] [flags true]) (set-time-second! [sig [(time exact-integer) -> (void)]] [flags true]) (set-time-type! [sig [(time sub-symbol) -> (void)]] [flags true]) @@ -1146,6 +1146,7 @@ (apropos [sig [(sub-ptr) (sub-ptr environment) -> (void)]] [flags true]) (apropos-list [sig [(sub-ptr) (sub-ptr environment) -> (list)]] [flags alloc]) (ash [sig [(sint sint) -> (sint)]] [flags arith-op discard cp02 cp03]) ; can take too long to fold + (assert-unreachable [sig [() -> (bottom)]] [flags abort-op]) (assertion-violationf [sig [(maybe-who string sub-ptr ...) -> (bottom)]] [flags abort-op]) ; 2nd arg is format string (asinh [sig [(number) -> (number)]] [flags arith-op mifoldable discard]) (atanh [sig [(number) -> (number)]] [flags arith-op mifoldable discard]) @@ -1163,7 +1164,7 @@ (block-write [sig [(textual-output-port string) (textual-output-port string length) -> (void)]] [flags true]) (box [sig [(ptr) -> (box)]] [flags unrestricted alloc]) (box? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) - (box-cas! [sig [(box ptr ptr) -> (boolean)]] [flags]) + (box-cas! [sig [(box ptr ptr) -> (boolean)]] [flags cptypes2]) (box-immobile [sig [(ptr) -> (box)]] [flags unrestricted alloc]) (box-immutable [sig [(ptr) -> (box)]] [flags unrestricted alloc]) (break [sig [(ptr ...) -> (ptr ...)]] [flags]) @@ -1175,6 +1176,9 @@ (bytevector->s8-list [sig [(bytevector) -> (list)]] [flags alloc]) (bytevector-truncate! [sig [(bytevector length) -> (bytevector)]] [flags true]) (bytevector->immutable-bytevector [sig [(bytevector) -> (bytevector)]] [flags alloc]) + (bytevector-reference-ref [sig [(sub-bytevector sub-index) -> (ptr)]] [flags mifoldable discard]) + (bytevector-reference*-ref [sig [(sub-bytevector sub-index) -> (ptr)]] [flags mifoldable discard]) + (bytevector-reference-set! [sig [(sub-bytevector sub-index sub-ptr) -> (void)]] [flags true]) (bytevector-s24-ref [sig [(bytevector sub-index symbol) -> (s24)]] [flags true mifoldable discard]) (bytevector-s24-set! [sig [(bytevector sub-index s24 symbol) -> (void)]] [flags true]) (bytevector-s40-ref [sig [(bytevector sub-index symbol) -> (s40)]] [flags true mifoldable discard]) @@ -1194,12 +1198,12 @@ (bytevector-compress [sig [(ptr) -> (ptr)]] [flags]) (bytevector-uncompress [sig [(ptr) -> (ptr)]] [flags]) (call/1cc [sig [(procedure) -> (ptr ...)]] [flags]) - (call-consuming-continuation-attachment [sig [(ptr procedure) -> (ptr ...)]] [flags]) - (call-getting-continuation-attachment [sig [(ptr procedure) -> (ptr ...)]] [flags]) + (call-consuming-continuation-attachment [sig [(ptr procedure) -> (ptr ...)]] [flags cptypes2x]) + (call-getting-continuation-attachment [sig [(ptr procedure) -> (ptr ...)]] [flags cptypes2x]) (call-in-continuation [sig [(ptr procedure) -> (ptr ...)] [(ptr ptr procedure) -> (ptr ...)]] [flags]) (call-with-input-file [sig [(pathname procedure) (pathname procedure sub-ptr) -> (ptr ...)]] [flags ieee r5rs]) ; has options argument (call-with-output-file [sig [(pathname procedure) (pathname procedure sub-ptr) -> (ptr ...)]] [flags ieee r5rs]) ; has options argument - (call-setting-continuation-attachment [sig [(ptr procedure) -> (ptr ...)]] [flags]) + (call-setting-continuation-attachment [sig [(ptr procedure) -> (ptr ...)]] [flags cptypes2x]) (cfl* [sig [(cflonum ...) -> (cflonum)]] [flags arith-op partial-folder safeongoodargs]) (cfl+ [sig [(cflonum ...) -> (cflonum)]] [flags arith-op partial-folder safeongoodargs]) (cfl- [sig [(cflonum cflonum ...) -> (cflonum)]] [flags arith-op partial-folder safeongoodargs]) @@ -1238,13 +1242,13 @@ (compile-script [sig [(pathname) (pathname pathname) (pathname pathname sub-symbol) -> (void)]] [flags true]) (compile-time-value? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) (compile-time-value-value [sig [(compile-time-value) -> (ptr)]] [flags pure mifoldable discard]) - (compile-to-file [sig [(list pathname) (list pathname maybe-sfd) -> (void/list)]] [flags true]) + (compile-to-file [sig [(list pathname) (list pathname maybe-sfd) (list pathname maybe-sfd boolean) -> (void/list)]] [flags true]) (compile-to-port [sig [(list binary-output-port) (list binary-output-port maybe-sfd) (list binary-output-port maybe-sfd maybe-binary-output-port) (list binary-output-port maybe-sfd maybe-binary-output-port maybe-textual-output-port) (list binary-output-port maybe-sfd maybe-binary-output-port maybe-textual-output-port sub-symbol) (list binary-output-port maybe-sfd maybe-binary-output-port maybe-textual-output-port sub-symbol maybe-binary-output-port) (list binary-output-port maybe-sfd maybe-binary-output-port maybe-textual-output-port sub-symbol maybe-binary-output-port ptr) (list binary-output-port maybe-sfd maybe-binary-output-port maybe-textual-output-port sub-symbol maybe-binary-output-port ptr ptr) -> (void/list)]] [flags true]) (compile-whole-program [sig [(string string) (string string ptr) -> (void)]] [flags]) (compile-whole-library [sig [(string string) -> (void)]] [flags]) (compute-composition [sig [(ptr) -> (list)] [(ptr sub-ufixnum) -> (list)]] [flags alloc]) (compute-size [sig [(ptr) -> (uint)] [(ptr sub-ufixnum) -> (uint)]] [flags alloc]) - (compute-size-increments [sig [(list) -> (list)] [(list sub-ufixnum) -> (list)]] [flags alloc]) + (compute-size-increments [sig [(list) -> (list)] [(list ptr) -> (list)]] [flags alloc]) ; the second argument is ufixnum or 'static (concatenate-object-files [sig [(pathname pathname pathname ...) -> (void)]] [flags true]) (condition-broadcast [feature pthreads] [sig [(condition-object) -> (void)]] [flags true]) (condition-continuation [sig [(continuation-condition) -> (ptr)]] [flags pure mifoldable discard]) @@ -1509,6 +1513,8 @@ (make-pseudo-random-generator [sig [() -> (pseudo-random-generator)]] [flags true]) (make-record-type [sig [(sub-ptr sub-list) (maybe-rtd sub-ptr sub-list) -> (rtd)]] [flags pure alloc cp02]) (make-record-type-descriptor* [sig [(symbol maybe-rtd maybe-symbol ptr ptr ufixnum exact-integer) -> (rtd)]] [flags pure alloc cp02]) + (make-reference-bytevector [sig [(length) -> (bytevector)]] [flags alloc]) + (make-immobile-reference-bytevector [sig [(length) -> (bytevector)]] [flags alloc]) (make-source-condition [sig [(ptr) -> (condition)]] [flags pure unrestricted mifoldable discard]) (make-source-file-descriptor [sig [(ptr binary-input-port) (ptr binary-input-port ptr) -> (sfd)]] [flags true]) (make-source-object [sig [(sfd uint uint) (sfd uint uint nzuint nzuint) -> (source-object)]] [flags pure true mifoldable discard]) @@ -1543,6 +1549,7 @@ (number->string [sig [(number) (number sub-ufixnum) (number sub-ufixnum sub-ufixnum) -> (string)]] [flags alloc]) ; radix not restricted to 2, 4, 8, 16 (object-backreferences [sig [() -> (list)]] [flags alloc]) (object-counts [sig [() -> (list)]] [flags alloc]) + (object->reference-address [sig [(ptr) -> (uint)]] [flags]) (oblist [sig [() -> (list)]] [flags alloc]) (open-fd-input-port [sig [(sub-ufixnum) (sub-ufixnum sub-symbol) (sub-ufixnum sub-symbol maybe-transcoder) -> (input-port)]] [flags true]) (open-fd-input/output-port [sig [(sub-ufixnum) (sub-ufixnum sub-symbol) (sub-ufixnum sub-symbol maybe-transcoder) -> (input/output-port)]] [flags true]) @@ -1622,12 +1629,16 @@ (record-constructor-descriptor? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard cp02]) (record-equal-procedure [sig [(record record) -> (maybe-procedure)]] [flags discard]) (record-hash-procedure [sig [(record) -> (maybe-procedure)]] [flags discard]) + (record-instance? [sig [(record rtd) -> (boolean)]] [flags pure mifoldable discard cp02 cptypes2]) (record-reader [sig [(sub-ptr) -> (ptr)] [(sub-ptr sub-ptr) -> (void)]] [flags]) (record-type-equal-procedure [sig [(rtd) -> (maybe-procedure)] [(rtd maybe-procedure) -> (void)]] [flags]) (record-type-hash-procedure [sig [(rtd) -> (maybe-procedure)] [(rtd maybe-procedure) -> (void)]] [flags]) (record-type-field-indices [sig [(rtd) -> (vector)]] [flags]) (record-type-named-fields? [sig [(rtd) -> (boolean)]] [flags]) (record-writer [sig [(rtd) -> (maybe-procedure)] [(rtd maybe-procedure) -> (void)]] [flags]) + (reference-address->object [sig [(sub-uint) -> (ptr)]] [flags]) + (reference*-address->object [sig [(sub-uint) -> (ptr)]] [flags]) + (reference-bytevector? [sig [(ptr) -> (boolean)]] [flags pure mifoldable discard]) (register-signal-handler [sig [(sint procedure) -> (void)]] [flags]) (remove-foreign-entry [sig [(string) -> (void)]] [flags true]) (remove-hash-table! [sig [(old-hash-table ptr) -> (void)]] [flags true]) @@ -1652,7 +1663,7 @@ (set-binary-port-output-buffer! [sig [(binary-output-port bytevector) -> (void)]] [flags true]) (set-binary-port-output-index! [sig [(binary-output-port sub-index) -> (void)]] [flags true]) (set-binary-port-output-size! [sig [(binary-output-port sub-length) -> (void)]] [flags true]) - (set-box! [sig [(box ptr) -> (void)]] [flags true]) + (set-box! [sig [(box ptr) -> (void)]] [flags true cptypes2]) (set-phantom-bytevector-length! [sig [(phantom-bytevector uptr) -> (void)]] [flags true]) (set-port-bol! [sig [(textual-output-port ptr) -> (void)]] [flags true]) (set-port-eof! [sig [(input-port ptr) -> (void)]] [flags true]) @@ -1804,7 +1815,7 @@ (utf-16-codec [sig [() -> (codec)] [(sub-symbol) -> (codec)]] [flags pure true]) ; has optional eness argument (utf-16le-codec [sig [() -> (codec)]] [flags pure unrestricted true]) (utf-16be-codec [sig [() -> (codec)]] [flags pure unrestricted true]) - (vector-cas! [sig [(vector sub-index ptr ptr) -> (boolean)]] [flags]) + (vector-cas! [sig [(vector sub-index ptr ptr) -> (boolean)]] [flags cptypes2]) (vector-copy [sig [(vector) -> (vector)]] [flags alloc safeongoodargs]) (vector->immutable-vector [sig [(vector) -> (vector)]] [flags alloc safeongoodargs]) (vector->pseudo-random-generator [sig [(vector) -> (pseudo-random-generator)]] [flags]) @@ -1963,6 +1974,7 @@ ($filter-conv [flags single-valued]) ($filter-foreign-type [flags single-valued]) ($fixed-path? [sig [(string) -> (boolean)]] [flags pure safeongoodargs]) + ($fixmediate [sig [(ptr) -> (ptr)]] [flags pure discard]) ($flvector-ref-check? [sig [(ptr ptr) -> (boolean)]] [flags unrestricted pure]) ($flvector-set!-check? [sig [(ptr ptr) -> (boolean)]] [flags unrestricted discard]) ($<= [flags single-valued]) @@ -2144,10 +2156,10 @@ ($ftype-guardian-oops [flags]) ($ftype-pointer? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable]) ($fxaddress [flags single-valued unrestricted alloc]) - ($fx-? [sig [(maybe-fixnum maybe-fixnum) -> (maybe-fixnum)]] [flags pure]) ; not boolean + ($fx-? [sig [(ptr ptr) -> (maybe-fixnum)]] [flags unrestricted pure]) ; not boolean ($fx/ [flags single-valued]) ($fx* [flags single-valued]) - ($fx+? [sig [(maybe-fixnum maybe-fixnum) -> (maybe-fixnum)]] [flags pure]) ; not boolean + ($fx+? [sig [(ptr ptr) -> (maybe-fixnum)]] [flags unrestricted pure]) ; not boolean ($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]) @@ -2164,7 +2176,7 @@ ($hashtable-veclen [flags discard]) ($ht-minlen [flags single-valued discard]) ($ht-veclen [flags single-valued discard]) - ($immediate? [sig [(ptr) -> (boolean)]] [flags pure unrestricted]) ; no mifoldable due to fixnum + ($immediate? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable]) ($impoops [flags abort-op]) ($import-library [flags single-valued]) ($inexactnum? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable]) @@ -2271,6 +2283,8 @@ ($np-last-pass [flags single-valued]) ($np-reset-timers! [flags single-valued]) ($np-tracer [flags single-valued]) + ($np-expand-primitives [flags single-valued]) + ($np-next-lambda-seqno [flags single-valued]) ($null-continuation [flags single-valued]) ($object-address [flags single-valued]) ($object-in-heap? [sig [(ptr) -> (boolean)]] [flags discard]) @@ -2311,12 +2325,14 @@ ($recompile-importer-path [flags single-valued]) ($record [flags single-valued cp02 cptypes2 unrestricted alloc]) ; first arg should be an rtd, but we don't check ($record? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable]) - ($record-cas! [sig [(record sub-index ptr ptr) -> (boolean)]] [flags single-valued]) + ($record-cas! [sig [(record sub-index ptr ptr) -> (boolean)]] [flags single-valued cptypes2]) ($record-equal-procedure [flags single-valued discard]) ($record-hash-procedure [flags single-valued discard]) ($record-oops [sig [(maybe-who sub-ptr rtd) -> (bottom)]] [flags abort-op]) ($record-ref [sig [(ptr sub-index) -> (ptr)]] [flags single-valued discard cp03]) - ($record-set! [sig [(ptr sub-index ptr) -> (void)]] [flags true]) + ($record-set! [sig [(ptr sub-index ptr) -> (void)]] [flags true cptypes2]) + ($record-type-act-sealed! [sig [(ptr) -> (void)]] [flags single-valued true]) + ($record-type-act-sealed? [sig [(ptr) -> (boolean)]] [flags single-valued]) ($record-type-descriptor [flags single-valued pure mifoldable discard true]) ($record-type-field-offsets [flags single-valued pure mifoldable discard true]) ($record-type-field-count [sig [(ptr) -> (fixnum)]] [flags single-valued pure mifoldable discard true]) @@ -2336,6 +2352,7 @@ ($sc-put-property! [flags single-valued]) ($script [flags single-valued]) ($sealed-record? [sig [(ptr rtd) -> (boolean)]] [flags pure mifoldable cptypes2]) ; first argument may be not a record + ($sealed-record-instance? [sig [(record rtd) -> (boolean)]] [flags pure mifoldable cptypes2]) ($seginfo [flags single-valued]) ($seginfo-generation [flags single-valued]) ($seginfo-space [flags single-valued]) diff --git a/src/ChezScheme/s/prims.ss b/src/ChezScheme/s/prims.ss index bfde6f4ed7..eecb0fecb3 100644 --- a/src/ChezScheme/s/prims.ss +++ b/src/ChezScheme/s/prims.ss @@ -76,6 +76,57 @@ [else (lambda (p) (ephemeron-pair? p))])) +(define reference-bytevector? + (constant-case architecture + [(pb) + (foreign-procedure "(cs)s_reference_bytevectorp" (scheme-object) scheme-object)] + [else + (lambda (p) (reference-bytevector? p))])) + +(define-who bytevector-reference-ref + (lambda (bv i) + (unless (reference-bytevector? bv) ($oops who "~s is not a reference bytevector" bv)) + (unless (and (fixnum? i) + (not ($fxu< (fx- (bytevector-length bv) (fx- (constant ptr-bytes) 1)) i))) + ($oops who "invalid index ~s for ~s" i bv)) + (bytevector-reference-ref bv i))) + +(define-who bytevector-reference*-ref + (let ([ref (foreign-procedure "(cs)s_bytevector_reference_star_ref" (ptr uptr) ptr)]) + (lambda (bv i) + (unless (reference-bytevector? bv) ($oops who "~s is not a reference bytevector" bv)) + (unless (and (fixnum? i) + (not ($fxu< (fx- (bytevector-length bv) (fx- (constant ptr-bytes) 1)) i))) + ($oops who "invalid index ~s for ~s" i bv)) + (ref bv i)))) + +(define-who bytevector-reference-set! + (lambda (bv i val) + (unless (reference-bytevector? bv) ($oops who "~s is not a reference bytevector" bv)) + (unless (and (fixnum? i) + (not ($fxu< (fx- (bytevector-length bv) (fx- (constant ptr-bytes) 1)) i))) + ($oops who "invalid index ~s for ~s" i bv)) + (bytevector-reference-set! bv i val))) + +(define-who object->reference-address + (lambda (v) + (object->reference-address v))) + +(define-who reference-address->object + (lambda (a) + (unless (and (or (fixnum? a) (bignum? a)) + (< -1 a (bitwise-arithmetic-shift 1 (constant ptr-bits)))) + ($oops who "invalid address ~s" a)) + (reference-address->object a))) + +(define-who reference*-address->object + (let ([ref->obj (foreign-procedure "(cs)s_reference_star_address_object" (uptr) ptr)]) + (lambda (a) + (unless (and (or (fixnum? a) (bignum? a)) + (< -1 a (bitwise-arithmetic-shift 1 (constant ptr-bits)))) + ($oops who "invalid address ~s" a)) + (ref->obj a)))) + (define $split-continuation (foreign-procedure "(cs)single_continuation" (scheme-object iptr) @@ -342,6 +393,20 @@ ($oops who "~s is not a valid vector length" n)) ($make-immobile-vector n 0)]))) +(define-who make-reference-bytevector + (let ([$make-reference-bytevector (foreign-procedure "(cs)s_make_reference_bytevector" (uptr) ptr)]) + (lambda (n) + (unless (and (fixnum? n) (not ($fxu< (constant maximum-bytevector-length) n))) + ($oops who "~s is not a valid bytevector length" n)) + ($make-reference-bytevector n)))) + +(define-who make-immobile-reference-bytevector + (let ([$make-immobile-reference-bytevector (foreign-procedure "(cs)s_make_immobile_reference_bytevector" (uptr) ptr)]) + (lambda (n) + (unless (and (fixnum? n) (not ($fxu< (constant maximum-bytevector-length) n))) + ($oops who "~s is not a valid bytevector length" n)) + ($make-immobile-reference-bytevector n)))) + (define $make-eqhash-vector (case-lambda [(n) @@ -434,12 +499,16 @@ (#2%apply f args))) ;; Implies no-inline, and in unsafe mode, asserts that the -;; application will not return +;; application will not return and that it does not inspect/change +;; the immediate continuation attachment (so it can be moved to a +;; more-tail position) (define $app/no-return (lambda (f . args) (#2%apply f args))) ;; In unsafe mode, asserts that the applicaiton returns a single value +;; and that it does not inspect/change the immediate continuation +;; attachment (so it can be moved to a more-tail position) (define $app/value (lambda (f . args) (#2%apply f args))) @@ -1587,6 +1656,14 @@ (display-string s)])) (define $immediate? (lambda (x) ($immediate? x))) + +;; Used to communicate fixmediateness from cptypes to cpnanopass: +(define-who $fixmediate + (lambda (x) + (if (fixmediate? x) + x + ($oops who "~s is not a fixnum or immediate value" x)))) + (define $inexactnum? (lambda (x) ($inexactnum? x))) (define $inexactnum-real-part @@ -1875,8 +1952,8 @@ (condition-guardian c) c))) -(define mutex-guardian (make-guardian)) -(define condition-guardian (make-guardian)) +(define mutex-guardian (make-guardian #t)) +(define condition-guardian (make-guardian #t)) (set! fork-thread (lambda (t) @@ -2313,8 +2390,22 @@ ($oops who "~s is not a record type descriptor" rtd)) (#3%$sealed-record? x rtd)) +(define-who ($sealed-record-instance? x rtd) + (unless (record? x) + ($oops who "~s is not a record" x)) + (unless (record-type-descriptor? rtd) + ($oops who "~s is not a record type descriptor" rtd)) + (#3%$sealed-record-instance? x rtd)) + (define ($record? x) (#3%$record? x)) +(define-who (record-instance? x rtd) + (unless (record? x) + ($oops who "~s is not a record" x)) + (unless (record-type-descriptor? rtd) + ($oops who "~s is not a record type descriptor" rtd)) + (#3%record-instance? x rtd)) + (define-who ($record-type-descriptor r) (unless ($record? r) ($oops who "~s is not a record" r)) (#3%$record-type-descriptor r)) diff --git a/src/ChezScheme/s/print.ss b/src/ChezScheme/s/print.ss index 1c20fad73d..baecb0fc10 100644 --- a/src/ChezScheme/s/print.ss +++ b/src/ChezScheme/s/print.ss @@ -95,7 +95,7 @@ (define hashable? (lambda (x) - (if ($immediate? x) + (if (fixmediate? x) (eq? x black-hole) (and ($object-in-heap? x) @@ -173,7 +173,9 @@ [(and ($record? x) (not (eq? x #!base-rtd))) (when (print-record) ((record-writer ($record-type-descriptor x)) x (bit-sink) - (lambda (x p) ; could check for p == (bit-sink) + (lambda (x p) + (unless (and (output-port? p) (textual-port? p)) + ($oops 'write "~s is not a textual output port" p)) (find-dupls x (decr lev) len))))] [(box? x) (find-dupls (unbox x) (decr lev) len)] [(eq? x black-hole) (find-dupls x (decr lev) len)])] @@ -201,7 +203,7 @@ (define cyclic? (lambda (x curlev lstlen) - (if ($immediate? x) + (if (fixmediate? x) (if (eq? x black-hole) (not lev) #f) (and ($object-in-heap? x) (cond @@ -215,7 +217,9 @@ (call/cc (lambda (k) ((record-writer ($record-type-descriptor x)) x (bit-sink) - (lambda (x p) ; could check for p == (bit-sink) + (lambda (x p) + (unless (and (output-port? p) (textual-port? p)) + ($oops 'write "~s is not a textual output port" p)) (if (cyclic? x (fx+ curlev 1) 0) (k #t)))) #f)))))] @@ -275,7 +279,7 @@ (constant cycle-node-max))]) (cond [(fx= xlev 0) (or (not lev) (fx> lev (constant cycle-node-max)))] - [($immediate? x) (if (eq? x black-hole) (not lev) #f)] + [(fixmediate? x) (if (eq? x black-hole) (not lev) #f)] [else (and ($object-in-heap? x) (cond @@ -308,7 +312,9 @@ (call/cc (lambda (k) ((record-writer ($record-type-descriptor x)) x (bit-sink) - (lambda (x p) ; could check for p == (bit-sink) + (lambda (x p) + (unless (and (output-port? p) (textual-port? p)) + ($oops 'write "~s is not a textual output port" p)) (if (down x (fx- xlev 1)) (k #t)))) #f)))] [(box? x) (down (unbox x) (fx- xlev 1))] @@ -316,7 +322,7 @@ (set! $make-graph-env (lambda (who x lev len) - (and (if ($immediate? x) + (and (if (fixmediate? x) (eq? x black-hole) (and ($object-in-heap? x) (or (pair? x) (vector? x) (stencil-vector? x) (box? x) (and ($record? x) (not (eq? x #!base-rtd)))))) @@ -628,7 +634,6 @@ floating point returns with (1 0 -1 ...). (cond [($immediate? x) (type-case x - [(fixnum?) (wrfixnum x r d? p)] [(null?) (display-string "()" p)] [(boolean?) (display-string (if x "#t" "#f") p)] [(char?) (if d? (write-char x p) (wrchar x p))] @@ -638,6 +643,7 @@ floating point returns with (1 0 -1 ...). [(void?) (display-string "#<void>" p)] [(black-hole?) (wrblack-hole x r lev len d? env p)] [else (display-string "#<garbage>" p)])] + [(fixnum? x) (wrfixnum x r d? p)] [($object-in-heap? x) (type-case x [(symbol?) @@ -706,7 +712,9 @@ floating point returns with (1 0 -1 ...). (if (limit? lev) (display-string "#[...]" p) ((record-writer ($record-type-descriptor x)) x p - (lambda (x p) ; could check for p == old p + (lambda (x p) + (unless (and (output-port? p) (textual-port? p)) + ($oops 'write "~s is not a textual output port" p)) (wr x r (decr lev) len d? env p)))) (let ([rtd ($record-type-descriptor x)]) (cond ; keep in sync with default-record-writer @@ -910,7 +918,7 @@ floating point returns with (1 0 -1 ...). [else (wrfixits (fx/ n r) r p) (write-char (digit->char (fxremainder n r)) p)])] - [(n r d p) + [(n r d p) ; add leading zeros as needed to ensure that `d` digits are printed (cond [(fx< n r) (do ([d d (fx- d 1)]) ((fx<= d 1)) (write-char #\0 p)) @@ -931,10 +939,14 @@ floating point returns with (1 0 -1 ...). (define wrbigits (let () - ; divide-and-conquer, treating bignum as two ``big base'' bigits - ; first base must be >= sqrt(n); base i+1 must be >= sqrt(base i) - ; last base must be <= most-positive-fixnum + ;; divide-and-conquer, treating bignum as two "big base" bigits, + ;; where a big base is a power of the radix; + ;; first base must be >= sqrt(n); base i+1 must be >= sqrt(base i); + ;; last base must be <= most-positive-fixnum (define largest-fixnum-big-base + ;; maps `radix` to `(cons big-base output-digits)` for a fixnum `big-base`, + ;; where `output-digits` is the same as `(log big-base radix)`; we need the + ;; number of digits in the big base to write out any needed leading `0`s (let ([v (make-vector 37)]) (do ([b 2 (fx+ b 1)]) ((fx= b 37) v) @@ -945,6 +957,9 @@ floating point returns with (1 0 -1 ...). (f bb^2 (* d 2)) (cons (cons bb d) '())))))))) (define (big-bases n r) + ;; get a list of spans of big-base digits, where each span's length is + ;; a power of two, so it corresponds to some number of squaring of + ;; the big base; pair that with the number of digits in the span (let ([iln/2 (bitwise-arithmetic-shift-right (+ (bitwise-length n) 1) 1)]) (let f ([bb* (vector-ref largest-fixnum-big-base r)]) (let ([bb (caar bb*)]) @@ -952,14 +967,27 @@ floating point returns with (1 0 -1 ...). bb* (f (cons (cons (* bb bb) (* (cdar bb*) 2)) bb*))))))) (lambda (n r p) - (let f ([n n] [d 0] [bb* (big-bases n r)]) - (cond - [(fixnum? n) (wrfixits n r d p)] - [(> (caar bb*) n) (f n d (cdr bb*))] - [else - (let ([hi.lo ($quotient-remainder n (caar bb*))]) - (f (car hi.lo) (- d (cdar bb*)) (cdr bb*)) - (f (cdr hi.lo) (cdar bb*) (cdr bb*)))]))))) + (case r + [(2 4 8 16 32) + ;; For powers of 2, we can stream through the binary representation + (let* ([big-base (car (vector-ref largest-fixnum-big-base r))] + [bits (bitwise-length (fx- (car big-base) 1))] + [digits (cdr big-base)]) + (let loop ([start (fx* bits (fx- (fxquotient (fx+ (bitwise-length n) (fx- bits 1)) bits) 1))] + [d 0]) + (wrfixits (bitwise-bit-field n start (fx+ start bits)) r d p) + (unless (fx= start 0) + (loop (fx- start bits) digits))))] + [else + ;; Use the general divide-and-conquer approach + (let f ([n n] [d 0] [bb* (big-bases n r)]) + (cond + [(fixnum? n) (wrfixits n r d p)] + [(> (caar bb*) n) (f n d (cdr bb*))] + [else + (let ([hi.lo ($quotient-remainder n (caar bb*))]) + (f (car hi.lo) (- d (cdar bb*)) (cdr bb*)) + (f (cdr hi.lo) (cdar bb*) (cdr bb*)))]))])))) (define wrradix (lambda (r p) diff --git a/src/ChezScheme/s/read.ss b/src/ChezScheme/s/read.ss index bd94ae714d..10733d15ef 100644 --- a/src/ChezScheme/s/read.ss +++ b/src/ChezScheme/s/read.ss @@ -439,8 +439,8 @@ (with-read-char c (state-case c [eof (with-unread-char c (xcall rd-eof-error "# prefix"))] - [(#\f #\F) (xcall rd-token-delimiter #f "boolean")] - [(#\t #\T) (xcall rd-token-delimiter #t "boolean")] + [(#\f #\F) (*state rd-token-boolean #f)] + [(#\t #\T) (*state rd-token-boolean #t)] [#\\ (*state rd-token-char)] [#\( (state-return vparen #f)] ;) for paren bouncer [#\' (state-return quote 'syntax)] @@ -476,6 +476,31 @@ [#\| (*state rd-token-block-comment 0)] [else (xcall rd-error #f #t "invalid sharp-sign prefix #~c" c)]))) +(define-state (rd-token-boolean x) + (with-peek-char c + (state-case c + [eof (state-return atomic x)] + [char-alphabetic? + ;; Trying to specify a R7RS boolean. + (let* ([s (if x "true" "false")] + [last-index (fx- (string-length s) 1)]) + (*state rd-token-boolean-rest x s 1 last-index))] + [else (*state rd-token-delimiter x "boolean")]))) + +(define-state (rd-token-boolean-rest x s i last-index) + (with-read-char c + (cond + [(eof-object? c) + ;; we ruled out a possible initial eof before, so it is always an error, here + (with-unread-char c (xcall rd-eof-error "boolean"))] + [(not (char-ci=? c (string-ref s i))) + (with-unread-char c + (xcall rd-error #f #t "invalid boolean #~a~c" (substring s 0 i) (char-downcase c)))] + [(fx= i last-index) + (nonstandard "alternative boolean") + (*state rd-token-delimiter x "boolean")] + [else (*state rd-token-boolean-rest x s (fx+ i 1) last-index)]))) + (define-state (rd-token-delimiter x what) (with-peek-char c (state-case c diff --git a/src/ChezScheme/s/record.ss b/src/ChezScheme/s/record.ss index 53bb7f2a39..c6686292f7 100644 --- a/src/ChezScheme/s/record.ss +++ b/src/ChezScheme/s/record.ss @@ -26,7 +26,8 @@ (let () (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-parent x) (let ([a (rtd-ancestry x)]) + (vector-ref a (fx- (vector-length a) (constant ancestry-parent-offset))))) (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))) @@ -554,8 +555,8 @@ (define ($mrt who base-rtd name parent uid flags fields mutability-mask extras) (include "layout.ss") (when parent - (when (record-type-sealed? parent) - ($oops who "cannot extend sealed record type ~s" parent)) + (when ($record-type-act-sealed? parent) + ($oops who "cannot extend sealed record type ~s as ~s" parent name)) (if (fixnum? fields) (unless (fixnum? (rtd-flds parent)) ($oops who "cannot make anonymous-field record type ~s from named-field parent record type ~s" name parent)) @@ -619,14 +620,15 @@ (unless (eq? (rtd-size rtd) size) (squawk "different size"))) rtd)] [else - (let* ([len (if (not parent) 0 (vector-length (rtd-ancestry parent)))] - [ancestry (make-vector (fx+ 1 len) parent)]) - (let loop ([i 0]) + (let* ([len (if (not parent) 1 (vector-length (rtd-ancestry parent)))] + [ancestry (make-vector (fx+ 1 len) #f)]) + (let loop ([i 1]) (unless (fx= i len) - (vector-set! ancestry (fx+ i 1) (vector-ref (rtd-ancestry parent) i)) + (vector-set! ancestry i (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)]) + (vector-set! ancestry len rtd) (with-tc-mutex ($sputprop uid '*rtd* rtd)) rtd))])))) @@ -899,6 +901,20 @@ ($oops 'record-type-sealed? "~s is not a record type descriptor" rtd)) (#3%record-type-sealed? rtd))) + (set-who! $record-type-act-sealed! + (lambda (rtd) + (unless (record-type-descriptor? rtd) + ($oops who "~s is not a record type descriptor" rtd)) + (unless ($record-type-act-sealed? rtd) + ($object-set! 'scheme-object rtd (constant record-type-flags-disp) + (fxior (rtd-flags rtd) (constant rtd-act-sealed)))))) + + (set-who! $record-type-act-sealed? + (lambda (rtd) + (unless (record-type-descriptor? rtd) + ($oops who "~s is not a record type descriptor" rtd)) + (#3%$record-type-act-sealed? rtd))) + (set! record-type-generative? (lambda (rtd) (unless (record-type-descriptor? rtd) diff --git a/src/ChezScheme/s/ta6fb.def b/src/ChezScheme/s/ta6fb.def deleted file mode 100644 index 741c288a9c..0000000000 --- a/src/ChezScheme/s/ta6fb.def +++ /dev/null @@ -1,19 +0,0 @@ -;;; ta6fb.def -;;; 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. - -(define-constant machine-type (constant machine-type-ta6fb)) -(features iconv expeditor pthreads) -(include "a6.def") -(include "default.def") diff --git a/src/ChezScheme/s/ta6le.def b/src/ChezScheme/s/ta6le.def deleted file mode 100644 index 53459a2f90..0000000000 --- a/src/ChezScheme/s/ta6le.def +++ /dev/null @@ -1,19 +0,0 @@ -;;; ta6le.def -;;; 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. - -(define-constant machine-type (constant machine-type-ta6le)) -(features iconv expeditor pthreads) -(include "a6.def") -(include "default.def") diff --git a/src/ChezScheme/s/ta6nb.def b/src/ChezScheme/s/ta6nb.def deleted file mode 100644 index c87428012b..0000000000 --- a/src/ChezScheme/s/ta6nb.def +++ /dev/null @@ -1,19 +0,0 @@ -;;; ta6nb.def -;;; 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. - -(define-constant machine-type (constant machine-type-ta6nb)) -(features iconv expeditor pthreads) -(include "a6.def") -(include "default.def") diff --git a/src/ChezScheme/s/ta6ob.def b/src/ChezScheme/s/ta6ob.def deleted file mode 100644 index 0db2867d05..0000000000 --- a/src/ChezScheme/s/ta6ob.def +++ /dev/null @@ -1,19 +0,0 @@ -;;; ta6ob.def -;;; 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. - -(define-constant machine-type (constant machine-type-ta6ob)) -(features iconv expeditor pthreads) -(include "a6.def") -(include "default.def") diff --git a/src/ChezScheme/s/ta6osx.def b/src/ChezScheme/s/ta6osx.def deleted file mode 100644 index 4ed30d64ed..0000000000 --- a/src/ChezScheme/s/ta6osx.def +++ /dev/null @@ -1,19 +0,0 @@ -;;; ta6osx.def -;;; 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. - -(define-constant machine-type (constant machine-type-ta6osx)) -(features iconv expeditor pthreads) -(include "a6.def") -(include "default.def") diff --git a/src/ChezScheme/s/ta6s2.def b/src/ChezScheme/s/ta6s2.def deleted file mode 100644 index 845029686d..0000000000 --- a/src/ChezScheme/s/ta6s2.def +++ /dev/null @@ -1,19 +0,0 @@ -;;; ta6s2.def -;;; 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. - -(define-constant machine-type (constant machine-type-ta6s2)) -(features iconv expeditor pthreads) -(include "a6.def") -(include "default.def") diff --git a/src/ChezScheme/s/tarm32le.def b/src/ChezScheme/s/tarm32le.def deleted file mode 100644 index 02dfc03992..0000000000 --- a/src/ChezScheme/s/tarm32le.def +++ /dev/null @@ -1,19 +0,0 @@ -;;; tarm32le.def -;;; 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. - -(define-constant machine-type (constant machine-type-tarm32le)) -(features iconv expeditor pthreads) -(include "arm32.def") -(include "default.def") diff --git a/src/ChezScheme/s/tarm64le.def b/src/ChezScheme/s/tarm64le.def deleted file mode 100644 index 9d02ddcf37..0000000000 --- a/src/ChezScheme/s/tarm64le.def +++ /dev/null @@ -1,6 +0,0 @@ -;;; tarm64le.def - -(define-constant machine-type (constant machine-type-tarm64le)) -(features iconv expeditor pthreads) -(include "arm64.def") -(include "default.def") diff --git a/src/ChezScheme/s/tarm64osx.def b/src/ChezScheme/s/tarm64osx.def deleted file mode 100644 index 07f98341c5..0000000000 --- a/src/ChezScheme/s/tarm64osx.def +++ /dev/null @@ -1,6 +0,0 @@ -;;; 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/ti3fb.def b/src/ChezScheme/s/ti3fb.def deleted file mode 100644 index 457f7d964d..0000000000 --- a/src/ChezScheme/s/ti3fb.def +++ /dev/null @@ -1,19 +0,0 @@ -;;; ti3fb.def -;;; 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. - -(define-constant machine-type (constant machine-type-ti3fb)) -(features iconv expeditor pthreads) -(include "i3.def") -(include "default.def") diff --git a/src/ChezScheme/s/ti3le.def b/src/ChezScheme/s/ti3le.def deleted file mode 100644 index 0326d2b11f..0000000000 --- a/src/ChezScheme/s/ti3le.def +++ /dev/null @@ -1,19 +0,0 @@ -;;; ti3le.def -;;; 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. - -(define-constant machine-type (constant machine-type-ti3le)) -(features iconv expeditor pthreads) -(include "i3.def") -(include "default.def") diff --git a/src/ChezScheme/s/ti3nb.def b/src/ChezScheme/s/ti3nb.def deleted file mode 100644 index c3b12ee830..0000000000 --- a/src/ChezScheme/s/ti3nb.def +++ /dev/null @@ -1,19 +0,0 @@ -;;; ti3nb.def -;;; 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. - -(define-constant machine-type (constant machine-type-ti3nb)) -(features iconv expeditor pthreads) -(include "i3.def") -(include "default.def") diff --git a/src/ChezScheme/s/ti3ob.def b/src/ChezScheme/s/ti3ob.def deleted file mode 100644 index 6e3d194e68..0000000000 --- a/src/ChezScheme/s/ti3ob.def +++ /dev/null @@ -1,19 +0,0 @@ -;;; ti3ob.def -;;; 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. - -(define-constant machine-type (constant machine-type-ti3ob)) -(features iconv expeditor pthreads) -(include "i3.def") -(include "default.def") diff --git a/src/ChezScheme/s/ti3osx.def b/src/ChezScheme/s/ti3osx.def deleted file mode 100644 index 99323c562b..0000000000 --- a/src/ChezScheme/s/ti3osx.def +++ /dev/null @@ -1,19 +0,0 @@ -;;; ti3osx.def -;;; 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. - -(define-constant machine-type (constant machine-type-ti3osx)) -(features iconv expeditor pthreads) -(include "i3.def") -(include "default.def") diff --git a/src/ChezScheme/s/ti3s2.def b/src/ChezScheme/s/ti3s2.def deleted file mode 100644 index 2f140c218d..0000000000 --- a/src/ChezScheme/s/ti3s2.def +++ /dev/null @@ -1,19 +0,0 @@ -;;; ti3s2.def -;;; 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. - -(define-constant machine-type (constant machine-type-ti3s2)) -(features iconv expeditor pthreads) -(include "i3.def") -(include "default.def") diff --git a/src/ChezScheme/s/tppc32le.def b/src/ChezScheme/s/tppc32le.def deleted file mode 100644 index 9a2d09df35..0000000000 --- a/src/ChezScheme/s/tppc32le.def +++ /dev/null @@ -1,19 +0,0 @@ -;;; tppc32le.def -;;; 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. - -(define-constant machine-type (constant machine-type-tppc32le)) -(features iconv expeditor pthreads) -(include "ppc32.def") -(include "default.def") diff --git a/src/ChezScheme/s/tppc32nb.def b/src/ChezScheme/s/tppc32nb.def new file mode 100644 index 0000000000..04c3767ad7 --- /dev/null +++ b/src/ChezScheme/s/tppc32nb.def @@ -0,0 +1,5 @@ +(define-constant machine-type (constant machine-type-tppc32nb)) +(features iconv expeditor pthreads) +(define-constant time-t-bits 64) +(include "ppc32.def") +(include "default.def") diff --git a/src/ChezScheme/s/tunix.def b/src/ChezScheme/s/tunix.def new file mode 100644 index 0000000000..87c03012cd --- /dev/null +++ b/src/ChezScheme/s/tunix.def @@ -0,0 +1,7 @@ +;; This template is turned into a machine-specific ".def" file +;; by the `workarea` script + +(define-constant machine-type (constant machine-type-$(M))) +(features iconv expeditor pthreads) +(include "$(March).def") +(include "default.def") diff --git a/src/ChezScheme/s/unix.def b/src/ChezScheme/s/unix.def new file mode 100644 index 0000000000..e0cb28c05b --- /dev/null +++ b/src/ChezScheme/s/unix.def @@ -0,0 +1,7 @@ +;; This template is turned into a machine-specific ".def" file +;; by the `workarea` script + +(define-constant machine-type (constant machine-type-$(M))) +(features iconv expeditor) +(include "$(March).def") +(include "default.def") diff --git a/src/ChezScheme/s/vfasl.ss b/src/ChezScheme/s/vfasl.ss index befc436ee1..a827e9ee56 100644 --- a/src/ChezScheme/s/vfasl.ss +++ b/src/ChezScheme/s/vfasl.ss @@ -753,11 +753,17 @@ (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*)) + (safe-assert (pair? fld*)) + (let ([ancestry (car fld*)]) + (field-case ancestry + [ptr (elem) + (fasl-case* elem + [(vector ty vec) + (let ([parent (vector-ref vec (fx- (vector-length vec) + (constant ancestry-parent-offset)))]) + (copy parent vfi))] + [else (safe-assert (not 'vector)) (void)])] + [else (safe-assert (not 'ptr)) (void)]))) (let* ([vspc (cond [maybe-uid (constant vspace-rtd)] @@ -1024,7 +1030,7 @@ (let* ([new-p (find-room 'reloc vfi (constant vspace-reloc) (fx+ (constant header-size-reloc-table) (fx* m (constant ptr-bytes))) - (constant typemod))]) + (constant type-untyped))]) (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]) diff --git a/src/ChezScheme/s/x86_64.ss b/src/ChezScheme/s/x86_64.ss index 1ea01fac1f..84904c2d79 100644 --- a/src/ChezScheme/s/x86_64.ss +++ b/src/ChezScheme/s/x86_64.ss @@ -636,7 +636,11 @@ [(op (x fpur) (y ur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpcast ,y))]) (define-instruction value (fp+ fp- fp* fp/) - [(op (x fpur) (y fpmem fpur) (z fpmem fpur)) + [(op (x fpur) (y fpur) (z fpmem fpur)) + (seq + `(move-related ,x ,y) + `(set! ,(make-live-info) ,x (asm ,info ,(asm-fpop-2 op) ,y ,z)))] + [(op (x fpur) (y fpmem) (z fpmem fpur)) `(set! ,(make-live-info) ,x (asm ,info ,(asm-fpop-2 op) ,y ,z))]) (define-instruction value (fpsqrt) @@ -735,58 +739,89 @@ (define-instruction pred (condition-code) [(op) (values '() `(asm ,info ,(asm-condition-code info)))]) - (let* ([info-cc-eq (make-info-condition-code 'eq? #f #t)] - [asm-eq (asm-relop info-cc-eq)]) - (define-instruction pred (type-check?) - [(op (x ur mem) (mask imm32 ur) (type imm32 ur)) - (let ([tmp (make-tmp 'u)]) - (values - (with-output-language (L15d Effect) - (seq + (let () + (define imm->imm32 + (lambda (y w k) + (nanopass-case (L15d Triv) w + [(immediate ,imm) + (if (signed-32? imm) + (k y w) + (let ([tmp (make-tmp 'u)] + [zero (with-output-language (L15d Triv) + `(immediate 0))]) + (with-output-language (L15d Effect) + (seq + `(set! ,(make-live-info) ,tmp ,w) + (if (eq? y %zero) + (k tmp zero) + (seq + `(set! ,(make-live-info) ,tmp (asm ,null-info ,asm-add ,tmp ,y)) + (k tmp zero)))))))]))) + + (let* ([info-cc-eq (make-info-condition-code 'eq? #f #t)] + [asm-eq (asm-relop info-cc-eq)]) + (define-instruction pred (type-check?) + [(op (x ur mem) (mask imm32 ur) (type imm32 ur)) + (let ([tmp (make-tmp 'u)]) + (values + (with-output-language (L15d Effect) + (seq `(set! ,(make-live-info) ,tmp ,x) `(set! ,(make-live-info) ,tmp (asm ,null-info ,asm-logand ,tmp ,mask)))) - `(asm ,info-cc-eq ,asm-eq ,tmp ,type)))]) - - (define-instruction pred (logtest log!test) - [(op (x mem) (y ur imm32)) - (values '() `(asm ,info-cc-eq ,(asm-logtest (eq? op 'log!test) info-cc-eq) ,x ,y))] - [(op (x ur imm32) (y mem)) - (values '() `(asm ,info-cc-eq ,(asm-logtest (eq? op 'log!test) info-cc-eq) ,y ,x))] - [(op (x imm32) (y ur)) - (values '() `(asm ,info-cc-eq ,(asm-logtest (eq? op 'log!test) info-cc-eq) ,y ,x))] - [(op (x ur) (y ur imm32)) - (values '() `(asm ,info-cc-eq ,(asm-logtest (eq? op 'log!test) info-cc-eq) ,x ,y))]) - - (define-instruction pred (lock!) - [(op (x ur) (y ur) (w imm32)) - (let ([uts (make-precolored-unspillable 'uts %ts)]) - (values - (nanopass-case (L15d Triv) w - [(immediate ,imm) - (with-output-language (L15d Effect) - (seq - `(set! ,(make-live-info) ,uts (immediate 1)) - `(set! ,(make-live-info) ,uts - (asm ,info ,asm-exchange ,uts - (mref ,x ,y ,imm uptr)))))]) - `(asm ,info-cc-eq ,asm-eq ,uts (immediate 0))))])) - - (define-instruction effect (locked-incr!) - [(op (x ur) (y ur) (w imm32)) - `(asm ,info ,asm-locked-incr ,x ,y ,w)]) - - (define-instruction effect (locked-decr!) - [(op (x ur) (y ur) (w imm32)) - `(asm ,info ,asm-locked-decr ,x ,y ,w)]) - - (define-instruction effect (cas) - [(op (x ur) (y ur) (w imm32) (old ur) (new ur)) - (let ([urax (make-precolored-unspillable 'urax %rax)]) - (with-output-language (L15d Effect) - (seq - `(set! ,(make-live-info) ,urax ,old) - ;; NB: may modify %rax: - `(asm ,info ,asm-locked-cmpxchg ,x ,y ,w ,urax ,new))))]) + `(asm ,info-cc-eq ,asm-eq ,tmp ,type)))]) + + (define-instruction pred (logtest log!test) + [(op (x mem) (y ur imm32)) + (values '() `(asm ,info-cc-eq ,(asm-logtest (eq? op 'log!test) info-cc-eq) ,x ,y))] + [(op (x ur imm32) (y mem)) + (values '() `(asm ,info-cc-eq ,(asm-logtest (eq? op 'log!test) info-cc-eq) ,y ,x))] + [(op (x imm32) (y ur)) + (values '() `(asm ,info-cc-eq ,(asm-logtest (eq? op 'log!test) info-cc-eq) ,y ,x))] + [(op (x ur) (y ur imm32)) + (values '() `(asm ,info-cc-eq ,(asm-logtest (eq? op 'log!test) info-cc-eq) ,x ,y))]) + + (define-instruction pred (lock!) + [(op (x ur) (y ur) (w imm)) + (imm->imm32 + y w + (lambda (y w) + (let ([uts (make-precolored-unspillable 'uts %ts)]) + (values + (nanopass-case (L15d Triv) w + [(immediate ,imm) + (with-output-language (L15d Effect) + (seq + `(set! ,(make-live-info) ,uts (immediate 1)) + `(set! ,(make-live-info) ,uts + (asm ,info ,asm-exchange ,uts + (mref ,x ,y ,imm uptr)))))]) + `(asm ,info-cc-eq ,asm-eq ,uts (immediate 0))))))])) + + (define-instruction effect (locked-incr!) + [(op (x ur) (y ur) (w imm)) + (imm->imm32 + y w + (lambda (y w) + `(asm ,info ,asm-locked-incr ,x ,y ,w)))]) + + (define-instruction effect (locked-decr!) + [(op (x ur) (y ur) (w imm)) + (imm->imm32 + y w + (lambda (y w) + `(asm ,info ,asm-locked-decr ,x ,y ,w)))]) + + (define-instruction effect (cas) + [(op (x ur) (y ur) (w imm) (old ur) (new ur)) + (imm->imm32 + y w + (lambda (y w) + (let ([urax (make-precolored-unspillable 'urax %rax)]) + (with-output-language (L15d Effect) + (seq + `(set! ,(make-live-info) ,urax ,old) + ;; NB: may modify %rax: + `(asm ,info ,asm-locked-cmpxchg ,x ,y ,w ,urax ,new))))))])) (define-instruction effect (pause) [(op) `(asm ,info ,asm-pause)]) @@ -2427,11 +2462,11 @@ (module (asm-foreign-call asm-foreign-callable) (if-feature windows (begin - (define make-vint (lambda () (vector %Carg1 %Carg2 %Carg3 %Carg4))) - (define make-vfp (lambda () (vector %Cfparg1 %Cfparg2 %Cfparg3 %Cfparg4)))) + (define vint (vector %Carg1 %Carg2 %Carg3 %Carg4)) + (define vfp (vector %Cfparg1 %Cfparg2 %Cfparg3 %Cfparg4))) (begin - (define make-vint (lambda () (vector %Carg1 %Carg2 %Carg3 %Carg4 %Carg5 %Carg6))) - (define make-vfp (lambda () (vector %Cfparg1 %Cfparg2 %Cfparg3 %Cfparg4 %Cfparg5 %Cfparg6 %Cfparg7 %Cfparg8))))) + (define vint (vector %Carg1 %Carg2 %Carg3 %Carg4 %Carg5 %Carg6)) + (define vfp (vector %Cfparg1 %Cfparg2 %Cfparg3 %Cfparg4 %Cfparg5 %Cfparg6 %Cfparg7 %Cfparg8)))) (define (align n size) (fxlogand (fx+ n (fx- size 1)) (fx- size))) @@ -2625,7 +2660,7 @@ `(set! ,(%mref ,%sp ,offset) (inline ,(make-info-load 'integer-8 #f) ,%load ,x ,%zero (immediate ,x-offset)))]))))] [load-content-regs - (lambda (classes size iint ifp vint vfp) + (lambda (classes size unsigned? iint ifp) (lambda (x) ; requires var (let loop ([size size] [iint iint] [ifp ifp] [classes classes] [x-offset 0]) (cond @@ -2650,13 +2685,13 @@ (let loop ([reg (vector-ref vint iint)] [size size] [x-offset x-offset]) (cond [(= size 4) - `(set! ,reg (inline ,(make-info-load 'unsigned-32 #f) + `(set! ,reg (inline ,(make-info-load (if unsigned? 'unsigned-32 'integer-32) #f) ,%load ,x ,%zero (immediate ,x-offset)))] [(= size 2) - `(set! ,reg (inline ,(make-info-load 'unsigned-16 #f) + `(set! ,reg (inline ,(make-info-load (if unsigned? 'unsigned-16 'integer-16) #f) ,%load ,x ,%zero (immediate ,x-offset)))] [(= size 1) - `(set! ,reg (inline ,(make-info-load 'unsigned-8 #f) + `(set! ,reg (inline ,(make-info-load (if unsigned? 'unsigned-8 'integer-8) #f) ,%load ,x ,%zero (immediate ,x-offset)))] [(> size 4) ;; 5, 6, or 7: multiple steps to avoid reading too many bytes @@ -2682,7 +2717,7 @@ (add-regs (fx- ints 1) (fx+ ir 1) vr (cons (vector-ref vr ir) regs))]))] [do-args - (lambda (types vint vfp) + (lambda (types) (if-feature windows (let loop ([types types] [locs '()] [regs '()] [fp-regs '()] [i 0] [isp 0]) (if (null? types) @@ -2717,12 +2752,12 @@ (eq? 'float (caar ($ftd->members ftd)))) ;; float or double (loop (cdr types) - (cons (load-content-regs '(sse) ($ftd-size ftd) i i vint vfp) locs) + (cons (load-content-regs '(sse) ($ftd-size ftd) #t i i) locs) (add-regs 1 i vint regs) (add-regs 1 i vfp fp-regs) (fx+ i 1) isp)] [else ;; integer (loop (cdr types) - (cons (load-content-regs '(integer) ($ftd-size ftd) i i vint vfp) locs) + (cons (load-content-regs '(integer) ($ftd-size ftd) ($ftd-unsigned? ftd) i i) locs) (add-regs 1 i vint regs) fp-regs(fx+ i 1) isp)])] [else ;; pass as value on the stack @@ -2786,7 +2821,7 @@ [else ;; pass in registers (loop (cdr types) - (cons (load-content-regs classes ($ftd-size ftd) iint ifp vint vfp) locs) + (cons (load-content-regs classes ($ftd-size ftd) ($ftd-unsigned? ftd) iint ifp) locs) (add-regs ints iint vint regs) (add-regs fps ifp vfp fp-regs) (fx+ iint ints) (fx+ ifp fps) isp)]))] [else @@ -2917,7 +2952,7 @@ [fill-result-here? (result-fits-in-registers? result-classes)] [result-reg* (get-result-regs fill-result-here? result-type result-classes)] [adjust-active? (if-feature pthreads (memq 'adjust-active conv*) #f)]) - (with-values (do-args (if fill-result-here? (cdr arg-type*) arg-type*) (make-vint) (make-vfp)) + (with-values (do-args (if fill-result-here? (cdr arg-type*) arg-type*)) (lambda (frame-size nfp locs live* fp-live*) (with-values (add-save-fill-target fill-result-here? frame-size locs) (lambda (frame-size locs) @@ -3061,8 +3096,6 @@ `(set! ,lvalue ,(%inline + ,%sp (immediate ,offset)))))) (define save-arg-regs (lambda (types) - (define vint (make-vint)) - (define vfp (make-vfp)) (if-feature windows (let f ([types types] [i 0] [isp 8]) (if (or (null? types) (fx= i 4)) diff --git a/src/ChezScheme/scheme.1.in b/src/ChezScheme/scheme.1.in index 2a34f0f2d0..fdd65a4c42 100644 --- a/src/ChezScheme/scheme.1.in +++ b/src/ChezScheme/scheme.1.in @@ -3,7 +3,7 @@ .if t .ds c caf\o'\'e' .if n .ds c cafe .ds ]W -.TH SCHEME 1 "Chez Scheme Version 9.5.3 September 2019" +.TH SCHEME 1 "Chez Scheme Version 9.5.5 August 2020" .SH NAME \fIChez Scheme\fP .br @@ -794,6 +794,6 @@ Second Edition\fP, MIT press (1996). .in -5 .SH AUTHOR -Copyright 2019 Cisco Systems, Inc. +Copyright 2020 Cisco Systems, Inc. Licensed under the Apache License, Version 2.0 (http://www.apache.org/licenses/LICENSE-2.0) diff --git a/src/ChezScheme/stex/Makefile b/src/ChezScheme/stex/Makefile index fa77487ab4..ed3131d813 100644 --- a/src/ChezScheme/stex/Makefile +++ b/src/ChezScheme/stex/Makefile @@ -49,10 +49,10 @@ install: $(exec) (umask 022; sed -e 's;include ~/stex/Mf-stex;include $(LIB)/Mf-stex;' Makefile.template > $(LIB)/Makefile.template) uninstall: - /bin/rm -rf $(LIB) + rm -rf $(LIB) clean: - /bin/rm -f Make.out + rm -f Make.out distclean: clean - /bin/rm -rf $m + rm -rf $m diff --git a/src/ChezScheme/stex/Mf-stex b/src/ChezScheme/stex/Mf-stex index e6cd3822e4..950b417b32 100644 --- a/src/ChezScheme/stex/Mf-stex +++ b/src/ChezScheme/stex/Mf-stex @@ -139,12 +139,12 @@ $(x).spell: $(x).bbl $(x).tex latexspell $(x).tex clean: $(x).clean - -/bin/rm -f *.log *.dvi *.aux *.out *.toc *.tmp *.idx *.ilg *.ind *.blg *.bbl *.rfm *.sfm *.firstrun *.secondrun *.thirdrun - -/bin/rm -f *.haux *.htoc *.hidx *.hfirstrun *.hsecondrun *.hthirdrun *.mathrun - -/bin/rm -f *.tex + -rm -f *.log *.dvi *.aux *.out *.toc *.tmp *.idx *.ilg *.ind *.blg *.bbl *.rfm *.sfm *.firstrun *.secondrun *.thirdrun + -rm -f *.haux *.htoc *.hidx *.hfirstrun *.hsecondrun *.hthirdrun *.mathrun + -rm -f *.tex reallyclean: clean $(x).reallyclean - -/bin/rm -f *.html *.ps *.pdf *.png + -rm -f *.html *.ps *.pdf *.png reallyreallyclean: reallyclean $(x).reallyreallyclean - -/bin/rm -rf $(mathdir) + -rm -rf $(mathdir) diff --git a/src/ChezScheme/stex/gifs/Makefile b/src/ChezScheme/stex/gifs/Makefile index 4a9abdb547..93c6457597 100644 --- a/src/ChezScheme/stex/gifs/Makefile +++ b/src/ChezScheme/stex/gifs/Makefile @@ -15,7 +15,7 @@ density=-r90x90 ${density} - |\ pnmcrop |\ ppmtogif -transparent white > $*.gif - /bin/rm -f $*.dvi $*.log *.aux + rm -f $*.dvi $*.log *.aux test -f $*.gif && chmod 644 $*.gif all: ${gifs} @@ -44,7 +44,7 @@ ghostRightarrow.gif: Rightarrow.tex giftrans -g '#000000=#ffffff' |\ giftopnm |\ ppmtogif -transparent white > $*.gif - /bin/rm -f Rightarrow.dvi Rightarrow.log Rightarrow.aux + rm -f Rightarrow.dvi Rightarrow.log Rightarrow.aux test -f $*.gif && chmod 644 $*.gif clean: diff --git a/src/ChezScheme/stex/math/Makefile b/src/ChezScheme/stex/math/Makefile index b3ffae3b54..9eca430132 100644 --- a/src/ChezScheme/stex/math/Makefile +++ b/src/ChezScheme/stex/math/Makefile @@ -16,11 +16,11 @@ density=-r90x90 ${density} - |\ pnmcrop |\ ppmtogif -transparent white > $*.gif - /bin/rm -f $*.dvi $*.log $*.aux + rm -f $*.dvi $*.log $*.aux test -f $*.gif && chmod 644 $*.gif all: ${gifs} ${gifs}: mathmacros -clean: ; /bin/rm -f *.gif Make.out +clean: ; rm -f *.gif Make.out diff --git a/src/ChezScheme/wininstall/Makefile b/src/ChezScheme/wininstall/Makefile index b32ace217e..fe9b5ce311 100644 --- a/src/ChezScheme/wininstall/Makefile +++ b/src/ChezScheme/wininstall/Makefile @@ -1,4 +1,4 @@ -VERSION := 9.5.3 +VERSION := 9.5.5 WIXEXTENSIONS := -ext WixUIExtension -ext WixBalExtension export MSYS_NO_PATHCONV=1 diff --git a/src/ChezScheme/wininstall/a6nt.wxs b/src/ChezScheme/wininstall/a6nt.wxs index c1d6cc28eb..86f258eb60 100644 --- a/src/ChezScheme/wininstall/a6nt.wxs +++ b/src/ChezScheme/wininstall/a6nt.wxs @@ -4,16 +4,16 @@ <DirectoryRef Id="D_bin"> <Directory Id="D_bin_a6nt" Name="a6nt"> <Component Id="cmp9E121291956F53F264990A9F6E93E67D" Guid="*"> - <File Id="fil174DC3B31231BE75291782CBF71B1ECB" KeyPath="yes" Source="..\a6nt\bin\a6nt\csv953.dll" /> + <File Id="fil174DC3B31231BE75291782CBF71B1ECB" KeyPath="yes" Source="..\a6nt\bin\a6nt\csv955.dll" /> </Component> <Component Id="cmpDB181AE3BD838D4F431CAE12DB40B70A" Guid="*"> - <File Id="fil53D3BD37CECBBF28D1DB95A8B750DBDC" KeyPath="yes" Source="..\a6nt\bin\a6nt\csv953.exp" /> + <File Id="fil53D3BD37CECBBF28D1DB95A8B750DBDC" KeyPath="yes" Source="..\a6nt\bin\a6nt\csv955.exp" /> </Component> <Component Id="cmp0B0A70880E3C505B199705D415235AC7" Guid="*"> - <File Id="fil69E98A18AB5AD3061617C9E68F536773" KeyPath="yes" Source="..\a6nt\bin\a6nt\csv953.lib" /> + <File Id="fil69E98A18AB5AD3061617C9E68F536773" KeyPath="yes" Source="..\a6nt\bin\a6nt\csv955.lib" /> </Component> <Component Id="cmp41C1093548579E6BE087DD4BE735B7C5" Guid="*"> - <File Id="fil11683117A53DD772D9B6F0C11BE06C7C" KeyPath="yes" Source="..\a6nt\bin\a6nt\csv953.pdb" /> + <File Id="fil11683117A53DD772D9B6F0C11BE06C7C" KeyPath="yes" Source="..\a6nt\bin\a6nt\csv955.pdb" /> </Component> <Component Id="cmpD50999EDF5C2480D6F6F6A04E6B127F3" Guid="*"> <File Id="filE439E2DE55CFE1366273AF3E232D4519" KeyPath="yes" Source="..\a6nt\bin\a6nt\petite.exe" /> @@ -40,10 +40,10 @@ <DirectoryRef Id="D_boot"> <Directory Id="D_boot_a6nt" Name="a6nt"> <Component Id="cmpB8AFC5E7298C4FB423F21E474D718248" Guid="*"> - <File Id="filAA3DCFC2962A0A679D26BAEF2EE45D18" KeyPath="yes" Source="..\a6nt\boot\a6nt\csv953md.lib" /> + <File Id="filAA3DCFC2962A0A679D26BAEF2EE45D18" KeyPath="yes" Source="..\a6nt\boot\a6nt\csv955md.lib" /> </Component> <Component Id="cmp41A0F324C636C03565EFAB5DC1197958" Guid="*"> - <File Id="fil0052F236986BD25DFE0D0DE76854483B" KeyPath="yes" Source="..\a6nt\boot\a6nt\csv953mt.lib" /> + <File Id="fil0052F236986BD25DFE0D0DE76854483B" KeyPath="yes" Source="..\a6nt\boot\a6nt\csv955mt.lib" /> </Component> <Component Id="cmp08025CB77BA01465D21171D27231AE6A" Guid="*"> <File Id="fil7FF609B8D0F6C6E984910D4458F7B76B" KeyPath="yes" Source="..\a6nt\boot\a6nt\mainmd.obj" /> diff --git a/src/ChezScheme/wininstall/i3nt.wxs b/src/ChezScheme/wininstall/i3nt.wxs index a530b092fe..1cf218dc73 100644 --- a/src/ChezScheme/wininstall/i3nt.wxs +++ b/src/ChezScheme/wininstall/i3nt.wxs @@ -4,16 +4,16 @@ <DirectoryRef Id="D_bin"> <Directory Id="D_bin_i3nt" Name="i3nt"> <Component Id="cmp3EAD5F342D86023E323C2F3E96A596B9" Guid="*"> - <File Id="filF35C82CDA44DE51CEFA9FF8CA1B38AAA" KeyPath="yes" Source="..\i3nt\bin\i3nt\csv953.dll" /> + <File Id="filF35C82CDA44DE51CEFA9FF8CA1B38AAA" KeyPath="yes" Source="..\i3nt\bin\i3nt\csv955.dll" /> </Component> <Component Id="cmpF2410A7AF5FB7C10A33DA57476B0E56B" Guid="*"> - <File Id="filFE4E60D4DD4AEF0DDA574E6EF117FEC0" KeyPath="yes" Source="..\i3nt\bin\i3nt\csv953.exp" /> + <File Id="filFE4E60D4DD4AEF0DDA574E6EF117FEC0" KeyPath="yes" Source="..\i3nt\bin\i3nt\csv955.exp" /> </Component> <Component Id="cmp905F254ECBC3BCB861BBBF60B0F34D73" Guid="*"> - <File Id="fil811C8A53860477F59CD4D11BF7C36A5E" KeyPath="yes" Source="..\i3nt\bin\i3nt\csv953.lib" /> + <File Id="fil811C8A53860477F59CD4D11BF7C36A5E" KeyPath="yes" Source="..\i3nt\bin\i3nt\csv955.lib" /> </Component> <Component Id="cmp43EE1BA94E7D15B5F9721D32B41CDFF1" Guid="*"> - <File Id="fil3475AECC40E6C77A1E5A74C81205D246" KeyPath="yes" Source="..\i3nt\bin\i3nt\csv953.pdb" /> + <File Id="fil3475AECC40E6C77A1E5A74C81205D246" KeyPath="yes" Source="..\i3nt\bin\i3nt\csv955.pdb" /> </Component> <Component Id="cmp2660425B08191D07FD2B8E4D12C25CAF" Guid="*"> <File Id="fil6C14AF587FDAABD1440BADC640EEF64E" KeyPath="yes" Source="..\i3nt\bin\i3nt\petite.exe" /> @@ -40,10 +40,10 @@ <DirectoryRef Id="D_boot"> <Directory Id="D_boot_i3nt" Name="i3nt"> <Component Id="cmp47E339F22F1D268C3D889C89DC04B1EC" Guid="*"> - <File Id="filFAE795432021A108F72A5A1763549848" KeyPath="yes" Source="..\i3nt\boot\i3nt\csv953md.lib" /> + <File Id="filFAE795432021A108F72A5A1763549848" KeyPath="yes" Source="..\i3nt\boot\i3nt\csv955md.lib" /> </Component> <Component Id="cmp97E86E3E78EC5C1E35333413F9D239A9" Guid="*"> - <File Id="filC2A38DD4D83F793279D6D10E8D553145" KeyPath="yes" Source="..\i3nt\boot\i3nt\csv953mt.lib" /> + <File Id="filC2A38DD4D83F793279D6D10E8D553145" KeyPath="yes" Source="..\i3nt\boot\i3nt\csv955mt.lib" /> </Component> <Component Id="cmp4EC08D9AF0D6DADE3077A7EB099476B4" Guid="*"> <File Id="fil47E4EBA05B181E80FAF43A5B84DCC1D6" KeyPath="yes" Source="..\i3nt\boot\i3nt\mainmd.obj" /> diff --git a/src/ChezScheme/wininstall/ta6nt.wxs b/src/ChezScheme/wininstall/ta6nt.wxs index f137baa657..665ff32f4a 100644 --- a/src/ChezScheme/wininstall/ta6nt.wxs +++ b/src/ChezScheme/wininstall/ta6nt.wxs @@ -4,16 +4,16 @@ <DirectoryRef Id="D_bin"> <Directory Id="D_bin_ta6nt" Name="ta6nt"> <Component Id="cmpA67EF6318D00B4209BFCD0BFDCDF781C" Guid="*"> - <File Id="fil6AE7892DB37FF6D2C21B5EC064C90DE5" KeyPath="yes" Source="..\ta6nt\bin\ta6nt\csv953.dll" /> + <File Id="fil6AE7892DB37FF6D2C21B5EC064C90DE5" KeyPath="yes" Source="..\ta6nt\bin\ta6nt\csv955.dll" /> </Component> <Component Id="cmpF41FF9DE554F79FB6FBD85E5B80A5221" Guid="*"> - <File Id="fil9157F8FB18F1F75BE50A64A9C227BF61" KeyPath="yes" Source="..\ta6nt\bin\ta6nt\csv953.exp" /> + <File Id="fil9157F8FB18F1F75BE50A64A9C227BF61" KeyPath="yes" Source="..\ta6nt\bin\ta6nt\csv955.exp" /> </Component> <Component Id="cmp372F759C97C3C69E4C336B81D807E4F5" Guid="*"> - <File Id="fil602A8BBB83416294672AA22507E6452A" KeyPath="yes" Source="..\ta6nt\bin\ta6nt\csv953.lib" /> + <File Id="fil602A8BBB83416294672AA22507E6452A" KeyPath="yes" Source="..\ta6nt\bin\ta6nt\csv955.lib" /> </Component> <Component Id="cmp009F56824D2716FAAC978FE17A4D947D" Guid="*"> - <File Id="filDD0E7D06D27FC4C00388CB48E4B2818C" KeyPath="yes" Source="..\ta6nt\bin\ta6nt\csv953.pdb" /> + <File Id="filDD0E7D06D27FC4C00388CB48E4B2818C" KeyPath="yes" Source="..\ta6nt\bin\ta6nt\csv955.pdb" /> </Component> <Component Id="cmp50972D99EC9DDA63E4BC6E29DAA592D0" Guid="*"> <File Id="fil8A260A0B8935F8F9011AA2EDB9147BDE" KeyPath="yes" Source="..\ta6nt\bin\ta6nt\petite.exe" /> @@ -40,10 +40,10 @@ <DirectoryRef Id="D_boot"> <Directory Id="D_boot_ta6nt" Name="ta6nt"> <Component Id="cmpCBDB945622604667783C3C57A0427DF5" Guid="*"> - <File Id="filD3E4E45F8404EE812C5DAFCBEB2502AA" KeyPath="yes" Source="..\ta6nt\boot\ta6nt\csv953md.lib" /> + <File Id="filD3E4E45F8404EE812C5DAFCBEB2502AA" KeyPath="yes" Source="..\ta6nt\boot\ta6nt\csv955md.lib" /> </Component> <Component Id="cmpD7880184C113065E511275EFD531D589" Guid="*"> - <File Id="filDC2D7E1DB036BAE5B7FFA7FE14F3CD69" KeyPath="yes" Source="..\ta6nt\boot\ta6nt\csv953mt.lib" /> + <File Id="filDC2D7E1DB036BAE5B7FFA7FE14F3CD69" KeyPath="yes" Source="..\ta6nt\boot\ta6nt\csv955mt.lib" /> </Component> <Component Id="cmp5211817ED85951CDAF2FD5E2419BD211" Guid="*"> <File Id="fil21839A8D4062A72DEAB3156D77EEE82A" KeyPath="yes" Source="..\ta6nt\boot\ta6nt\mainmd.obj" /> diff --git a/src/ChezScheme/wininstall/ti3nt.wxs b/src/ChezScheme/wininstall/ti3nt.wxs index 3c65019ef5..160d041259 100644 --- a/src/ChezScheme/wininstall/ti3nt.wxs +++ b/src/ChezScheme/wininstall/ti3nt.wxs @@ -4,16 +4,16 @@ <DirectoryRef Id="D_bin"> <Directory Id="D_bin_ti3nt" Name="ti3nt"> <Component Id="cmp3E51840FF941B7410025EFB2215EAB58" Guid="*"> - <File Id="fil6B96E8682034EC96C7842C5024FDF620" KeyPath="yes" Source="..\ti3nt\bin\ti3nt\csv953.dll" /> + <File Id="fil6B96E8682034EC96C7842C5024FDF620" KeyPath="yes" Source="..\ti3nt\bin\ti3nt\csv955.dll" /> </Component> <Component Id="cmp68BA21E76800BFFA057D33973E89D8F4" Guid="*"> - <File Id="fil5F505E9200C84F7887C4D12FA9D9D794" KeyPath="yes" Source="..\ti3nt\bin\ti3nt\csv953.exp" /> + <File Id="fil5F505E9200C84F7887C4D12FA9D9D794" KeyPath="yes" Source="..\ti3nt\bin\ti3nt\csv955.exp" /> </Component> <Component Id="cmpCA1F1C55C49A3A332E60F8D0D78363C2" Guid="*"> - <File Id="filB8607D2BF295249DD6F51070A687E14B" KeyPath="yes" Source="..\ti3nt\bin\ti3nt\csv953.lib" /> + <File Id="filB8607D2BF295249DD6F51070A687E14B" KeyPath="yes" Source="..\ti3nt\bin\ti3nt\csv955.lib" /> </Component> <Component Id="cmp01D266C0ECE540BE4BF6E6AE14AFFCBB" Guid="*"> - <File Id="filE99735E84B4934FC41AAA6BBF547F1C5" KeyPath="yes" Source="..\ti3nt\bin\ti3nt\csv953.pdb" /> + <File Id="filE99735E84B4934FC41AAA6BBF547F1C5" KeyPath="yes" Source="..\ti3nt\bin\ti3nt\csv955.pdb" /> </Component> <Component Id="cmpC00FD9C7415A1D2D22EA38F5259CAAA4" Guid="*"> <File Id="fil80D2F31CB0D3B8F98E3C8CCAF9DA6F29" KeyPath="yes" Source="..\ti3nt\bin\ti3nt\petite.exe" /> @@ -40,10 +40,10 @@ <DirectoryRef Id="D_boot"> <Directory Id="D_boot_ti3nt" Name="ti3nt"> <Component Id="cmp7099C9EB3F487AAFE3A880CED21FA9C2" Guid="*"> - <File Id="filD5DA8D84F54BC985AA246BBD3FB15239" KeyPath="yes" Source="..\ti3nt\boot\ti3nt\csv953md.lib" /> + <File Id="filD5DA8D84F54BC985AA246BBD3FB15239" KeyPath="yes" Source="..\ti3nt\boot\ti3nt\csv955md.lib" /> </Component> <Component Id="cmpF3038779EA05930E72A29C15DC2D64B2" Guid="*"> - <File Id="filFB335FE01A6D5ED27AD2BC179DB8E265" KeyPath="yes" Source="..\ti3nt\boot\ti3nt\csv953mt.lib" /> + <File Id="filFB335FE01A6D5ED27AD2BC179DB8E265" KeyPath="yes" Source="..\ti3nt\boot\ti3nt\csv955mt.lib" /> </Component> <Component Id="cmp9DDE0523EFC5EEA983DE3CFA0F493908" Guid="*"> <File Id="fil139F59D34D1A013CCB2AEC11507287AA" KeyPath="yes" Source="..\ti3nt\boot\ti3nt\mainmd.obj" /> diff --git a/src/ChezScheme/workarea b/src/ChezScheme/workarea index d1b0aa80b4..b650869be4 100755 --- a/src/ChezScheme/workarea +++ b/src/ChezScheme/workarea @@ -54,7 +54,13 @@ case "$Mhost" in a6osx) ;; a6s2) ;; arm32le) ;; + arm32fb) ;; + arm32ob) ;; + arm32nb) ;; arm64le) ;; + arm64fb) ;; + arm64ob) ;; + arm64nb) ;; arm64osx) ;; i3fb) ;; i3le) ;; @@ -65,31 +71,50 @@ case "$Mhost" in i3qnx) ;; i3s2) ;; ppc32le) ;; - ppc32osx) ;; + ppc32fb) ;; + ppc32ob) ;; + ppc32nb) ;; ppc32osx) ;; arm64osx) ;; - ta6fb) Muni=a6fb ;; - ta6le) Muni=a6le ;; - ta6nb) Muni=a6nb ;; - ta6nt) Muni=a6nt ;; - ta6ob) Muni=a6ob ;; - ta6osx) Muni=a6osx ;; - ta6s2) Muni=a6s2 ;; - tarm32le) Muni=arm32le ;; - tarm64le) Muni=arm64le ;; - tarm64osx) Muni=arm64osx ;; - ti3fb) Muni=i3fb ;; - ti3le) Muni=i3le ;; - ti3nb) Muni=i3nb ;; - ti3nt) Muni=i3nt ;; - ti3ob) Muni=i3ob ;; - ti3osx) Muni=i3osx ;; - ti3qnx) Muni=i3qnx ;; - ti3s2) Muni=i3s2 ;; - tppc32le) Muni=ppc32le ;; - tppc32osx) Muni=ppc32osx ;; - tarm64osx) Muni=arm64osx ;; - *) echo "Unrecognized machine name $Mhost"; exit 1 ;; + ta6fb) ;; + ta6le) ;; + ta6nb) ;; + ta6nt) ;; + ta6ob) ;; + ta6osx) ;; + ta6s2) ;; + tarm32le) ;; + tarm32fb) ;; + tarm32ob) ;; + tarm32nb) ;; + tarm64le) ;; + tarm64fb) ;; + tarm64ob) ;; + tarm64nb) ;; + tarm64osx) ;; + ti3fb) ;; + ti3le) ;; + ti3nb) ;; + ti3nt) ;; + ti3ob) ;; + ti3osx) ;; + ti3s2) ;; + tppc32le) ;; + tppc32fb) ;; + tppc32ob) ;; + tppc32nb) ;; + tppc32osx) ;; + tarm64osx) ;; + *) echo "unrecognized machine name: $Mhost"; exit 1 ;; +esac + +Muni=`echo $M | sed -e 's/^t//'` + +# If Mtype is set, then Mf-$Mtype is used, +# otherwise Mf-$M and Mf-$Muni is used +case "$Mhost" in + *nt) ;; + *) Mtype=unix ;; esac if [ "$Muni" != "" ] ; then @@ -98,30 +123,37 @@ else Muniarch=$Mhost fi -case "$Muniarch" in - a6fb) March=a6 ;; - a6le) March=a6 ;; - a6nb) March=a6 ;; - a6nt) March=a6 ;; - a6ob) March=a6 ;; - a6osx) March=a6 ;; - a6s2) March=a6 ;; - arm32le) March=arm32 ;; - arm64le) March=arm64 ;; - arm64osx) March=arm64 ;; - i3fb) March=i3 ;; - i3le) March=i3 ;; - i3nb) March=i3 ;; - i3nt) March=i3 ;; - i3ob) March=i3 ;; - i3osx) March=i3 ;; - i3qnx) March=i3 ;; - i3s2) March=i3 ;; - ppc32le) March=ppc32 ;; - ppc32osx) March=ppc32 ;; - *) March="" ;; +case "$Muni" in + a6*) + March=a6 + archincludes=x86_64.ss + ;; + arm32*) + March=arm32 + archincludes=arm32.ss + ;; + arm64*) + March=arm64 + archincludes=arm64.ss + ;; + i3*) + March=i3 + archincludes=x86.ss + ;; + ppc32*) + March=ppc32 + archincludes=ppc32.ss + ;; + pb) + March=pb + archincludes=pb.ss + ;; + *) + March="" + archincludes="" + ;; esac - + case "$Muniarch" in a6nt) Mos=nt ;; i3nt) Mos=nt ;; @@ -130,9 +162,9 @@ esac if [ "$OS" = "Windows_NT" ] then - ln="/bin/cp -R" + ln="cp -R" else - ln="/bin/ln -s" + ln="ln -s" fi # This shell script creates a workarea for local modifications to the @@ -182,8 +214,11 @@ workln() # attempts to create link even if source does not exist forceworkln() { + if [ -h $2 ] ; then + rm $2 + fi if [ ! -e $2 ] ; then - /bin/ln -s "$1" $2 2> /dev/null + ln -s "$1" $2 2> /dev/null fi } @@ -205,14 +240,15 @@ workdir() workdir $W workdir $W/c -(cd $W/c; workln "$upupsrcdir"/c/Mf-$M Mf-$M) -(cd $W/c; forceworkln Mf-$M Makefile) -if [ "$Muni" != "" ] ; then - (cd $W/c; workln "$upupsrcdir"/c/Mf-$Muni Mf-$Muni) -fi -if [ "$Mpbhost" != "" ] ; then - (cd $W/c; workln "$upupsrcdir"/c/Mf-$Mpbhost Mf-$Mpbhost) - (cd $W/c; forceworkln Mf-$Mpbhost Mf-pbhost) +if [ "$Mtype" != "" ] ; then + (cd $W/c; workln "$upupsrcdir"/c/Mf-$Mtype Mf-$Mtype) + (cd $W/c; forceworkln Mf-$Mtype Makefile) +else + (cd $W/c; workln "$upupsrcdir"/c/Mf-$M Mf-$M) + (cd $W/c; forceworkln Mf-$M Makefile) + if [ "$Muni" != "" ] ; then + (cd $W/c; workln "$upupsrcdir"/c/Mf-$Muni Mf-$Muni) + fi fi (cd $W/c; workln "$upupsrcdir"/c/Mf-base Mf-base) if [ ! -e $W/c/config.h ] ; then @@ -228,14 +264,34 @@ case $M in esac workdir $W/s -(cd $W/s; workln ${upupsrcdir}/s/Mf-$M Mf-$M) -(cd $W/s; forceworkln Mf-$M Makefile) -if [ "$Muni" != "" ] ; then - (cd $W/s; workln ${upupsrcdir}/s/Mf-$Muni Mf-$Muni) +if [ "$Mtype" != "" ] ; then + (cd $W/s; workln ${upupsrcdir}/s/Mf-$Mtype Mf-$Mtype) + (cd $W/s; forceworkln Mf-$Mtype Makefile) +else + (cd $W/s; workln ${upupsrcdir}/s/Mf-$M Mf-$M) + (cd $W/s; forceworkln Mf-$M Makefile) + if [ "$Muni" != "" ] ; then + (cd $W/s; workln ${upupsrcdir}/s/Mf-$Muni Mf-$Muni) + fi fi (cd $W/s; workln "$upupsrcdir"/s/Mf-base Mf-base) (cd $W/s; workln "$upupsrcdir"/s/Mf-cross Mf-cross) -(cd $W/s; workln "$upupsrcdir"/s/$M.def $M.def) +if [ -e "$srcdir"/s/$M.def ] ; then + (cd $W/s; workln "$upupsrcdir"/s/$M.def $M.def) +else + # synthesize generic Unix .def file + if [ -h $W/s/$M.def ] ; then + rm $W/s/$M.def + fi + if [ $"M" = "$Muni" ] ; then + Munix=unix + else + Munix=tunix + fi + sed -e 's/$(M)/'$M'/g'\ + -e 's/$(March)/'$March'/g'\ + "$srcdir"/s/${Munix}.def > $W/s/$M.def +fi (cd $W/s; forceworkln2 $M.def machine.def) if [ "$March" != "" ] ; then (cd $W/s; workln "$upupsrcdir"/s/$March.def $March.def) @@ -246,10 +302,15 @@ fi (cd $W/s; workln "$upupsrcdir"/s/default.def default.def) workdir $W/mats -(cd $W/mats; workln "$upupsrcdir"/mats/Mf-$M Mf-$M) -(cd $W/mats; forceworkln Mf-$M Makefile) -if [ "$Muni" != "" ] ; then - (cd $W/mats; workln "$upupsrcdir"/mats/Mf-$Muni Mf-$Muni) +if [ "$Mtype" != "" ] ; then + (cd $W/mats; workln "$upupsrcdir"/mats/Mf-$Mtype Mf-$Mtype) + (cd $W/mats; forceworkln Mf-$Mtype Makefile) +else + (cd $W/mats; workln "$upupsrcdir"/mats/Mf-$M Mf-$M) + (cd $W/mats; forceworkln Mf-$M Makefile) + if [ "$Muni" != "" ] ; then + (cd $W/mats; workln "$upupsrcdir"/mats/Mf-$Muni Mf-$Muni) + fi fi if [ "$Mpbhost" != "" ] ; then (cd $W/mats; workln "$upupsrcdir"/mats/Mf-$Mpbhost Mf-$Mpbhost) @@ -278,13 +339,13 @@ linkeach unicode # deep copy submodules where builds occur so changes don't propagate through symlinks for dir in `echo zlib` ; do if [ ! -e $W/$dir ] ; then - /bin/cp -R "$srcdir"/$dir $W/$dir + cp -R "$srcdir"/$dir $W/$dir fi done for dir in `echo lz4` ; do if [ ! -e $W/$dir ] ; then - /bin/cp -R "$srcdir"/$dir $W/$dir + cp -R "$srcdir"/$dir $W/$dir fi done @@ -321,8 +382,8 @@ case $M in *nt) (cd $W/boot/$M; workln "$upupupbootdir"/boot/$M/mainmd.obj mainmd.obj) (cd $W/boot/$M; workln "$upupupbootdir"/boot/$M/mainmt.obj mainmt.obj) - (cd $W/boot/$M; workln "$upupupbootdir"/boot/$M/csv953md.lib csv953md.lib) - (cd $W/boot/$M; workln "$upupupbootdir"/boot/$M/csv953mt.lib csv953mt.lib) + (cd $W/boot/$M; workln "$upupupbootdir"/boot/$M/csv955md.lib csv955md.lib) + (cd $W/boot/$M; workln "$upupupbootdir"/boot/$M/csv955mt.lib csv955mt.lib) (cd $W/boot/$M; workln "$upupupbootdir"/boot/$M/scheme.res scheme.res) ;; *) @@ -337,8 +398,8 @@ case $M in *nt) (cd $W/bin/$M; workln "$upupupsrcdir"/bin/$M/scheme.exe scheme.exe) (cd $W/bin/$M; forceworkln2 scheme.exe petite.exe) - (cd $W/bin/$M; workln "$upupupsrcdir"/bin/$M/csv953.dll csv953.dll) - (cd $W/bin/$M; workln "$upupupsrcdir"/bin/$M/csv953.lib csv953.lib) + (cd $W/bin/$M; workln "$upupupsrcdir"/bin/$M/csv955.dll csv955.dll) + (cd $W/bin/$M; workln "$upupupsrcdir"/bin/$M/csv955.lib csv955.lib) ;; *) (cd $W/bin/$M; workln "$upupupsrcdir"/bin/$M/scheme scheme) @@ -385,14 +446,12 @@ esac cat > $W/s/Mf-config << END upupsrcdir=$upupsrcdir upupupbootdir=$upupupbootdir +m=$M +archincludes=$archincludes END cat > $W/Mf-config << END srcdir=$srcdir END -cat > $W/mats/Mf-config << END -upupsrcdir=$upupsrcdir -END - exit 0 diff --git a/src/ChezScheme/zlib/contrib/minizip/Makefile b/src/ChezScheme/zlib/contrib/minizip/Makefile index 84eaad20d4..784beb0e1e 100644 --- a/src/ChezScheme/zlib/contrib/minizip/Makefile +++ b/src/ChezScheme/zlib/contrib/minizip/Makefile @@ -22,4 +22,4 @@ test: miniunz minizip ./miniunz test.zip clean: - /bin/rm -f *.o *~ minizip miniunz + rm -f *.o *~ minizip miniunz |