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

switch to a new, Racket-implemented expander & module system

Browse Source 
This commit merges changes that were developed in the "racket7" repo.
See that repo (which is no longer modified) for a more fine-grained
change history.

The commit includes experimental support for running Racket on Chez
Scheme, but that "CS" variant is not built by default.
This commit is contained in:
Matthew Flatt 2018-02-26 09:18:51 -07:00
parent 00211413a5
commit 59ef254318
939 changed files with 204119 additions and 63193 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

338
INSTALL.txt
View File

@ -40,35 +40,43 @@ If you stick with this repository, then you have several options:
* Minimal --- as described in the "src" subdirectory of "racket" * Minimal --- as described in the "src" subdirectory of "racket"
(i.e., ignore this directory and "pkgs"). You can build a minimal (i.e., ignore this directory and "pkgs"). You can build a minimal
Racket using the usual `configure && make && make install' steps Racket using the usual `configure && make && make install` steps
(or similar for Windows), and then you can install packages from (or similar for Windows), and then you can install packages from
the catalog server with `raco pkg'. the catalog server with `raco pkg`.
* Installers --- create installers for a variety of platforms by * Installers --- create installers for a variety of platforms by
farming out work to machines that run those platforms. This is the farming out work to machines that run those platforms. This is the
way that Racket snapshots and releases are created, and you can way that Racket snapshots and releases are created, and you can
create your own. See "Building Installers" below. create your own. See "Building Installers" below.
* In-place Racket-on-Chez build --- when you use `make cs`. Unless
you use various options described in "More Instructions: Building
Racket-on-Chez" below, this process downloads Chez Scheme from
Github, builds a traditional `racket` with minimal packages, builds
Chez Scheme, and then builds Racket-on-Chez using Racket and Chez
Scheme. Final executables that end in "cs" or "CS" are the
Racket-on-Chez variants.
Quick Instructions: In-place Build Quick Instructions: In-place Build
================================== ==================================
On Unix (including Linux) and Mac OS, `make' (or `make in-place') On Unix (including Linux) and Mac OS, `make` (or `make in-place`)
creates a build in the "racket" directory. creates a build in the "racket" directory.
On Windows with Microsoft Visual Studio (any version between 2008/9.0 On Windows with Microsoft Visual Studio (any version between 2008/9.0
and 2015/14.0), `nmake win32-in-place' creates a build in the "racket" and 2015/14.0), `nmake win32-in-place` creates a build in the "racket"
directory. For information on configuring your command-line directory. For information on configuring your command-line
environment for Visual Studio, see "racket/src/worksp/README". environment for Visual Studio, see "racket/src/worksp/README".
On Windows with MinGW, `make PLAIN_RACKET=racket/racket', since MinGW On Windows with MinGW, `make PLAIN_RACKET=racket/racket`, since MinGW
uses Unix-style tools but generates a Windows-layout Racket build. uses Unix-style tools but generates a Windows-layout Racket build.
In all cases, an in-place build includes (via links) a few packages In all cases, an in-place build includes (via links) a few packages
that are in the "pkgs" directory. To get new versions of those that are in the "pkgs" directory. To get new versions of those
packages, as well as the Racket core, then use `git pull'. Afterward, packages, as well as the Racket core, then use `git pull`. Afterward,
or to get new versions of any other package, use `make in-place' or to get new versions of any other package, use `make in-place`
again, which includes a `raco pkg update' step. again, which includes a `raco pkg update` step.
See "More Instructions: Building Racket" below for more information. See "More Instructions: Building Racket" below for more information.
@ -76,12 +84,12 @@ See "More Instructions: Building Racket" below for more information.
Quick Instructions: Unix-style Install Quick Instructions: Unix-style Install
====================================== ======================================
On Unix (including Linux), `make unix-style PREFIX=<dir>' builds and On Unix (including Linux), `make unix-style PREFIX=<dir>` builds and
installs into "<dir>" (which must be an absolute path) with binaries installs into "<dir>" (which must be an absolute path) with binaries
in "<dir>/bin", packages in "<dir>/share/racket/pkgs", documentation in "<dir>/bin", packages in "<dir>/share/racket/pkgs", documentation
in "<dir>/share/racket/doc", etc. in "<dir>/share/racket/doc", etc.
On Mac OS, `make unix-style PREFIX=<dir>' builds and installs into On Mac OS, `make unix-style PREFIX=<dir>` builds and installs into
"<dir>" (which must be an absolute path) with binaries in "<dir>/bin", "<dir>" (which must be an absolute path) with binaries in "<dir>/bin",
packages in "<dir>/share/pkgs", documentation in "<dir>/doc", etc. packages in "<dir>/share/pkgs", documentation in "<dir>/doc", etc.
@ -90,7 +98,7 @@ On Windows, Unix-style install is not supported.
A Unix-style install leaves no reference to this source directory. A Unix-style install leaves no reference to this source directory.
To split the build and install steps of a Unix-style installation, To split the build and install steps of a Unix-style installation,
supply `DESTDIR=<dest-dir>' with `make unix-style PREFIX=<dir>', which supply `DESTDIR=<dest-dir>` with `make unix-style PREFIX=<dir>`, which
assembles the installation in "<dest-dir>" (which must be an absolute assembles the installation in "<dest-dir>" (which must be an absolute
path). Then, copy the content of "<dest-dir>" to the target root path). Then, copy the content of "<dest-dir>" to the target root
"<dir>". "<dir>".
@ -102,33 +110,33 @@ More Instructions: Building Racket
================================== ==================================
The "racket" directory contains minimal Racket, which is just enough The "racket" directory contains minimal Racket, which is just enough
to run `raco pkg' to install everything else. The first step of `make to run `raco pkg` to install everything else. The first step of `make
in-place' or `make unix-style' is to build minimal Racket, and you can in-place` or `make unix-style` is to build minimal Racket, and you can
read "racket/src/README" for more information. read "racket/src/README" for more information.
If you would like to provide arguments to `configure' for the minimal If you would like to provide arguments to `configure` for the minimal
Racket build, then you can supply them with by adding Racket build, then you can supply them with by adding
`CONFIGURE_ARGS_qq="..."' to `make in-place' or `make `CONFIGURE_ARGS_qq="..."` to `make in-place` or `make
unix-style'. (The `_qq' suffix on the variable name is a convention unix-style`. (The `_qq` suffix on the variable name is a convention
that indicates that single- and double-quote marks are allowed in the that indicates that single- and double-quote marks are allowed in the
value.) value.)
The "pkgs" directory contains packages that are tied to the Racket The "pkgs" directory contains packages that are tied to the Racket
core implementation and are therefore kept in the same Git core implementation and are therefore kept in the same Git
repository. A `make in-place' links to the package in-place, while repository. A `make in-place` links to the package in-place, while
`make unix-style' copies packages out of "pkgs" to install them. `make unix-style` copies packages out of "pkgs" to install them.
To install a subset of the packages in "pkgs", supply `PKGS' value to To install a subset of the packages in "pkgs", supply `PKGS` value to
`make'. For example, `make`. For example,
make PKGS="gui-lib readline-lib" make PKGS="gui-lib readline-lib"
links only the "gui-lib" and "readline-lib" packages and their links only the "gui-lib" and "readline-lib" packages and their
dependencies. The default value of `PKGS' is "main-distribution dependencies. The default value of `PKGS` is "main-distribution
main-distribution-test". If you run `make' a second time, all main-distribution-test". If you run `make` a second time, all
previously installed packages remain installed and are updated, while previously installed packages remain installed and are updated, while
new packages are added. To uninstall previously selected package, use new packages are added. To uninstall previously selected package, use
`raco pkg remove'. `raco pkg remove`.
To build anything other than the latest sources in the repository To build anything other than the latest sources in the repository
(e.g., when building from the "v6.2.1" tag), you need a catalog (e.g., when building from the "v6.2.1" tag), you need a catalog
@ -136,40 +144,65 @@ that's compatible with those sources. Note that a release distribution
is configured to use a catalog specific to that release, so you can is configured to use a catalog specific to that release, so you can
extract the catalog's URL from there. extract the catalog's URL from there.
Using `make' (or `make in-place') sets the installation's name to Using `make` (or `make in-place`) sets the installation's name to
"development", unless the installation has been previously configured "development", unless the installation has been previously configured
(i.e., unless the "racket/etc/config.rktd" file exists). The (i.e., unless the "racket/etc/config.rktd" file exists). The
installation name affects, for example, the directory where installation name affects, for example, the directory where
user-specific documentation is installed. Using `make' also sets the user-specific documentation is installed. Using `make` also sets the
default package scope to `installation', which means that default package scope to `installation`, which means that
packages are installed by default into the installation's space instead packages are installed by default into the installation's space instead
of user-specific space. The name and/or default-scope configuration of user-specific space. The name and/or default-scope configuration
can be changed through `raco pkg config'. can be changed through `raco pkg config`.
Note that `make -j <n>' controls parallelism for the makefile part of Note that `make -j <n>` controls parallelism for the makefile part of
a build, but not for the `raco setup' part. To control both the a build, but not for the `raco setup` part. To control both the
makefile and the `raco setup' part, use makefile and the `raco setup` part, use
make CPUS=<n> make CPUS=<n>
which recurs with `make -j <n> JOB_OPTIONS="-j <n>"'. Setting `CPUS' which recurs with `make -j <n> JOB_OPTIONS="-j <n>"`. Setting `CPUS`
also works with `make unix-style'. also works with `make unix-style`.
Use `make as-is' (or `nmake win32-as-is') to perform the same build Use `make as-is` (or `nmake win32-as-is`) to perform the same build
actions as `make in-place`, but without consulting any package actions as `make in-place`, but without consulting any package
catalogs or package sources to install or update packages. In other catalogs or package sources to install or update packages. In other
words, use `make as-is' to rebuild after local changes that could words, use `make as-is` to rebuild after local changes that could
include changes to the Racket core. (If you change only packages, then include changes to the Racket core. (If you change only packages, then
`raco setup' should suffice.) `raco setup` should suffice.)
If you need even more control over the build, carry on to "Even More If you need even more control over the build, carry on to "Even More
Instructions: Building Racket Pieces". Instructions: Building Racket Pieces" further below.
More Instructions: Building Racket-on-Chez
==========================================
The `make cs` target (or `make cs-as-is` for a rebuild) builds an
experimental variant of Racket that runs on Chez Scheme. The
executables for the Racket-on-Chez variant all have a "cs" or "CS"
suffix, so they coexist with a traditional Racket build. (One day, if
the experiment goes well, there will be an option or default to build
Racket-on-Chez as `racket` instead of `racketcs`.)
Building Racket-on-Chez requires an existing Racket and Chez Scheme.
If you use `make cs` with no further arguments, then the build process
will bootstrap by building a traditional variant of Racket and by
downloading and building Chez Scheme.
If you have a sufficiently recent Racket installation already with at
least the "compiler-lib" and "parser-tools-libs" packages installed,
you can supply `RACKET=...` with `make cs` to skip that part of the
bootstrap. And if you have a Chez Scheme source directory already, you
can supply that with `SCHEME_SRC=...` instead of downloading a new
copy.
make cs RACKET=racket SCHEME_SRC=path/to/ChezScheme
Even More Instructions: Building Racket Pieces Even More Instructions: Building Racket Pieces
============================================== ==============================================
Instead of just using `make in-place' or `make unix-style', you can Instead of just using `make in-place` or `make unix-style`, you can
take more control over the build by understand how the pieces fit take more control over the build by understand how the pieces fit
together. together.
@ -181,25 +214,25 @@ and follow the "README" there, which gives you more configuration
options. options.
If you don't want any special configuration and you just want the base If you don't want any special configuration and you just want the base
build, you can use `make base' (or `nmake win32-base') with the build, you can use `make base` (or `nmake win32-base`) with the
top-level makefile. top-level makefile.
Minimal Racket does not require additional native libraries to run, Minimal Racket does not require additional native libraries to run,
but under Windows, encoding-conversion, extflonum, and SSL but under Windows, encoding-conversion, extflonum, and SSL
functionality is hobbled until native libraries from the functionality is hobbled until native libraries from the
`racket-win32-i386' or `racket-win32-x86_64' package are installed. `racket-win32-i386` or `racket-win32-x86_64` package are installed.
On all platforms, fom the top-level makefile, `JOB_OPTIONS' as a On all platforms, fom the top-level makefile, `JOB_OPTIONS` as a
makefile variable and `PLT_SETUP_OPTIONS' as an environment variable makefile variable and `PLT_SETUP_OPTIONS` as an environment variable
are passed on to the `raco setup' that is used to build minimal-Racket are passed on to the `raco setup` that is used to build minimal-Racket
libraries. See the documentation for `raco setup' for information on libraries. See the documentation for `raco setup` for information on
the options. the options.
For cross compilation, add configuration options to For cross compilation, add configuration options to
`CONFIGURE_ARGS_qq="..."' as described in the "README" of `CONFIGURE_ARGS_qq="..."` as described in the "README" of
"racket/src", but also add a `PLAIN_RACKET=...' argument for the "racket/src", but also add a `PLAIN_RACKET=...` argument for the
top-level makefile to specify the same executable as in an top-level makefile to specify the same executable as in an
`--enable-racket=...' for `configure'. In general, the `PLAIN_RACKET` `--enable-racket=...` for `configure`. In general, the `PLAIN_RACKET`
setting should have the form `PLAIN_RACKET="... -C"` to ensure that setting should have the form `PLAIN_RACKET="... -C"` to ensure that
cross-compilation mode is used and that any foreign libraries needed cross-compilation mode is used and that any foreign libraries needed
for build time can be found, but many cross-compilation scenarios work for build time can be found, but many cross-compilation scenarios work
@ -213,15 +246,15 @@ packages via the package-catalog server, completely ignoring the
content of "pkgs". content of "pkgs".
If you want to install packages manually out of the "pkgs" directory, If you want to install packages manually out of the "pkgs" directory,
the `local-catalog' target creates a catalog as "racket/local/catalog" the `local-catalog` target creates a catalog as "racket/local/catalog"
that merges the currently configured catalog's content with pointers that merges the currently configured catalog's content with pointers
to the packages in "pkgs". A Unix-style build works that way: it to the packages in "pkgs". A Unix-style build works that way: it
builds and installs minimal Racket, and then it installs packages out builds and installs minimal Racket, and then it installs packages out
of a catalog that is created by `make local-catalog'. of a catalog that is created by `make local-catalog`.
To add a package catalog that is used after the content of "pkgs" but To add a package catalog that is used after the content of "pkgs" but
before the default package catalogs, specify the catalog's URL as the before the default package catalogs, specify the catalog's URL as the
`SRC_CATALOG' makefile variable: `SRC_CATALOG` makefile variable:
make .... SRC_CATALOG=<url> make .... SRC_CATALOG=<url>
@ -229,19 +262,19 @@ Linking Packages for In-place Development Mode
---------------------------------------------- ----------------------------------------------
With an in-place build, you can edit packages within "pkgs" directly With an in-place build, you can edit packages within "pkgs" directly
or update those packages with `git pull' plus `raco setup', since the or update those packages with `git pull` plus `raco setup`, since the
packages are installed with the equivalent of `raco pkg install -i packages are installed with the equivalent of `raco pkg install -i
--static-link ...'. --static-link ...`.
Instead of actually using `raco pkg install --static-link ...`, the Instead of actually using `raco pkg install --static-link ...`, the
`pkgs-catalog' makefile target creates a catalog that points to the `pkgs-catalog` makefile target creates a catalog that points to the
packages in "pkgs", and the catalog indicates that the packages are to packages in "pkgs", and the catalog indicates that the packages are to
be installed as links. The `pkgs-catalog' target further configures be installed as links. The `pkgs-catalog` target further configures
the new catalog as the first one to check when installing the new catalog as the first one to check when installing
packages. The configuration adjustment is made only if no packages. The configuration adjustment is made only if no
configuration file "racket/etc/config.rktd" exists already. configuration file "racket/etc/config.rktd" exists already.
All other packages (as specified by `PKGS') are installed via the All other packages (as specified by `PKGS`) are installed via the
configured package catalog. They are installed in installation scope, but configured package catalog. They are installed in installation scope, but
the content of "racket/share/pkgs" is not meant to be edited. To the content of "racket/share/pkgs" is not meant to be edited. To
reinstall a package in a mode suitable for editing and manipulation reinstall a package in a mode suitable for editing and manipulation
@ -257,7 +290,7 @@ The Whole Enchilada: Building Installers
======================================== ========================================
To build installers that can be distributed to other users, do not use To build installers that can be distributed to other users, do not use
`make in-place' or `make unix-style', but instead start from a clean `make in-place` or `make unix-style`, but instead start from a clean
repository. repository.
Use one non-Windows machine as a server, where packages will be Use one non-Windows machine as a server, where packages will be
@ -266,24 +299,20 @@ installers on N client machines, each of which contacts the server
machine to obtain pre-built packages. The server can act as a client, machine to obtain pre-built packages. The server can act as a client,
naturally, to create an installer for the server's platform. naturally, to create an installer for the server's platform.
GNU `make' is required on the server machine, `nmake' is required on GNU `make` is required on the server machine, `nmake` is required on
Windows client machines, and any `make' should work on other client Windows client machines, and any `make` should work on other client
machines. machines.
Running Build Farms Running Build Farms
------------------- -------------------
The `installers' target of the makefile will do everything to generate The `installers` target of the makefile will do everything to generate
installers: build a server on the current machine, run clients on installers: build a server on the current machine, run clients on
hosts specified via CONFIG, and start/stop VirtualBox virtual machines hosts specified via CONFIG, and start/stop VirtualBox virtual machines
that act as client machines. that act as client machines.
See See the documentation of the "distro-build" package for a description
of the site-configuration module and requirements on client hosts.
pkgs/distro-build-pkgs/distro-build-client/doc.txt
for a description of the site-configuration module and requirements on
client hosts.
If "my-site-config.rkt" is a configuration module, then If "my-site-config.rkt" is a configuration module, then
@ -295,21 +324,22 @@ installer filenames in "build/installer/table.rktd". A log file
for each client is written to "build/log". for each client is written to "build/log".
The default CONFIG path is "build/site.rkt", so you could put your The default CONFIG path is "build/site.rkt", so you could put your
configuration file there and omit the `CONFIG' argument to configuration file there and omit the `CONFIG` argument to `make`. A
`make'. Supply `CONFIG_MODE=...' to pass a configuration mode on to default configuration file is created there automatically. Supply
your site-configuration module (accessible via the `current-mode' `CONFIG_MODE=...` to pass a configuration mode on to your
parameter). Supply `CLEAN_MODE=--clean' to make the default `#:clean?' site-configuration module (accessible via the `current-mode`
parameter). Supply `CLEAN_MODE=--clean` to make the default `#:clean?`
configuration for a client #t instead of #f, supply configuration for a client #t instead of #f, supply
`RELEASE_MODE=--release' to make the default `#:release?' `RELEASE_MODE=--release` to make the default `#:release?`
configuration #t, supply `SOURCE_MODE=--source` to make the default configuration #t, supply `SOURCE_MODE=--source` to make the default
`#:source?' configuration #t, and supply `VERSIONLESS_MODE=--version` `#:source?` configuration #t, and supply `VERSIONLESS_MODE=--version`
to make the default `#:versionless?' configuration #t. to make the default `#:versionless?` configuration #t.
A configuration file can specify the packages to include, host address A configuration file can specify the packages to include, host address
of the server, distribution name, installer directory, and of the server, distribution name, installer directory, and
documentation search URL, but defaults can be provided as `make' documentation search URL, but defaults can be provided as `make`
arguments via `PKGS', `SERVER' plus `SERVER_PORT` plus `SERVER_HOSTS`, arguments via `PKGS`, `SERVER` plus `SERVER_PORT` plus `SERVER_HOSTS`,
`DIST_NAME', `DIST_BASE', and `DIST_DIR', `DOC_SEARCH', `DIST_NAME`, `DIST_BASE`, and `DIST_DIR`, `DOC_SEARCH`,
respectively. The site configuration's top-level options for packages respectively. The site configuration's top-level options for packages
and documentation search URL are used to configure the set of packages and documentation search URL are used to configure the set of packages
that are available to client machines to include in installers. that are available to client machines to include in installers.
@ -320,9 +350,9 @@ is
<dist-base>-<version>-<platform>-<dist-suffix>.<ext> <dist-base>-<version>-<platform>-<dist-suffix>.<ext>
where <dist-base> defaults to "racket" (but can be set via where <dist-base> defaults to "racket" (but can be set via
`DIST_BASE'), <platform> is from `(system-library-subpath #f)' but `DIST_BASE`), <platform> is from `(system-library-subpath #f)` but
normalizing the Windows results to "i386-win32" and "x86_63-win32", normalizing the Windows results to "i386-win32" and "x86_63-win32",
-<dist-suffix> is omitted unless a `#:dist-suffix' string is specified -<dist-suffix> is omitted unless a `#:dist-suffix` string is specified
for the client in the site configuration, and <ext> is for the client in the site configuration, and <ext> is
platform-specific: ".sh" for Unix (including Linux), ".dmg" or ".pkg" platform-specific: ".sh" for Unix (including Linux), ".dmg" or ".pkg"
for Mac OS, and ".exe" for Windows. for Mac OS, and ".exe" for Windows.
@ -330,58 +360,58 @@ for Mac OS, and ".exe" for Windows.
Generating Installer Web Sites Generating Installer Web Sites
------------------------------ ------------------------------
The `site' target of the makefile uses the `installers' target to The `site` target of the makefile uses the `installers` target to
generate a set of installers, and then it combines the installers, generate a set of installers, and then it combines the installers,
packages, a package catalog, and log files into a directory that is packages, a package catalog, and log files into a directory that is
suitable for access via a web server. suitable for access via a web server.
Supply the same `CONFIG=...' and `CONFIG_MODE=...' arguments for Supply the same `CONFIG=...` and `CONFIG_MODE=...` arguments for
`site' as for `installers'. The configuration file should have a `site` as for `installers`. The configuration file should have a
`#:dist-base-url' entry for the URL where installers and packages will `#:dist-base-url` entry for the URL where installers and packages will
be made available; the `installers' target uses `#:dist-base-url' to be made available; the `installers` target uses `#:dist-base-url` to
embed suitable configuration into the installers. Specifically, embed suitable configuration into the installers. Specifically,
installers are configured to access pre-built packages and installers are configured to access pre-built packages and
documentation from the site indicated by `#:dist-base-url'. documentation from the site indicated by `#:dist-base-url`.
Note that `#:dist-base-url' should almost always end with "/", since Note that `#:dist-base-url` should almost always end with "/", since
others URLs will be constructed as relative to `#:dist-base-url'. others URLs will be constructed as relative to `#:dist-base-url`.
The site is generated as "build/site" by default. A `#:site-dest' The site is generated as "build/site" by default. A `#:site-dest`
entry in the configuration file can select an alternate destination. entry in the configuration file can select an alternate destination.
Use the `site-from-installers' makefile target to perform the part of Use the `site-from-installers` makefile target to perform the part of
`site' that happens after `installers' (i.e., to generate a `site' `site` that happens after `installers` (i.e., to generate a `site`
from an already-generated set of installers). from an already-generated set of installers).
Managing Snapshot Web Sites Managing Snapshot Web Sites
--------------------------- ---------------------------
The `snapshot-site' makefile target uses `site' (so supply the same The `snapshot-site` makefile target uses `site` (so supply the same
`CONFIG=...' and `CONFIG_MODE=...' arguments), and then treats the `CONFIG=...` and `CONFIG_MODE=...` arguments), and then treats the
resulting site as a snapshot with additional snapshot-management resulting site as a snapshot with additional snapshot-management
tasks. tasks.
For snapshot management, the destination of the files generated for For snapshot management, the destination of the files generated for
`site' (as specified by `#:site-dest') should be within a directory of `site` (as specified by `#:site-dest`) should be within a directory of
snapshots. The configuration file can use `(current-stamp)' to get a snapshots. The configuration file can use `(current-stamp)` to get a
string that represents the current build, and then use the string both string that represents the current build, and then use the string both
for `#:dist-base-url' and `#:site-dest'. Normally, the stamp string is for `#:dist-base-url` and `#:site-dest`. Normally, the stamp string is
a combination of the date and Git commit hash. a combination of the date and Git commit hash.
Snapshot management includes creating an "index.html" file in the Snapshot management includes creating an "index.html" file in the
snapshots directory (essentially a copy of the snapshot's own snapshots directory (essentially a copy of the snapshot's own
"index.html") and pruning snapshot subdirectories to keep the number "index.html") and pruning snapshot subdirectories to keep the number
of snapshots at the amount specified by `#:max-snapshots' of snapshots at the amount specified by `#:max-snapshots`
configuration-file entry (with a default value of 5). configuration-file entry (with a default value of 5).
Use the `snapshot-at-site' makefile target to perform the part of Use the `snapshot-at-site` makefile target to perform the part of
`snapshot-site that happens after `site (i.e., to manage snapshots `snapshot-site that happens after `site (i.e., to manage snapshots
around an already-generated site). around an already-generated site).
Separate Server and Clients Separate Server and Clients
--------------------------- ---------------------------
Instead of using the `installers' makefile target and a site Instead of using the `installers` makefile target and a site
configuration file, you can run server and client processes manually. configuration file, you can run server and client processes manually.
Roughly, the steps are Roughly, the steps are
@ -389,50 +419,50 @@ Roughly, the steps are
1. On the server machine: 1. On the server machine:
make server PKGS="..." make server PKGS="..."
See 1b below for more information on variables other than `PKGS' See 1b below for more information on variables other than `PKGS`
that you can provide with `make'. that you can provide with `make`.
2. On each client machine: 2. On each client machine:
make client SERVER=... PKGS="..." make client SERVER=... PKGS="..."
or or
nmake win32-client SERVER=... PKGS="..." nmake win32-client SERVER=... PKGS="..."
See 2b below for more information on variables other than `SERVER' See 2b below for more information on variables other than `SERVER`
and `PKGS' that you can provide with `make'. and `PKGS` that you can provide with `make`.
In more detail: In more detail:
1a. Build "racket" on a server. 1a. Build "racket" on a server.
The `base' target of the makefile will do that, if you haven't The `base` target of the makefile will do that, if you haven't
done it already. (The server only works on non-Windows platforms, done it already. (The server only works on non-Windows platforms,
currently.) currently.)
1b. On the server, build packages and start a catalog server. 1b. On the server, build packages and start a catalog server.
The `server-from-base' target of the makefile will do that. The `server-from-base` target of the makefile will do that.
Alternatively, use the `server' target, which combines `base' and Alternatively, use the `server` target, which combines `base` and
`server-from-base' (i.e., steps 1a and 1b). `server-from-base` (i.e., steps 1a and 1b).
The `SERVER_PORT' variable of the makefile choose the port on The `SERVER_PORT` variable of the makefile choose the port on
which the server listens to clients. The default is port 9440. which the server listens to clients. The default is port 9440.
The `SERVER_HOSTS' variable of the makefile determines the The `SERVER_HOSTS` variable of the makefile determines the
interfaces at which the server listens. The default is interfaces at which the server listens. The default is
"localhost" which listens only on the loopback device (for "localhost" which listens only on the loopback device (for
security). Supply the empty string to listen on all security). Supply the empty string to listen on all
interfaces. Supply multiple addresses by separating them with a interfaces. Supply multiple addresses by separating them with a
comma. comma.
The `PKGS' variable of the makefile determines which packages are The `PKGS` variable of the makefile determines which packages are
built for potential inclusion in a distribution. built for potential inclusion in a distribution.
The `DOC_SEARCH' variable of the makefile determine a URL that is The `DOC_SEARCH` variable of the makefile determine a URL that is
embedded in rendered documentation for cases where a remote embedded in rendered documentation for cases where a remote
search is needed (because other documentation is not installed). search is needed (because other documentation is not installed).
The `SRC_CATALOG' variable determines the catalog that is used to The `SRC_CATALOG` variable determines the catalog that is used to
get package sources and native-library packages. The default is get package sources and native-library packages. The default is
"http://pkgs.racket-lang.org". "http://pkgs.racket-lang.org".
@ -442,8 +472,8 @@ In more detail:
"README.txt" by default). "README.txt" by default).
If you stop the server and want to restart it, use the If you stop the server and want to restart it, use the
`built-package-server' makefile target instead of starting over `built-package-server` makefile target instead of starting over
with the `server' target. with the `server` target.
2a. On each client (one for each platform to bundle), build "racket". 2a. On each client (one for each platform to bundle), build "racket".
@ -452,94 +482,94 @@ In more detail:
2b. On each client, create an installer. 2b. On each client, create an installer.
The `client' (or `win32-client') target of the makefile will do The `client` (or `win32-client`) target of the makefile will do
that. that.
Provide `SERVER' as the hostname of the server machine, but a Provide `SERVER` as the hostname of the server machine, but a
"localhost"-based tunnel back to the server is more secure and "localhost"-based tunnel back to the server is more secure and
avoids the need to specify `SERVER_HOSTS' when starting the avoids the need to specify `SERVER_HOSTS` when starting the
server in step 1b. Also, provide `SERVER_PORT' if an alternate server in step 1b. Also, provide `SERVER_PORT` if an alternate
port was specified in step 1b. port was specified in step 1b.
Provide the same `PKGS' (or a subset) as in step 1b if you want a Provide the same `PKGS` (or a subset) as in step 1b if you want a
different set than the ones listed in the makefile. Similarly, different set than the ones listed in the makefile. Similarly,
`DOC_SEARCH' normally should be the same as in step 1b, but for a `DOC_SEARCH` normally should be the same as in step 1b, but for a
client, it affects future documentation builds in the client, it affects future documentation builds in the
installation. installation.
Alternatively, use the `client' target, which combines `base' and Alternatively, use the `client` target, which combines `base` and
`client-from-base' (i.e., steps 2a and 2b). `client-from-base` (i.e., steps 2a and 2b).
On Windows, you need NSIS installed, either in the usual location On Windows, you need NSIS installed, either in the usual location
or with `makensis' in your command-line path. or with `makensis` in your command-line path.
To create a release installer, provide `RELEASE_MODE' as To create a release installer, provide `RELEASE_MODE` as
"--release" to `make'. A release installer has slightly different "--release" to `make`. A release installer has slightly different
defaults that are suitable for infrequently updated release defaults that are suitable for infrequently updated release
installations, as opposed to frequently updated snapshot installations, as opposed to frequently updated snapshot
installations. installations.
To create a source archive, provide `SOURCE_MODE' as "--source" To create a source archive, provide `SOURCE_MODE` as "--source"
to `make'. to `make`.
To create an archive that omits the version number and also omit To create an archive that omits the version number and also omit
and version number in installer paths, provide `VERSIONLESS_MODE' as and version number in installer paths, provide `VERSIONLESS_MODE` as
"--versionless" to `make'. "--versionless" to `make`.
To change the human-readable name of the distribution as embedded To change the human-readable name of the distribution as embedded
in the installer, provide `DIST_NAME' to `make'. The default in the installer, provide `DIST_NAME` to `make`. The default
distribution name is "Racket". Whatever name you pick, the Racket distribution name is "Racket". Whatever name you pick, the Racket
version number is automatically added for various contexts. version number is automatically added for various contexts.
To change the base name of the installer file, provide `DIST_BASE' To change the base name of the installer file, provide `DIST_BASE`
to `make'. The default is "racket". to `make`. The default is "racket".
To change the directory name for installation on Unix (including To change the directory name for installation on Unix (including
Linux), provide `DIST_DIR' to `make'. The default is "racket". Linux), provide `DIST_DIR` to `make`. The default is "racket".
To add an extra piece to the installer's name, such as an To add an extra piece to the installer's name, such as an
identifier for a variant of Linux, provide `DIST_SUFFIX' to identifier for a variant of Linux, provide `DIST_SUFFIX` to
`make'. The default is "", which omits the prefix and its `make`. The default is "", which omits the prefix and its
preceding hyphen. preceding hyphen.
To set the description string for the installer, provide To set the description string for the installer, provide
`DIST_DESC' to `make'. The description string is recorded `DIST_DESC` to `make`. The description string is recorded
alongside the installer. alongside the installer.
To set the initial package catalogs URLs for an installation, To set the initial package catalogs URLs for an installation,
provide `DIST_CATALOGS_q' to `make'. Separate multiple URLs with provide `DIST_CATALOGS_q` to `make`. Separate multiple URLs with
a space, and use an empty string in place of a URL to indicate a space, and use an empty string in place of a URL to indicate
that the default catalogs should be used. The "_q" in the that the default catalogs should be used. The "_q" in the
variable name indicates that its value can include double quotes variable name indicates that its value can include double quotes
(but not single quotes) --- which are needed to specify an empty (but not single quotes) --- which are needed to specify an empty
string, for example. string, for example.
To select a "README" file for the client, provide `README' to To select a "README" file for the client, provide `README` to
`make'. The `README' value is used as a file name to download `make`. The `README` value is used as a file name to download
from the server. from the server.
To create a ".tgz" archive instead of an installer (or any To create a ".tgz" archive instead of an installer (or any
platform), set `TGZ_MODE' to "--tgz". platform), set `TGZ_MODE` to "--tgz".
For a Mac OS installer, set `SIGN_IDENTITY' as the name to For a Mac OS installer, set `SIGN_IDENTITY` as the name to
which the signing certificate is associated. Set `MAC_PKG_MODE' which the signing certificate is associated. Set `MAC_PKG_MODE`
to "--mac-pkg" to create a ".pkg" installer instead of a ".dmg" to "--mac-pkg" to create a ".pkg" installer instead of a ".dmg"
image. image.
For a Windows installer, set `OSSLSIGNCODE_ARGS_BASE64` as a For a Windows installer, set `OSSLSIGNCODE_ARGS_BASE64` as a
Base64 encoding of an S-expression for a list of argument strings Base64 encoding of an S-expression for a list of argument strings
for `osslsigncode`. The `-n', `-t', `-in', and `-out' arguments for `osslsigncode`. The `-n`, `-t`, `-in`, and `-out` arguments
are provided to `osslsigncode` automatically, so supply the are provided to `osslsigncode` automatically, so supply the
others. others.
The `SERVER_CATALOG_PATH' and `SERVER_COLLECTS_PATH' makefile The `SERVER_CATALOG_PATH` and `SERVER_COLLECTS_PATH` makefile
variables specify paths at `SERVER' plus `SERVER_PORT' to access variables specify paths at `SERVER` plus `SERVER_PORT` to access
the package catalog and pre-built "collects" tree needed for a the package catalog and pre-built "collects" tree needed for a
client, but those paths should be empty for a server started with client, but those paths should be empty for a server started with
`make server', and they are used mainly by `make `make server`, and they are used mainly by `make
client-from-site' (described below). client-from-site` (described below).
The `UPLOAD' makefile variable specifies a URL to use as an The `UPLOAD` makefile variable specifies a URL to use as an
upload destination for the created installed, where the upload destination for the created installed, where the
installer's name is added to the end of the URL, or leave as installer's name is added to the end of the URL, or leave as
empty for no upload. empty for no upload.
@ -551,26 +581,26 @@ the server, which leaves the installer in a "build/installers"
directory and records a mapping from the installer's description to directory and records a mapping from the installer's description to
its filename in "build/installers/table.rktd". its filename in "build/installers/table.rktd".
If you provide `JOB_OPTIONS=...' for either a client or server build, If you provide `JOB_OPTIONS=...` for either a client or server build,
the options are used both for `raco setup' and `raco pkg the options are used both for `raco setup` and `raco pkg
install'. Normally, `JOB_OPTIONS' is used to control parallelism. install`. Normally, `JOB_OPTIONS` is used to control parallelism.
Creating a Client from an Installer Web Site Creating a Client from an Installer Web Site
-------------------------------------------- --------------------------------------------
If you (or someone else) previously created an installer site with If you (or someone else) previously created an installer site with
`make site', then `make client-from-site` in a clean repository `make site`, then `make client-from-site` in a clean repository
creates an installer for the current platform drawing packages creates an installer for the current platform drawing packages
from the site. from the site.
At a minimum, provide `SERVER', `SERVER_PORT' (usually 80), and At a minimum, provide `SERVER`, `SERVER_PORT` (usually 80), and
`SITE_PATH' (if not empty, include a trailing "/") makefile variables `SITE_PATH` (if not empty, include a trailing "/") makefile variables
to access a site at to access a site at
http://$(SERVER):$(SERVER_PORT)/$(SITE_PATH) http://$(SERVER):$(SERVER_PORT)/$(SITE_PATH)
The `client-from-site' makefile target chains to `make client' while The `client-from-site` makefile target chains to `make client` while
passing suitable values for `DIST_CATALOGS_q`, `DOC_SEARCH`, passing suitable values for `DIST_CATALOGS_q`, `DOC_SEARCH`,
`SERVER_CATALOG_PATH', and `SERVER_COLLECTS_PATH'. Supply any other `SERVER_CATALOG_PATH`, and `SERVER_COLLECTS_PATH`. Supply any other
suitable variables, such as `DIST_NAME' or `RELEASE_MODE', the same as suitable variables, such as `DIST_NAME` or `RELEASE_MODE`, the same as
for `make client'. for `make client`.

159
Makefile
View File

@ -64,11 +64,24 @@ INSTALL_PKGS_ARGS = $(JOB_OPTIONS) --no-setup --pkgs \
ALL_PLT_SETUP_OPTIONS = $(JOB_OPTIONS) $(PLT_SETUP_OPTIONS) ALL_PLT_SETUP_OPTIONS = $(JOB_OPTIONS) $(PLT_SETUP_OPTIONS)
plain-in-place: plain-in-place:
$(MAKE) plain-minimal-in-place
$(MAKE) in-place-setup
plain-in-place-after-base:
$(MAKE) plain-minimal-in-place-after-base
$(MAKE) in-place-setup
plain-minimal-in-place:
$(MAKE) plain-base $(MAKE) plain-base
$(MAKE) plain-minimal-in-place-after-base
plain-minimal-in-place-after-base:
$(MAKE) pkgs-catalog $(MAKE) pkgs-catalog
$(RUN_RACO) pkg update $(UPDATE_PKGS_ARGS) $(RUN_RACO) pkg update $(UPDATE_PKGS_ARGS)
$(RUN_RACO) pkg install $(INSTALL_PKGS_ARGS) $(RUN_RACO) pkg install $(INSTALL_PKGS_ARGS)
$(RUN_RACO) setup --only-foreign-libs $(ALL_PLT_SETUP_OPTIONS) $(RUN_RACO) setup --only-foreign-libs $(ALL_PLT_SETUP_OPTIONS)
in-place-setup:
$(RUN_RACO) setup $(ALL_PLT_SETUP_OPTIONS) $(RUN_RACO) setup $(ALL_PLT_SETUP_OPTIONS)
win32-in-place: win32-in-place:
@ -91,7 +104,7 @@ cpus-as-is:
plain-as-is: plain-as-is:
$(MAKE) base $(MAKE) base
$(RUN_RACO) setup $(ALL_PLT_SETUP_OPTIONS) $(MAKE) in-place-setup
win32-as-is: win32-as-is:
$(MAKE) win32-base $(MAKE) win32-base
@ -148,7 +161,9 @@ set-src-catalog:
CONFIGURE_ARGS_qq = CONFIGURE_ARGS_qq =
SELF_FLAGS_qq = SELF_RACKET_FLAGS="-G `cd ../../../build/config; pwd`" SELF_UP =
SELF_FLAGS_qq = SELF_RACKET_FLAGS="-G `cd $(SELF_UP)../../../build/config; pwd`"
INSTALL_SETUP_ARGS = $(SELF_FLAGS_qq) PLT_SETUP_OPTIONS="$(JOB_OPTIONS) $(PLT_SETUP_OPTIONS)"
base: base:
if [ "$(CPUS)" = "" ] ; \ if [ "$(CPUS)" = "" ] ; \
@ -159,13 +174,16 @@ cpus-base:
$(MAKE) -j $(CPUS) plain-base JOB_OPTIONS="-j $(CPUS)" $(MAKE) -j $(CPUS) plain-base JOB_OPTIONS="-j $(CPUS)"
plain-base: plain-base:
mkdir -p build/config $(MAKE) base-config
echo '#hash((links-search-files . ()))' > build/config/config.rktd
mkdir -p racket/src/build mkdir -p racket/src/build
$(MAKE) racket/src/build/Makefile $(MAKE) racket/src/build/Makefile
cd racket/src/build; $(MAKE) reconfigure cd racket/src/build; $(MAKE) reconfigure
cd racket/src/build; $(MAKE) $(SELF_FLAGS_qq) cd racket/src/build; $(MAKE) $(SELF_FLAGS_qq)
cd racket/src/build; $(MAKE) install $(SELF_FLAGS_qq) PLT_SETUP_OPTIONS="$(JOB_OPTIONS) $(PLT_SETUP_OPTIONS)" cd racket/src/build; $(MAKE) install $(INSTALL_SETUP_ARGS)
base-config:
mkdir -p build/config
echo '#hash((links-search-files . ()))' > build/config/config.rktd
win32-base: win32-base:
$(MAKE) win32-remove-setup-dlls $(MAKE) win32-remove-setup-dlls
@ -195,6 +213,77 @@ native-for-cross:
racket/src/build/cross/Makefile: racket/src/configure racket/src/Makefile.in racket/src/build/cross/Makefile: racket/src/configure racket/src/Makefile.in
cd racket/src/build/cross; ../../configure cd racket/src/build/cross; ../../configure
# ------------------------------------------------------------
# Racket-on-Chez build
# If `RACKET` is not set, then we bootstrap by first building the
# traditional virtual machine
RACKET =
# If `SCHEME_SRC` is not set, then we'll download a copy of
# Chez Scheme from `CHEZ_SCHEME_REPO`
SCHEME_SRC =
DEFAULT_SCHEME_SRC = racket/src/build/ChezScheme
CHEZ_SCHEME_REPO = https://github.com/mflatt/ChezScheme
# Redirected for "as-is":
BASE_TARGET = plain-minimal-in-place
CS_SETUP_TARGET = plain-in-place-after-base
cs:
if [ "$(SCHEME_SRC)" = "" ] ; \
then $(MAKE) scheme-src ; fi
if [ "$(RACKET)" = "" ] ; \
then $(MAKE) racket-then-cs ; \
else $(MAKE) cs-after-racket-with-racket RACKET="$(RACKET)" ; fi
cs-as-is:
$(MAKE) cs BASE_TARGET=plain-base CS_SETUP_TARGET=in-place-setup
cs-after-racket:
if [ "$(RACKET)" = "" ] ; \
then $(MAKE) cs-after-racket-with-racket RACKET="$(PLAIN_RACKET)" ; \
else $(MAKE) cs-after-racket-with-racket RACKET="$(RACKET)" ; fi
racket-then-cs:
$(MAKE) $(BASE_TARGET) PKGS="compiler-lib parser-tools-lib"
$(RUN_RACO) setup $(ALL_PLT_SETUP_OPTIONS) -D -l compiler parser-tools
$(MAKE) cs-after-racket-with-racket RACKET="$(PLAIN_RACKET)"
ABS_RACKET = "`$(RACKET) racket/src/cs/absify.rkt --exec $(RACKET)`"
ABS_SCHEME_SRC = "`$(RACKET) racket/src/cs/absify.rkt $(SCHEME_SRC)`"
cs-after-racket-with-racket:
if [ "$(SCHEME_SRC)" = "" ] ; \
then $(MAKE) cs-after-racket-with-racket-and-scheme-src RACKET="$(RACKET)" SCHEME_SRC="$(DEFAULT_SCHEME_SRC)" ; \
else $(MAKE) cs-after-racket-with-racket-and-scheme-src RACKET="$(RACKET)" SCHEME_SRC="$(SCHEME_SRC)" ; fi
cs-after-racket-with-racket-and-scheme-src:
$(MAKE) cs-after-racket-with-abs-paths RACKET="$(ABS_RACKET)" SCHEME_SRC="$(ABS_SCHEME_SRC)" SELF_UP=../
cs-after-racket-with-abs-paths:
$(MAKE) racket/src/build/cs/Makefile
cd racket/src/build/cs; $(MAKE) RACKET="$(RACKET)" SCHEME_SRC="$(SCHEME_SRC)"
$(MAKE) base-config
cd racket/src/build/cs; $(MAKE) install RACKET="$(RACKET)" $(INSTALL_SETUP_ARGS)
$(MAKE) $(CS_SETUP_TARGET) PLAIN_RACKET=racket/bin/racketcs
racket/src/build/cs/Makefile: racket/src/cs/c/configure racket/src/cs/c/Makefile.in
mkdir -p cd racket/src/build/cs
cd racket/src/build/cs; ../../cs/c/configure
scheme-src:
$(MAKE) racket/src/build/ChezScheme
$(MAKE) update-ChezScheme
racket/src/build/ChezScheme:
mkdir -p racket/src/build
cd racket/src/build && git clone $(CHEZ_SCHEME_REPO)
update-ChezScheme:
cd racket/src/build/ChezScheme && git pull && git submodule update
# ------------------------------------------------------------ # ------------------------------------------------------------
# Configuration options for building installers # Configuration options for building installers
@ -331,8 +420,8 @@ SVR_CAT = http://$(SVR_PRT)/$(SERVER_CATALOG_PATH)
# Helper macros: # Helper macros:
USER_CONFIG = -G build/user/config -X racket/collects -A build/user USER_CONFIG = -G build/user/config -X racket/collects -A build/user
RACKET = $(PLAIN_RACKET) $(USER_CONFIG) USER_RACKET = $(PLAIN_RACKET) $(USER_CONFIG)
RACO = $(PLAIN_RACKET) $(USER_CONFIG) -N raco -l- raco USER_RACO = $(PLAIN_RACKET) $(USER_CONFIG) -N raco -l- raco
WIN32_RACKET = $(WIN32_PLAIN_RACKET) $(USER_CONFIG) WIN32_RACKET = $(WIN32_PLAIN_RACKET) $(USER_CONFIG)
WIN32_RACO = $(WIN32_PLAIN_RACKET) $(USER_CONFIG) -N raco -l- raco WIN32_RACO = $(WIN32_PLAIN_RACKET) $(USER_CONFIG) -N raco -l- raco
X_AUTO_OPTIONS = --skip-installed --deps search-auto --pkgs $(JOB_OPTIONS) X_AUTO_OPTIONS = --skip-installed --deps search-auto --pkgs $(JOB_OPTIONS)
@ -352,11 +441,11 @@ WIN32_IN_BUNDLE_RACO = bundle\racket\raco
# ------------------------------------------------------------ # ------------------------------------------------------------
# Linking all packages (development mode; not an installer build) # Linking all packages (development mode; not an installer build)
PKGS_CATALOG = -U -G build/config -l- pkg/dirs-catalog --link --check-metadata PKGS_CATALOG = -U -G build/config -l- pkg/dirs-catalog --link --check-metadata --immediate
PKGS_CONFIG = -U -G build/config racket/src/pkgs-config.rkt PKGS_CONFIG = -U -G build/config racket/src/pkgs-config.rkt
pkgs-catalog: pkgs-catalog:
$(RUN_RACKET) $(PKGS_CATALOG) racket/share/pkgs-catalog pkgs $(RUN_RACKET) $(PKGS_CATALOG) racket/share/pkgs-catalog pkgs racket/src/expander
$(RUN_RACKET) $(PKGS_CONFIG) "$(DEFAULT_SRC_CATALOG)" "$(SRC_CATALOG)" $(RUN_RACKET) $(PKGS_CONFIG) "$(DEFAULT_SRC_CATALOG)" "$(SRC_CATALOG)"
$(RUN_RACKET) racket/src/pkgs-check.rkt racket/share/pkgs-catalog $(RUN_RACKET) racket/src/pkgs-check.rkt racket/share/pkgs-catalog
@ -409,47 +498,47 @@ stamp-from-date:
build-from-catalog: build-from-catalog:
rm -rf build/user rm -rf build/user
rm -rf build/catalog-copy rm -rf build/catalog-copy
$(RACO) pkg catalog-copy "$(SRC_CATALOG)" build/catalog-copy $(USER_RACO) pkg catalog-copy "$(SRC_CATALOG)" build/catalog-copy
$(MAKE) server-cache-config $(MAKE) server-cache-config
$(RACO) pkg install --all-platforms $(SOURCE_USER_AUTO_q) $(REQUIRED_PKGS) $(DISTRO_BUILD_PKGS) $(USER_RACO) pkg install --all-platforms $(SOURCE_USER_AUTO_q) $(REQUIRED_PKGS) $(DISTRO_BUILD_PKGS)
$(MAKE) set-server-config $(MAKE) set-server-config
$(RACKET) -l- distro-build/pkg-info -o build/pkgs.rktd build/catalog-copy $(USER_RACKET) -l- distro-build/pkg-info -o build/pkgs.rktd build/catalog-copy
$(RACKET) -l distro-build/install-pkgs $(CONFIG_MODE_q) "$(PKGS) $(TEST_PKGS)" $(SOURCE_USER_AUTO_q) --all-platforms $(USER_RACKET) -l distro-build/install-pkgs $(CONFIG_MODE_q) "$(PKGS) $(TEST_PKGS)" $(SOURCE_USER_AUTO_q) --all-platforms
$(RACO) setup --avoid-main $(JOB_OPTIONS) $(USER_RACO) setup --avoid-main $(JOB_OPTIONS)
server-cache-config: server-cache-config:
$(RACO) pkg config -i --set download-cache-dir build/cache $(USER_RACO) pkg config -i --set download-cache-dir build/cache
$(RACO) pkg config -i --set download-cache-max-files 1023 $(USER_RACO) pkg config -i --set download-cache-max-files 1023
$(RACO) pkg config -i --set download-cache-max-bytes 671088640 $(USER_RACO) pkg config -i --set download-cache-max-bytes 671088640
set-server-config: set-server-config:
$(RACKET) -l distro-build/set-server-config build/user/config/config.rktd $(CONFIG_MODE_q) "" "" "$(DOC_SEARCH)" "" $(USER_RACKET) -l distro-build/set-server-config build/user/config/config.rktd $(CONFIG_MODE_q) "" "" "$(DOC_SEARCH)" ""
# Although a client will build its own "collects", pack up the # Although a client will build its own "collects", pack up the
# server's version to be used by each client, so that every client has # server's version to be used by each client, so that every client has
# exactly the same bytecode (which matters for SHA1-based dependency # exactly the same bytecode (which matters for SHA1-based dependency
# tracking): # tracking):
origin-collects: origin-collects:
$(RACKET) -l distro-build/pack-collects $(USER_RACKET) -l distro-build/pack-collects
# Now that we've built packages from local sources, create "built" # Now that we've built packages from local sources, create "built"
# versions of the packages from the installation into "build/user": # versions of the packages from the installation into "build/user":
built-catalog: built-catalog:
$(RACKET) -l distro-build/pack-built build/pkgs.rktd $(USER_RACKET) -l distro-build/pack-built build/pkgs.rktd
# Run a catalog server to provide pre-built packages, as well # Run a catalog server to provide pre-built packages, as well
# as the copy of the server's "collects" tree: # as the copy of the server's "collects" tree:
built-catalog-server: built-catalog-server:
if [ -d ".git" ]; then git update-server-info ; fi if [ -d ".git" ]; then git update-server-info ; fi
$(RACKET) -l distro-build/serve-catalog $(CONFIG_MODE_q) "$(SERVER_HOSTS)" $(SERVER_PORT) $(SERVE_DURING_CMD_qq) $(USER_RACKET) -l distro-build/serve-catalog $(CONFIG_MODE_q) "$(SERVER_HOSTS)" $(SERVER_PORT) $(SERVE_DURING_CMD_qq)
# Demonstrate how a catalog server for binary packages works, # Demonstrate how a catalog server for binary packages works,
# which involves creating package archives in "binary" mode # which involves creating package archives in "binary" mode
# instead of "built" mode: # instead of "built" mode:
binary-catalog: binary-catalog:
$(RACKET) -l- distro-build/pack-built --mode binary build/pkgs.rktd $(USER_RACKET) -l- distro-build/pack-built --mode binary build/pkgs.rktd
binary-catalog-server: binary-catalog-server:
$(RACKET) -l- distro-build/serve-catalog --mode binary $(CONFIG_MODE_q) "$(SERVER_HOSTS)" $(SERVER_PORT) $(USER_RACKET) -l- distro-build/serve-catalog --mode binary $(CONFIG_MODE_q) "$(SERVER_HOSTS)" $(SERVER_PORT)
# ------------------------------------------------------------ # ------------------------------------------------------------
# On each supported platform (for an installer build): # On each supported platform (for an installer build):
@ -485,7 +574,7 @@ client:
$(MAKE) base $(COPY_ARGS) $(MAKE) base $(COPY_ARGS)
$(MAKE) distro-build-from-server $(COPY_ARGS) $(MAKE) distro-build-from-server $(COPY_ARGS)
$(MAKE) bundle-from-server $(COPY_ARGS) $(MAKE) bundle-from-server $(COPY_ARGS)
$(RACKET) -l distro-build/set-config $(SET_BUNDLE_CONFIG_q) $(USER_RACKET) -l distro-build/set-config $(SET_BUNDLE_CONFIG_q)
$(MAKE) installer-from-bundle $(COPY_ARGS) $(MAKE) installer-from-bundle $(COPY_ARGS)
win32-client: win32-client:
@ -499,7 +588,7 @@ win32-client:
# Install the "distro-build" package from the server into # Install the "distro-build" package from the server into
# a local build: # a local build:
distro-build-from-server: distro-build-from-server:
$(RACO) pkg install $(REMOTE_USER_AUTO) distro-build-client $(USER_RACO) pkg install $(REMOTE_USER_AUTO) distro-build-client
# Copy our local build into a "bundle/racket" build, dropping in the # Copy our local build into a "bundle/racket" build, dropping in the
# process things that should not be in an installer (such as the "src" # process things that should not be in an installer (such as the "src"
@ -511,13 +600,13 @@ distro-build-from-server:
bundle-from-server: bundle-from-server:
rm -rf bundle rm -rf bundle
mkdir -p bundle/racket mkdir -p bundle/racket
$(RACKET) -l setup/unixstyle-install bundle racket bundle/racket $(USER_RACKET) -l setup/unixstyle-install bundle racket bundle/racket
$(RACKET) -l setup/winstrip bundle/racket $(USER_RACKET) -l setup/winstrip bundle/racket
$(RACKET) -l setup/winvers-change bundle/racket $(USER_RACKET) -l setup/winvers-change bundle/racket
$(RACKET) -l distro-build/unpack-collects http://$(SVR_PRT)/$(SERVER_COLLECTS_PATH) $(USER_RACKET) -l distro-build/unpack-collects http://$(SVR_PRT)/$(SERVER_COLLECTS_PATH)
$(BUNDLE_RACO) pkg install $(REMOTE_INST_AUTO) $(PKG_SOURCE_MODE) $(REQUIRED_PKGS) $(BUNDLE_RACO) pkg install $(REMOTE_INST_AUTO) $(PKG_SOURCE_MODE) $(REQUIRED_PKGS)
$(BUNDLE_RACO) pkg install $(REMOTE_INST_AUTO) $(PKG_SOURCE_MODE) $(PKGS) $(BUNDLE_RACO) pkg install $(REMOTE_INST_AUTO) $(PKG_SOURCE_MODE) $(PKGS)
$(RACKET) -l setup/unixstyle-install post-adjust "$(SOURCE_MODE)" "$(PKG_SOURCE_MODE)" racket bundle/racket $(USER_RACKET) -l setup/unixstyle-install post-adjust "$(SOURCE_MODE)" "$(PKG_SOURCE_MODE)" racket bundle/racket
UPLOAD_q = --readme "$(README)" --upload "$(UPLOAD)" --desc "$(DIST_DESC)" UPLOAD_q = --readme "$(README)" --upload "$(UPLOAD)" --desc "$(DIST_DESC)"
DIST_ARGS_q = $(UPLOAD_q) $(RELEASE_MODE) $(SOURCE_MODE) $(VERSIONLESS_MODE) \ DIST_ARGS_q = $(UPLOAD_q) $(RELEASE_MODE) $(SOURCE_MODE) $(VERSIONLESS_MODE) \
@ -528,7 +617,7 @@ DIST_ARGS_q = $(UPLOAD_q) $(RELEASE_MODE) $(SOURCE_MODE) $(VERSIONLESS_MODE) \
# Create an installer from the build (with installed packages) that's # Create an installer from the build (with installed packages) that's
# in "bundle/racket": # in "bundle/racket":
installer-from-bundle: installer-from-bundle:
$(RACKET) -l- distro-build/installer $(DIST_ARGS_q) $(USER_RACKET) -l- distro-build/installer $(DIST_ARGS_q)
win32-distro-build-from-server: win32-distro-build-from-server:
$(WIN32_RACO) pkg install $(REMOTE_USER_AUTO) distro-build-client $(WIN32_RACO) pkg install $(REMOTE_USER_AUTO) distro-build-client
@ -589,7 +678,7 @@ DRIVE_ARGS_q = $(RELEASE_MODE) $(VERSIONLESS_MODE) $(SOURCE_MODE) \
$(CLEAN_MODE) "$(CONFIG)" "$(CONFIG_MODE)" \ $(CLEAN_MODE) "$(CONFIG)" "$(CONFIG_MODE)" \
$(SERVER) $(SERVER_PORT) "$(SERVER_HOSTS)" \ $(SERVER) $(SERVER_PORT) "$(SERVER_HOSTS)" \
"$(PKGS)" "$(DOC_SEARCH)" "$(DIST_NAME)" $(DIST_BASE) $(DIST_DIR) "$(PKGS)" "$(DOC_SEARCH)" "$(DIST_NAME)" $(DIST_BASE) $(DIST_DIR)
DRIVE_CMD_q = $(RACKET) -l- distro-build/drive-clients $(DRIVE_ARGS_q) DRIVE_CMD_q = $(USER_RACKET) -l- distro-build/drive-clients $(DRIVE_ARGS_q)
# Full server build and clients drive, based on `CONFIG': # Full server build and clients drive, based on `CONFIG':
installers: installers:
@ -615,8 +704,8 @@ DOC_CATALOGS = build/built/catalog build/native/catalog
site-from-installers: site-from-installers:
rm -rf build/docs rm -rf build/docs
$(RACKET) -l- distro-build/install-for-docs build/docs $(CONFIG_MODE_q) "$(PKGS)" $(DOC_CATALOGS) $(USER_RACKET) -l- distro-build/install-for-docs build/docs $(CONFIG_MODE_q) "$(PKGS)" $(DOC_CATALOGS)
$(RACKET) -l- distro-build/assemble-site $(CONFIG_MODE_q) $(USER_RACKET) -l- distro-build/assemble-site $(CONFIG_MODE_q)
# ------------------------------------------------------------ # ------------------------------------------------------------
# Create a snapshot site: # Create a snapshot site:
@ -626,4 +715,4 @@ snapshot-site:
$(MAKE) snapshot-at-site $(MAKE) snapshot-at-site
snapshot-at-site: snapshot-at-site:
$(RACKET) -l- distro-build/manage-snapshots $(CONFIG_MODE_q) $(USER_RACKET) -l- distro-build/manage-snapshots $(CONFIG_MODE_q)

14
README.md
View File

@ -1,17 +1,11 @@
[![Linux/Mac Build This is the source code for the core of Racket. See "INSTALL.txt" for
Status](https://travis-ci.org/racket/racket.svg?branch=master)](https://travis-ci.org/racket/racket) full information on building Racket.
[![Windows build status](https://ci.appveyor.com/api/projects/status/hqir4eib0okk6xar?svg=true)](https://ci.appveyor.com/project/plt/racket)
This is the source code for the core of Racket. See
"INSTALL.txt" for full information on building Racket.
To build the full Racket distribution from this repository, run `make` To build the full Racket distribution from this repository, run `make`
in the top-level directory. To build the Minimal Racket, run `make in the top-level directory. To build minimal Racket, run `make base`.
base`.
The rest of the Racket distribution source code is in other The rest of the Racket distribution source code is in other
repositories under [the Racket GitHub repositories, mostly under [the Racket GitHub
organization](https://github.com/racket). organization](https://github.com/racket).
Contribute to Racket by submitting a pull request, joining the Contribute to Racket by submitting a pull request, joining the

2
pkgs/base/info.rkt
View File

@ -12,7 +12,7 @@
(define collection 'multi) (define collection 'multi)
(define version "6.12.0.4") (define version "6.90.0.16")
(define deps `("racket-lib" (define deps `("racket-lib"
["racket" #:version ,version])) ["racket" #:version ,version]))

4
pkgs/compiler-lib/compiler/commands/decompile.rkt
View File

@ -11,6 +11,7 @@
(string->symbol (short-program+command-name))) (string->symbol (short-program+command-name)))
(define force? #f) (define force? #f)
(define to-linklets? #f)
(define source-files (define source-files
(command-line (command-line
@ -24,6 +25,8 @@
(raise-user-error (get-name) (raise-user-error (get-name)
"not a valid column count: ~a" n)) "not a valid column count: ~a" n))
(pretty-print-columns num))] (pretty-print-columns num))]
[("--linklet") "Decompile to linklets"
(set! to-linklets? #t)]
#:args source-or-bytecode-file #:args source-or-bytecode-file
source-or-bytecode-file)) source-or-bytecode-file))
@ -85,6 +88,7 @@
[print-graph #t]) [print-graph #t])
(pretty-write (pretty-write
(decompile (decompile
#:to-linklets? to-linklets?
(call-with-input-file* (call-with-input-file*
(if (file-exists? alt-file) alt-file zo-file) (if (file-exists? alt-file) alt-file zo-file)
(lambda (in) (lambda (in)

12
pkgs/compiler-lib/compiler/commands/exe.rkt
View File

@ -10,7 +10,7 @@
(define very-verbose (make-parameter #f)) (define very-verbose (make-parameter #f))
(define gui (make-parameter #f)) (define gui (make-parameter #f))
(define 3m (make-parameter #t)) (define variant (make-parameter (system-type 'gc)))
(define launcher (make-parameter #f)) (define launcher (make-parameter #f))
(define exe-output (make-parameter #f)) (define exe-output (make-parameter #f))
@ -54,9 +54,11 @@
[("--orig-exe") "Use original executable instead of stub" [("--orig-exe") "Use original executable instead of stub"
(exe-aux (cons (cons 'original-exe? #t) (exe-aux)))] (exe-aux (cons (cons 'original-exe? #t) (exe-aux)))]
[("--3m") "Generate using 3m variant" [("--3m") "Generate using 3m variant"
(3m #t)] (variant '3m)]
[("--cgc") "Generate using CGC variant" [("--cgc") "Generate using CGC variant"
(3m #f)] (variant 'cgc)]
[("--cs") "Generate using CS variant"
(variant 'cs)]
#:multi #:multi
[("++aux") aux-file "Extra executable info (based on <aux-file> suffix)" [("++aux") aux-file "Extra executable info (based on <aux-file> suffix)"
(let ([auxes (extract-aux-from-path (path->complete-path aux-file))]) (let ([auxes (extract-aux-from-path (path->complete-path aux-file))])
@ -106,7 +108,7 @@
dest))))))) dest)))))))
(cond (cond
[(launcher) [(launcher)
(parameterize ([current-launcher-variant (if (3m) '3m 'cgc)]) (parameterize ([current-launcher-variant (variant)])
((if (gui) ((if (gui)
make-gracket-launcher make-gracket-launcher
make-racket-launcher) make-racket-launcher)
@ -123,7 +125,7 @@
(mzc:create-embedding-executable (mzc:create-embedding-executable
dest dest
#:mred? (gui) #:mred? (gui)
#:variant (if (3m) '3m 'cgc) #:variant (variant)
#:verbose? (very-verbose) #:verbose? (very-verbose)
#:modules (cons `(#%mzc: (file ,source-file) (main configure-runtime)) #:modules (cons `(#%mzc: (file ,source-file) (main configure-runtime))
(map (lambda (l) `(#t (lib ,l))) (map (lambda (l) `(#t (lib ,l)))

803
pkgs/compiler-lib/compiler/decompile.rkt
View File

@ -1,42 +1,37 @@
#lang racket/base #lang racket/base
(require compiler/zo-parse (require racket/linklet
compiler/zo-parse
compiler/zo-marshal
syntax/modcollapse syntax/modcollapse
racket/port racket/port
racket/match racket/match
racket/list racket/list
racket/set racket/set
racket/path) racket/path
(only-in '#%linklet compiled-position->primitive)
"private/deserialize.rkt")
(provide decompile) (provide decompile)
;; ---------------------------------------- ;; ----------------------------------------
(define primitive-table (define primitive-table
;; Figure out number-to-id mapping for kernel functions in `primitive' (let ([value-names (let ([ns (make-base-empty-namespace)])
(let ([bindings (parameterize ([current-namespace ns])
(let ([ns (make-base-empty-namespace)]) (namespace-require ''#%kernel)
(parameterize ([current-namespace ns]) (namespace-require ''#%unsafe)
(namespace-require ''#%kernel) (namespace-require ''#%flfxnum)
(namespace-require ''#%unsafe) (namespace-require ''#%extfl)
(namespace-require ''#%flfxnum) (namespace-require ''#%futures)
(namespace-require ''#%extfl) (namespace-require ''#%foreign)
(namespace-require ''#%futures) (namespace-require ''#%paramz)
(namespace-require ''#%foreign) (for/hasheq ([name (in-list (namespace-mapped-symbols))])
(for/list ([l (namespace-mapped-symbols)]) (values (namespace-variable-value name #t (lambda () #f))
(cons l (with-handlers ([exn:fail? (lambda (x) #f)]) name))))])
(compile l))))))] (for/hash ([i (in-naturals)]
[table (make-hash)]) #:break (not (compiled-position->primitive i)))
(for ([b (in-list bindings)]) (define v (compiled-position->primitive i))
(let ([v (and (cdr b) (values i (or (hash-ref value-names v #f) `',v)))))
(zo-parse
(open-input-bytes
(with-output-to-bytes
(λ () (write (cdr b)))))))])
(let ([n (match v
[(struct compilation-top (_ _ prefix (struct primval (n)))) n]
[else #f])])
(hash-set! table n (car b)))))
table))
(define (list-ref/protect l pos who) (define (list-ref/protect l pos who)
(list-ref l pos) (list-ref l pos)
@ -47,291 +42,194 @@
;; ---------------------------------------- ;; ----------------------------------------
(define-struct glob-desc (vars num-tls num-stxs num-lifts)) (define-struct glob-desc (vars))
;; Main entry: ;; Main entry:
(define (decompile top) (define (decompile top #:to-linklets? [to-linklets? #f])
(let ([stx-ht (make-hasheq)])
(match top
[(struct compilation-top (max-let-depth binding-namess prefix form))
(let-values ([(globs defns) (decompile-prefix prefix stx-ht)])
(expose-module-path-indexes
`(begin
,@defns
,(decompile-form form globs '(#%globals) (make-hasheq) stx-ht))))]
[else (error 'decompile "unrecognized: ~e" top)])))
(define (expose-module-path-indexes e)
;; This is a nearly general replace-in-graph function. (It seems like a lot
;; of work to expose module path index content and sharing, though.)
(define ht (make-hasheq))
(define mconses null)
(define (x-mcons a b)
(define m (mcons a b))
(set! mconses (cons (cons m (cons a b)) mconses))
m)
(define main
(let loop ([e e])
(cond
[(hash-ref ht e #f)]
[(module-path-index? e)
(define ph (make-placeholder #f))
(hash-set! ht e ph)
(define-values (name base) (module-path-index-split e))
(placeholder-set! ph (x-mcons '#%modidx
(x-mcons (loop name)
(x-mcons (loop base)
null))))
ph]
[(pair? e)
(define ph (make-placeholder #f))
(hash-set! ht e ph)
(placeholder-set! ph (cons (loop (car e))
(loop (cdr e))))
ph]
[(mpair? e)
(define m (mcons #f #f))
(hash-set! ht e m)
(set! mconses (cons (cons m (cons (loop (mcar e))
(loop (mcdr e))))
mconses))
m]
[(box? e)
(define ph (make-placeholder #f))
(hash-set! ht e ph)
(placeholder-set! ph (box (loop (unbox e))))
ph]
[(vector? e)
(define ph (make-placeholder #f))
(hash-set! ht e ph)
(placeholder-set! ph
(for/vector #:length (vector-length e) ([i (in-vector e)])
(loop i)))
ph]
[(hash? e)
(define ph (make-placeholder #f))
(hash-set! ht e ph)
(placeholder-set! ph
((cond
[(hash-eq? ht)
make-hasheq-placeholder]
[(hash-eqv? ht)
make-hasheqv-placeholder]
[else make-hash-placeholder])
(for/list ([(k v) (in-hash e)])
(cons (loop k) (loop v)))))
ph]
[(prefab-struct-key e)
=> (lambda (k)
(define ph (make-placeholder #f))
(hash-set! ht e ph)
(placeholder-set! ph
(apply make-prefab-struct
k
(map loop
(cdr (vector->list (struct->vector e))))))
ph)]
[else
e])))
(define l (make-reader-graph (cons main mconses)))
(for ([i (in-list (cdr l))])
(set-mcar! (car i) (cadr i))
(set-mcdr! (car i) (cddr i)))
(car l))
(define (decompile-prefix a-prefix stx-ht)
(match a-prefix
[(struct prefix (num-lifts toplevels stxs src-insp-desc))
(let ([lift-ids (for/list ([i (in-range num-lifts)])
(gensym 'lift))]
[stx-ids (map (lambda (i) (gensym 'stx))
stxs)])
(values (glob-desc
(append
(map (lambda (tl)
(match tl
[#f '#%linkage]
[(? symbol?) (string->symbol (format "_~a" tl))]
[(struct global-bucket (name))
(string->symbol (format "_~a" name))]
[(struct module-variable (modidx sym pos phase constantness))
(if (and (module-path-index? modidx)
(let-values ([(n b) (module-path-index-split modidx)])
(and (not n) (not b))))
(string->symbol (format "_~a" sym))
(string->symbol (format "_~s~a@~s~a"
sym
(match constantness
['constant ":c"]
['fixed ":f"]
[(function-shape a pm?)
(if pm? ":P" ":p")]
[(struct-type-shape c) ":t"]
[(constructor-shape a) ":mk"]
[(predicate-shape) ":?"]
[(accessor-shape c) ":ref"]
[(mutator-shape c) ":set!"]
[else ""])
(mpi->string modidx)
(if (zero? phase)
""
(format "/~a" phase)))))]
[else (error 'decompile-prefix "bad toplevel: ~e" tl)]))
toplevels)
stx-ids
(if (null? stx-ids) null '(#%stx-array))
lift-ids)
(length toplevels)
(length stxs)
num-lifts)
(list*
`(quote inspector ,src-insp-desc)
;; `(quote tls ,toplevels)
(map (lambda (stx id)
`(define ,id ,(if stx
`(#%decode-syntax
,(decompile-stx (stx-content stx) stx-ht))
#f)))
stxs stx-ids))))]
[else (error 'decompile-prefix "huh?: ~e" a-prefix)]))
(define (decompile-stx stx stx-ht)
(or (hash-ref stx-ht stx #f)
(let ([p (mcons #f #f)])
(hash-set! stx-ht stx p)
(match stx
[(stx-obj datum wrap srcloc props tamper-status)
(set-mcar! p (case tamper-status
[(clean) 'wrap]
[(tainted) 'wrap-tainted]
[(armed) 'wrap-armed]))
(set-mcdr! p (mcons
(cond
[(pair? datum)
(cons (decompile-stx (car datum) stx-ht)
(let loop ([l (cdr datum)])
(cond
[(null? l) null]
[(pair? l)
(cons (decompile-stx (car l) stx-ht)
(loop (cdr l)))]
[else
(decompile-stx l stx-ht)])))]
[(vector? datum)
(for/vector ([e (in-vector datum)])
(decompile-stx e stx-ht))]
[(box? datum)
(box (decompile-stx (unbox datum) stx-ht))]
[else datum])
(let* ([l (mcons wrap null)]
[l (if (hash-count props)
(mcons props l)
l)]
[l (if srcloc
(mcons srcloc l)
l)])
l)))
p]))))
(define (mpi->string modidx)
(cond (cond
[(symbol? modidx) modidx] [(linkl-directory? top)
[else (cond
(collapse-module-path-index modidx)])) [to-linklets?
(cons
'linklet-directory
(apply
append
(for/list ([(k v) (in-hash (linkl-directory-table top))])
(list '#:name k '#:bundle (decompile v #:to-linklets? to-linklets?)))))]
[else
(define main (hash-ref (linkl-directory-table top) '() #f))
(unless main (error 'decompile "cannot find main module"))
(decompile-module-with-submodules top '() main)])]
[(linkl-bundle? top)
(cond
[to-linklets?
(cons
'linklet-bundle
(apply
append
(for/list ([(k v) (in-hash (linkl-bundle-table top))])
(case (and (not to-linklets?) k)
[(stx-data)
(list '#:stx-data (decompile-data-linklet v))]
[else
(list '#:key k '#:value (decompile v #:to-linklets? to-linklets?))]))))]
[else
(decompile-module top)])]
[(linkl? top)
(decompile-linklet top)]
[else `(quote ,top)]))
(define (decompile-module mod-form orig-stack stx-ht mod-name) (define (decompile-module-with-submodules l-dir name-list main-l)
(match mod-form (decompile-module main-l
[(struct mod (name srcname self-modidx (lambda ()
prefix provides requires body syntax-bodies unexported (for/list ([(k l) (in-hash (linkl-directory-table l-dir))]
max-let-depth dummy lang-info #:when (and (list? k)
internal-context binding-names (= (length k) (add1 (length name-list)))
flags pre-submodules post-submodules)) (for/and ([s1 (in-list name-list)]
(let-values ([(globs defns) (decompile-prefix prefix stx-ht)] [s2 (in-list k)])
[(stack) (append '(#%modvars) orig-stack)] (eq? s1 s2))))
[(closed) (make-hasheq)]) (decompile-module-with-submodules l-dir k l)))))
`(,mod-name ,(if (symbol? name) name (last name)) ....
(quote self ,self-modidx)
(quote internal-context
,(if (stx? internal-context)
`(#%decode-syntax
,(decompile-stx (stx-content internal-context) stx-ht))
internal-context))
(quote bindings ,(for/hash ([(phase ht) (in-hash binding-names)])
(values phase
(for/hash ([(sym id) (in-hash ht)])
(values sym
(if (eq? id #t)
#t
`(#%decode-syntax
,(decompile-stx (stx-content id) stx-ht))))))))
(quote language-info ,lang-info)
,@(if (null? flags) '() (list `(quote ,flags)))
,@(let ([l (apply
append
(for/list ([req (in-list requires)]
#:when (pair? (cdr req)))
(define l (for/list ([mpi (in-list (cdr req))])
(define p (mpi->string mpi))
(if (path? p)
(let ([d (current-load-relative-directory)])
(path->string (if d
(find-relative-path (simplify-path d #t)
(simplify-path p #f)
#:more-than-root? #t)
p)))
p)))
(if (eq? 0 (car req))
l
`((,@(case (car req)
[(#f) `(for-label)]
[(1) `(for-syntax)]
[else `(for-meta ,(car req))])
,@l)))))])
(if (null? l)
null
`((require ,@l))))
(provide ,@(apply
append
(for/list ([p (in-list provides)])
(define phase (car p))
(define l
(for/list ([pv (in-list (append (cadr p) (caddr p)))])
(match pv
[(struct provided (name src src-name nom-src src-phase protected?))
(define n (if (eq? name src-name)
name
`(rename-out [,src-name ,name])))
(if protected?
`(protect-out ,n)
n)])))
(if (or (null? l) (eq? phase 0))
l
`((,@(case phase
[(#f) `(for-label)]
[(1) `(for-syntax)]
[else `(for-meta ,phase)])
,@l))))))
,@defns
,@(for/list ([submod (in-list pre-submodules)])
(decompile-module submod orig-stack stx-ht 'module))
,@(for/list ([b (in-list syntax-bodies)])
(let loop ([n (sub1 (car b))])
(if (zero? n)
(cons 'begin
(for/list ([form (in-list (cdr b))])
(decompile-form form globs stack closed stx-ht)))
(list 'begin-for-syntax (loop (sub1 n))))))
,@(map (lambda (form)
(decompile-form form globs stack closed stx-ht))
body)
,@(for/list ([submod (in-list post-submodules)])
(decompile-module submod orig-stack stx-ht 'module*))))]
[else (error 'decompile-module "huh?: ~e" mod-form)]))
(define (decompile-form form globs stack closed stx-ht) (define (decompile-module l [get-nested (lambda () '())])
(define ht (linkl-bundle-table l))
(define phases (sort (for/list ([k (in-hash-keys ht)]
#:when (exact-integer? k))
k)
<))
(define-values (mpi-vector requires provides)
(let ([data-l (hash-ref ht 'data #f)]
[decl-l (hash-ref ht 'decl #f)])
(define (zo->linklet l)
(let ([o (open-output-bytes)])
(zo-marshal-to (linkl-bundle (hasheq 'data l)) o)
(parameterize ([read-accept-compiled #t])
(define b (read (open-input-bytes (get-output-bytes o))))
(hash-ref (linklet-bundle->hash b) 'data))))
(cond
[(and data-l
decl-l)
(define data-i (instantiate-linklet (zo->linklet data-l)
(list deserialize-instance)))
(define decl-i (instantiate-linklet (zo->linklet decl-l)
(list deserialize-instance
data-i)))
(values (instance-variable-value data-i '.mpi-vector)
(instance-variable-value decl-i 'requires)
(instance-variable-value decl-i 'provides))]
[else (values '#() '() '())])))
(define (phase-wrap phase l)
(case phase
[(0) l]
[(1) `((for-syntax ,@l))]
[(-1) `((for-template ,@l))]
[(#f) `((for-label ,@l))]
[else `((for-meta ,phase ,@l))]))
`(module ,(hash-ref ht 'name 'unknown) ....
(require ,@(apply
append
(for/list ([phase+mpis (in-list requires)])
(phase-wrap (car phase+mpis)
(map collapse-module-path-index (cdr phase+mpis))))))
(provide ,@(apply
append
(for/list ([(phase ht) (in-hash provides)])
(phase-wrap phase (hash-keys ht)))))
,@(let loop ([phases phases] [depth 0])
(cond
[(null? phases) '()]
[(= depth (car phases))
(append
(decompile-linklet (hash-ref ht (car phases)) #:just-body? #t)
(loop (cdr phases) depth))]
[else
(define l (loop phases (add1 depth)))
(define (convert-syntax-definition s wrap)
(match s
[`(let ,bindings ,body)
(convert-syntax-definition body
(lambda (rhs)
`(let ,bindings
,rhs)))]
[`(begin (.set-transformer! ',id ,rhs) ',(? void?))
`(define-syntaxes ,id ,(wrap rhs))]
[`(begin (.set-transformer! ',ids ,rhss) ... ',(? void?))
`(define-syntaxes ,ids ,(wrap `(values . ,rhss)))]
[_ #f]))
(let loop ([l l] [accum '()])
(cond
[(null? l) (if (null? accum)
'()
`((begin-for-syntax ,@(reverse accum))))]
[(convert-syntax-definition (car l) values)
=> (lambda (s)
(append (loop null accum)
(cons s (loop (cdr l) null))))]
[else
(loop (cdr l) (cons (car l) accum))]))]))
,@(get-nested)
,@(let ([l (hash-ref ht 'stx-data #f)])
(if l
`((begin-for-all
(define (.get-syntax-literal! pos)
....
,(decompile-data-linklet l)
....)))
null))))
(define (decompile-linklet l #:just-body? [just-body? #f])
(match l
[(struct linkl (name importss import-shapess exports internals lifts source-names body max-let-depth needs-instance?))
(define closed (make-hasheq))
(define globs (glob-desc
(append
(list 'root)
(apply append importss)
exports
internals
lifts)))
(define body-l
(for/list ([form (in-list body)])
(decompile-form form globs '(#%globals) closed)))
(if just-body?
body-l
`(linklet
,importss
,exports
'(import-shapes: ,@(for/list ([imports (in-list importss)]
[import-shapes (in-list import-shapess)]
#:when #t
[import (in-list imports)]
[import-shape (in-list import-shapes)]
#:when import-shape)
`[,import ,import-shape]))
,@body-l))]))
(define (decompile-data-linklet l)
(match l
[(struct linkl (_ _ _ _ _ _ _ (list vec-def (struct def-values (_ deser-lam))) _ _))
(match deser-lam
[(struct lam (_ _ _ _ _ _ _ _ _ (struct seq ((list vec-copy! _)))))
(match vec-copy!
[(struct application (_ (list _ _ (struct application (_ (list mpi-vector inspector bulk-binding-registry
num-mutables mutable-vec
num-shares share-vec
mutable-fill-vec
result-vec))))))
(decompile-deserialize '.mpi-vector '.inspector '.bulk-binding-registry
num-mutables mutable-vec
num-shares share-vec
mutable-fill-vec
result-vec)]
[else
(decompile-linklet l)])]
[else
(decompile-linklet l)])]
[else
(decompile-linklet l)]))
(define (decompile-form form globs stack closed)
(match form (match form
[(? mod?)
(decompile-module form stack stx-ht 'module)]
[(struct def-values (ids rhs)) [(struct def-values (ids rhs))
`(define-values ,(map (lambda (tl) `(define-values ,(map (lambda (tl)
(match tl (match tl
@ -344,29 +242,10 @@
,(decompile-expr (inline-variant-inline rhs) globs stack closed) ,(decompile-expr (inline-variant-inline rhs) globs stack closed)
,(decompile-expr (inline-variant-direct rhs) globs stack closed)) ,(decompile-expr (inline-variant-direct rhs) globs stack closed))
(decompile-expr rhs globs stack closed)))] (decompile-expr rhs globs stack closed)))]
[(struct def-syntaxes (ids rhs prefix max-let-depth dummy))
`(define-syntaxes ,ids
,(let-values ([(globs defns) (decompile-prefix prefix stx-ht)])
`(let ()
,@defns
,(decompile-form rhs globs '(#%globals) closed stx-ht))))]
[(struct seq-for-syntax (exprs prefix max-let-depth dummy))
`(begin-for-syntax
,(let-values ([(globs defns) (decompile-prefix prefix stx-ht)])
`(let ()
,@defns
,@(for/list ([rhs (in-list exprs)])
(decompile-form rhs globs '(#%globals) closed stx-ht)))))]
[(struct seq (forms)) [(struct seq (forms))
`(begin ,@(map (lambda (form) `(begin ,@(map (lambda (form)
(decompile-form form globs stack closed stx-ht)) (decompile-form form globs stack closed))
forms))] forms))]
[(struct splice (forms))
`(begin ,@(map (lambda (form)
(decompile-form form globs stack closed stx-ht))
forms))]
[(struct req (reqs dummy))
`(#%require . (#%decode-syntax ,reqs))]
[else [else
(decompile-expr form globs stack closed)])) (decompile-expr form globs stack closed)]))
@ -417,12 +296,12 @@
(match expr (match expr
[(struct toplevel (depth pos const? ready?)) [(struct toplevel (depth pos const? ready?))
(decompile-tl expr globs stack closed #f)] (decompile-tl expr globs stack closed #f)]
[(struct varref (tl dummy)) [(struct varref (tl dummy constant? from-unsafe?))
`(#%variable-reference ,(if (eq? tl #t) `(#%variable-reference . ,(cond
'<constant-local> [(not tl) '()]
(decompile-tl tl globs stack closed #t)))] [(eq? tl #t) '(<constant-local>)]
[(struct topsyntax (depth pos midpt)) [(symbol? tl) (list tl)] ; primitive
(list-ref/protect (glob-desc-vars globs) (+ midpt pos) 'topsyntax)] [else (list (decompile-tl tl globs stack closed #t))]))]
[(struct primval (id)) [(struct primval (id))
(hash-ref primitive-table id (lambda () (error "unknown primitive: " id)))] (hash-ref primitive-table id (lambda () (error "unknown primitive: " id)))]
[(struct assign (id rhs undef-ok?)) [(struct assign (id rhs undef-ok?))
@ -558,20 +437,9 @@
'() '()
(list (list
(for/list ([pos (in-list (sort (set->list tl-map) <))]) (for/list ([pos (in-list (sort (set->list tl-map) <))])
(define tl-pos (list-ref/protect (glob-desc-vars globs)
(cond pos
[(or (pos . < . (glob-desc-num-tls globs)) 'lam)))))))
(zero? (glob-desc-num-stxs globs)))
pos]
[(= pos (glob-desc-num-tls globs))
'stx]
[else
(+ pos (glob-desc-num-stxs globs))]))
(if (eq? tl-pos 'stx)
'#%syntax
(list-ref/protect (glob-desc-vars globs)
tl-pos
'lam))))))))
,(decompile-expr body globs ,(decompile-expr body globs
(append captures (append captures
(append vars rest-vars)) (append vars rest-vars))
@ -585,6 +453,249 @@
;; ---------------------------------------- ;; ----------------------------------------
(define (decompile-deserialize mpis inspector bulk-binding-registry
num-mutables mutable-vec
num-shares share-vec
mutable-fill-vec
result-vec)
;; Names for shared values:
(define shared (for/vector ([i (in-range (+ num-mutables num-shares))])
(string->symbol (format "~a:~a"
(if (i . < . num-mutables)
'mutable
'shared)
i))))
(define (infer-name! d i)
(when (pair? d)
(define new-name
(case (car d)
[(deserialize-scope) 'scope]
[(srcloc) 'srcloc]
[else #f]))
(when new-name
(vector-set! shared i (string->symbol (format "~a:~a" new-name i))))))
(define mutables (make-vector num-mutables #f))
;; Make mutable shells
(for/fold ([pos 0]) ([i (in-range num-mutables)])
(define-values (d next-pos)
(decode-shell mutable-vec pos mpis inspector bulk-binding-registry shared))
(vector-set! mutables i d)
(infer-name! d i)
next-pos)
;; Construct shared values
(define shareds (make-vector num-shares #f))
(for/fold ([pos 0]) ([i (in-range num-shares)])
(define-values (d next-pos)
(decode share-vec pos mpis inspector bulk-binding-registry shared))
(vector-set! shareds i d)
(infer-name! d (+ i num-mutables))
next-pos)
;; Fill in mutable shells
(define-values (fill-pos rev-fills)
(for/fold ([pos 0] [rev-fills null]) ([i (in-range num-mutables)]
[v (in-vector shared)])
(define-values (fill next-pos)
(decode-fill! v mutable-fill-vec pos mpis inspector bulk-binding-registry shared))
(values next-pos (if fill
(cons fill rev-fills)
rev-fills))))
;; Construct the final result
(define-values (result done-pos)
(decode result-vec 0 mpis inspector bulk-binding-registry shared))
`(let (,(for/list ([i (in-range num-mutables)])
`(,(vector-ref shared i) ,(vector-ref mutables i))))
(let* (,(for/list ([i (in-range num-shares)])
`(,(vector-ref shared (+ i num-mutables)) ,(vector-ref shareds i))))
,@(reverse rev-fills)
,result)))
;; Decode the construction of a mutable variable
(define (decode-shell vec pos mpis inspector bulk-binding-registry shared)
(case (vector-ref vec pos)
[(#:box) (values (list 'box #f) (add1 pos))]
[(#:vector) (values `(make-vector ,(vector-ref vec (add1 pos))) (+ pos 2))]
[(#:hash) (values (list 'make-hasheq) (add1 pos))]
[(#:hasheq) (values (list 'make-hasheq) (add1 pos))]
[(#:hasheqv) (values (list 'make-hasheqv) (add1 pos))]
[else (decode vec pos mpis inspector bulk-binding-registry shared)]))
;; The decoder that is used for most purposes
(define (decode vec pos mpis inspector bulk-binding-registry shared)
(define-syntax decodes
(syntax-rules ()
[(_ (id ...) rhs) (decodes #:pos (add1 pos) (id ...) rhs)]
[(_ #:pos pos () rhs) (values rhs pos)]
[(_ #:pos pos ([#:ref id0] id ...) rhs)
(let-values ([(id0 next-pos) (let ([i (vector-ref vec pos)])
(if (exact-integer? i)
(values (vector-ref shared i) (add1 pos))
(decode vec pos mpis inspector bulk-binding-registry shared)))])
(decodes #:pos next-pos (id ...) rhs))]
[(_ #:pos pos (id0 id ...) rhs)
(let-values ([(id0 next-pos) (decode vec pos mpis inspector bulk-binding-registry shared)])
(decodes #:pos next-pos (id ...) rhs))]))
(define-syntax-rule (decode* (deser id ...))
(decodes (id ...) `(deser ,id ...)))
(case (vector-ref vec pos)
[(#:ref)
(values (vector-ref shared (vector-ref vec (add1 pos)))
(+ pos 2))]
[(#:inspector) (values inspector (add1 pos))]
[(#:bulk-binding-registry) (values bulk-binding-registry (add1 pos))]
[(#:syntax #:datum->syntax)
(decodes
(content [#:ref context] [#:ref srcloc])
`(deserialize-syntax
,content
,context
,srcloc
#f
#f
,inspector))]
[(#:syntax+props)
(decodes
(content [#:ref context] [#:ref srcloc] props tamper)
`(deserialize-syntax
,content
,context
,srcloc
,props
,tamper
,inspector))]
[(#:srcloc)
(decode* (srcloc source line column position span))]
[(#:quote)
(values (vector-ref vec (add1 pos)) (+ pos 2))]
[(#:mpi)
(values `(vector-ref ,mpis ,(vector-ref vec (add1 pos)))
(+ pos 2))]
[(#:box)
(decode* (box-immutable v))]
[(#:cons)
(decode* (cons a d))]
[(#:list #:vector #:set #:seteq #:seteqv)
(define len (vector-ref vec (add1 pos)))
(define r (make-vector len))
(define next-pos
(for/fold ([pos (+ pos 2)]) ([i (in-range len)])
(define-values (v next-pos) (decodes #:pos pos (v) v))
(vector-set! r i v)
next-pos))
(values `(,(case (vector-ref vec pos)
[(#:list) 'list]
[(#:vector) 'vector]
[(#:set) 'set]
[(#:seteq) 'seteq]
[(#:seteqv) 'seteqv])
,@(vector->list r))
next-pos)]
[(#:hash #:hasheq #:hasheqv)
(define len (vector-ref vec (add1 pos)))
(define-values (l next-pos)
(for/fold ([l null] [pos (+ pos 2)]) ([i (in-range len)])
(decodes #:pos pos (k v) (list* v k l))))
(values `(,(case (vector-ref vec pos)
[(#:hash) 'hash]
[(#:hasheq) 'hasheq]
[(#:hasheqv) 'hasheqv])
,@(reverse l))
next-pos)]
[(#:prefab)
(define-values (key next-pos) (decodes #:pos (add1 pos) (k) k))
(define len (vector-ref vec next-pos))
(define-values (r done-pos)
(for/fold ([r null] [pos (add1 next-pos)]) ([i (in-range len)])
(decodes #:pos pos (v) (cons v r))))
(values `(make-prefab-struct ',key ,@(reverse r))
done-pos)]
[(#:scope)
(decode* (deserialize-scope))]
[(#:scope+kind)
(decode* (deserialize-scope kind))]
[(#:multi-scope)
(decode* (deserialize-multi-scope name scopes))]
[(#:shifted-multi-scope)
(decode* (deserialize-shifted-multi-scope phase multi-scope))]
[(#:table-with-bulk-bindings)
(decode* (deserialize-table-with-bulk-bindings syms bulk-bindings))]
[(#:bulk-binding-at)
(decode* (deserialize-bulk-binding-at scopes bulk))]
[(#:representative-scope)
(decode* (deserialize-representative-scope kind phase))]
[(#:module-binding)
(decode* (deserialize-full-module-binding
module sym phase
nominal-module
nominal-phase
nominal-sym
nominal-require-phase
free=id
extra-inspector
extra-nominal-bindings))]
[(#:simple-module-binding)
(decode* (deserialize-simple-module-binding module sym phase nominal-module))]
[(#:local-binding)
(decode* (deserialize-full-local-binding key free=id))]
[(#:bulk-binding)
(decode* (deserialize-bulk-binding prefix excepts mpi provide-phase-level phase-shift bulk-binding-registry))]
[(#:provided)
(decode* (deserialize-provided binding protected? syntax?))]
[else
(values `(quote ,(vector-ref vec pos)) (add1 pos))]))
;; Decode the filling of mutable values, which has its own encoding
;; variant
(define (decode-fill! v vec pos mpis inspector bulk-binding-registry shared)
(case (vector-ref vec pos)
[(#f) (values #f (add1 pos))]
[(#:set-box!)
(define-values (c next-pos)
(decode vec (add1 pos) mpis inspector bulk-binding-registry shared))
(values `(set-box! ,v ,c)
next-pos)]
[(#:set-vector!)
(define len (vector-ref vec (add1 pos)))
(define-values (l next-pos)
(for/fold ([l null] [pos (+ pos 2)]) ([i (in-range len)])
(define-values (c next-pos)
(decode vec pos mpis inspector bulk-binding-registry shared))
(values (cons `(vector-set! ,v ,i ,c) l)
next-pos)))
(values `(begin ,@(reverse l)) next-pos)]
[(#:set-hash!)
(define len (vector-ref vec (add1 pos)))
(define-values (l next-pos)
(for/fold ([l null] [pos (+ pos 2)]) ([i (in-range len)])
(define-values (key next-pos)
(decode vec pos mpis inspector bulk-binding-registry shared))
(define-values (val done-pos)
(decode vec next-pos mpis inspector bulk-binding-registry shared))
(values (cons `(hash-set! ,v ,key ,val) l)
done-pos)))
(values `(begin ,@(reverse l)) next-pos)]
[(#:scope-fill!)
(define-values (c next-pos)
(decode vec (add1 pos) mpis inspector bulk-binding-registry shared))
(values `(deserialize-scope-fill! ,v ,c)
next-pos)]
[(#:representative-scope-fill!)
(define-values (a next-pos)
(decode vec (add1 pos) mpis inspector bulk-binding-registry shared))
(define-values (d done-pos)
(decode vec next-pos mpis inspector bulk-binding-registry shared))
(values `(deserialize-representative-scope-fill! ,v ,a ,d)
done-pos)]
[else
(error 'deserialize "bad fill encoding: ~v" (vector-ref vec pos))]))
;; ----------------------------------------
#; #;
(begin (begin
(require scheme/pretty) (require scheme/pretty)

20
pkgs/compiler-lib/compiler/demodularizer/alpha.rkt
View File

@ -1,20 +0,0 @@
#lang racket/base
(require racket/match racket/contract compiler/zo-parse)
(define (alpha-vary-ctop top)
(match top
[(struct compilation-top (max-let-depth binding-namess prefix form))
(make-compilation-top max-let-depth binding-namess (alpha-vary-prefix prefix) form)]))
(define (alpha-vary-prefix p)
(struct-copy prefix p
[toplevels
(map (match-lambda
[(and sym (? symbol?))
(gensym sym)]
[other
other])
(prefix-toplevels p))]))
(provide/contract
[alpha-vary-ctop (compilation-top? . -> . compilation-top?)])

41
pkgs/compiler-lib/compiler/demodularizer/batch.rkt
View File

@ -1,50 +1,9 @@
#lang racket/base #lang racket/base
#|
Here's the idea:
- Take a module's bytecode
- Recursively get all the bytecode for modules that the target requires
- After reading it, prune everything that isn't at phase 0 (the runtime phase)
- Now that we have all the modules, the next step is to merge them into a single
module
-- Although actually we collapse them into the top-level, not a module
- To do that, we iterate through all the modules doing two things as we go:
-- Incrementing all the global variable references by all the references in all
the modules
--- So if A has 5, then B's start at index 5 and so on
-- Replacing module variable references with the actual global variables
corresponding to those variables
--- So if A's variable 'x' is in global slot 4, then if B refers to it, it
directly uses slot 4, rather than a module-variable slot
- At that point we have all the module code in a single top-level, but many
toplevels won't be used because a library function isn't really used
- So, we do a "garbage collection" on elements of the prefix
- First, we create a dependency graph of all toplevels and the initial scope
- Then, we do a DFS on the initial scope and keep all those toplevels, throwing
away the construction of everything else
[XXX: This may be broken because of side-effects.]
- Now we have a small amount code, but because we want to go back to source,
we need to fix it up a bit; because different modules may've used the same
names
- So, we do alpha-renaming, but it's easy because names are only used in the
compilation-top prefix structure
[TODO]
- Next, we decompile
- Then, it will pay to do dead code elimination and inlining, etc.
|#
(require racket/cmdline (require racket/cmdline
racket/set racket/set
raco/command-name raco/command-name
"main.rkt") "main.rkt")
(let ([output-file (make-parameter #f)]) (let ([output-file (make-parameter #f)])
(command-line #:program (short-program+command-name) (command-line #:program (short-program+command-name)
#:multi #:multi

169
pkgs/compiler-lib/compiler/demodularizer/bundle.rkt Normal file
View File

@ -0,0 +1,169 @@
#lang racket/base
(require (only-in '#%linklet primitive->compiled-position)
racket/set
compiler/zo-structs
"run.rkt"
"name.rkt")
(provide wrap-bundle)
(define (wrap-bundle body internals lifts excluded-module-mpis get-merge-info)
(define-values (runs
import-keys
ordered-importss
import-shapess
any-syntax-literals?
any-transformer-registers?
saw-zero-pos-toplevel?)
(get-merge-info))
(define module-name 'demodularized)
(define (primitive v)
(primval (or (primitive->compiled-position v)
(error "cannot find primitive" v))))
(define new-linkl
(linkl module-name
(list* (if any-syntax-literals? '(.get-syntax-literal!) '())
(if any-transformer-registers? '(.set-transformer!) '())
ordered-importss)
(list* (if any-syntax-literals? (list (function-shape 1 #f)) '())
(if any-transformer-registers? (list (function-shape 2 #f)) '())
import-shapess)
'() ; exports
internals
lifts
#hasheq()
body
(for/fold ([m 0]) ([r (in-list runs)])
(max m (linkl-max-let-depth (run-linkl r))))
saw-zero-pos-toplevel?))
(define data-linkl
(linkl 'data
'((deserialize-module-path-indexes))
'((#f))
'(.mpi-vector)
'()
'()
#hasheq()
(list
(def-values (list (toplevel 0 2 #f #f)) ; .mpi-vector
(application (toplevel 2 1 #f #f) ; deserialize-module-path-indexes
;; Construct two vectors: one for mpi construction, and
;; another for selecting the slots that are externally referenced
;; mpis (where the selection vector matches th `import-keys` order).
;; If all import keys are primitive modules, then we just make
;; a vector with those specs in order, but if there's a more
;; complex mpi, then we have to insert extra slots in the first
;; vector to hold intermediate mpi constructions.
;; We could do better here by sharing common tails.
(let loop ([import-keys import-keys]
[specs (list (box module-name))]
[results (list 0)])
(cond
[(null? import-keys)
(list (list->vector (reverse specs))
(list->vector (reverse results)))]
[else
(define path/submod+phase (car import-keys))
(define path (car path/submod+phase))
(cond
[(symbol? path)
(loop (cdr import-keys)
(cons (vector `(quote ,path)) specs)
(cons (length specs) results))]
[(path? path)
(define-values (i new-specs)
(begin
(let mpi-loop ([mpi (hash-ref excluded-module-mpis path)])
(define-values (name base) (module-path-index-split mpi))
(cond
[(and (not name) (not base))
(values 0 specs)]
[(not base)
(values (length specs) (cons (vector name) specs))]
[else
(define-values (next-i next-specs) (mpi-loop base))
(values (length next-specs) (cons (vector name next-i) next-specs))]))))
(loop (cdr import-keys)
new-specs
(cons i results))]
[else
(error 'wrap-bundle "unrecognized import path shape: ~s" path)])])))))
16
#f))
(define decl-linkl
(let ([deserialize-pos 1]
[module-use-pos 2]
[mpi-vector-pos 3]
[exports-pos 4])
(linkl 'decl
'((deserialize
module-use)
(.mpi-vector))
'((#f)
(#f))
'(self-mpi requires provides phase-to-link-modules)
'()
'()
#hasheq()
(list
(def-values (list (toplevel 0 (+ exports-pos 0) #f #f)) ; .self-mpi
(application (primitive vector-ref)
(list (toplevel 2 mpi-vector-pos #f #f)
'0)))
(def-values (list (toplevel 0 (+ exports-pos 1) #f #f)) ; requires
(let ([arg-count 9])
(application (toplevel arg-count deserialize-pos #f #f)
(list
(toplevel arg-count mpi-vector-pos #f #f)
#f #f 0 '#() 0 '#() '#()
(list->vector
(let loop ([phases (sort (set->list
(for/set ([path/submod+phase (in-list import-keys)])
(cdr path/submod+phase)))
<)])
(cond
[(null? phases) (list '())]
[else
(define phase (car phases))
(define n (for/sum ([path/submod+phase (in-list import-keys)])
(if (eqv? phase (cdr path/submod+phase)) 1 0)))
(append `(#:cons #:list ,(add1 n) ,(- 0 phase))
(apply
append
(for/list ([path/submod+phase (in-list import-keys)]
[i (in-naturals 1)]
#:when (eqv? phase (cdr path/submod+phase)))
`(#:mpi ,i)))
(loop (cdr phases)))])))))))
(def-values (list (toplevel 0 (+ exports-pos 2) #f #f)) ; provides
(application (primitive hasheqv) null))
(def-values (list (toplevel 0 (+ exports-pos 3) #f #f)) ; phase-to-link-modules
(let ([depth 2])
(application (primitive hasheqv)
(list 0
(let ([depth (+ depth (length import-keys))])
(application (primitive list)
(for/list ([path/submod+phase (in-list import-keys)]
[i (in-naturals 1)])
(let ([depth (+ depth 2)])
(application (toplevel depth module-use-pos #f #f)
(list
(let ([depth (+ depth 2)])
(application (primitive vector-ref)
(list
(toplevel depth mpi-vector-pos #f #f)
i)))
(cdr path/submod+phase))))))))))))
(+ 32 (length import-keys))
#f)))
;; By not including a 'stx-data linklet, we get a default
;; linklet that supplies #f for any syntax-literal reference.
(linkl-bundle (hasheq 0 new-linkl
'data data-linkl
'decl decl-linkl)))

164
pkgs/compiler-lib/compiler/demodularizer/find.rkt Normal file
View File

@ -0,0 +1,164 @@
#lang racket/base
(require racket/set
compiler/zo-parse
syntax/modcode
racket/linklet
"../private/deserialize.rkt"
"module-path.rkt"
"run.rkt")
(provide find-modules
current-excluded-modules)
(struct mod (compiled zo)) ; includes submodules; `zo` is #f for excluded
(struct one-mod (compiled zo decl)) ; module without submodules
(define current-excluded-modules (make-parameter (set)))
(define (find-modules orig-path #:submodule [submod '()])
(define mods (make-hash)) ; path -> mod
(define one-mods (make-hash)) ; path+submod -> one-mod
(define runs-done (make-hash)) ; path+submod+phase -> #t
(define runs null) ; list of `run`
(define excluded-module-mpis (make-hash)) ; path -> mpi
(define (find-modules! orig-path+submod exclude?)
(define orig-path (if (pair? orig-path+submod) (car orig-path+submod) orig-path+submod))
(define submod (if (pair? orig-path+submod) (cdr orig-path+submod) '()))
(define path (normal-case-path (simplify-path (path->complete-path orig-path))))
(unless (hash-ref mods path #f)
(define-values (zo-path kind) (get-module-path path))
(unless (eq? kind 'zo)
(error 'demodularize "not available in bytecode form\n path: ~a" path))
(define zo (and (not exclude?)
(call-with-input-file zo-path zo-parse)))
(define compiled (parameterize ([read-accept-compiled #t]
[current-load-relative-directory
(let-values ([(dir file-name dir?) (split-path path)])
dir)])
(call-with-input-file zo-path read)))
(hash-set! mods path (mod compiled zo)))
(unless (hash-ref one-mods (cons path submod) #f)
(define m (hash-ref mods path))
(define compiled (mod-compiled m))
(define zo (mod-zo m))
(define (raise-no-submod)
(error 'demodularize "no such submodule\n path: ~a\n submod: ~a"
path submod))
(define one-compiled
(let loop ([compiled compiled] [submod submod])
(cond
[(linklet-bundle? compiled)
(unless (null? submod) (raise-no-submod))
compiled]
[else
(cond
[(null? submod)
(or (hash-ref (linklet-directory->hash compiled) #f #f)
(raise-no-submod))]
[else
(loop (or (hash-ref (linklet-directory->hash compiled) (car submod) #f)
(raise-no-submod))
(cdr submod))])])))
(define one-zo
(cond
[(not zo) #f]
[(linkl-bundle? zo)
(unless (null? submod) (raise-no-submod))
zo]
[else
(or (hash-ref (linkl-directory-table zo) submod #f)
(raise-no-submod))]))
(define h (linklet-bundle->hash one-compiled))
(define data-linklet (hash-ref h 'data #f))
(define decl-linklet (hash-ref h 'decl #f))
(unless data-linklet
(error 'demodularize "could not find module path metadata\n path: ~a\n submod: ~a"
path submod))
(unless decl-linklet
(error 'demodularize "could not find module metadata\n path: ~a\n submod: ~a"
path submod))
(define data-instance (instantiate-linklet data-linklet
(list deserialize-instance)))
(define decl (instantiate-linklet decl-linklet
(list deserialize-instance
data-instance)))
(hash-set! one-mods (cons path submod) (one-mod one-compiled one-zo decl))
;; Transitive requires
(define reqs (instance-variable-value decl 'requires))
(for ([phase+reqs (in-list reqs)]
#:when (car phase+reqs)
[req (in-list (cdr phase+reqs))])
(define path/submod (module-path-index->path req path submod))
(define req-path (if (pair? path/submod) (car path/submod) path/submod))
(unless (symbol? req-path)
(find-modules! path/submod
;; Even if this module is excluded, traverse it to get all
;; modules that it requires, so that we don't duplicate those
;; modules by accessing them directly
(or exclude? (set-member? (current-excluded-modules) req-path)))))))
(define (find-phase-runs! orig-path+submod orig-mpi #:phase [phase 0])
(define orig-path (if (pair? orig-path+submod) (car orig-path+submod) orig-path+submod))
(define submod (if (pair? orig-path+submod) (cdr orig-path+submod) '()))
(define path (normal-case-path (simplify-path (path->complete-path orig-path))))
(define path/submod (if (pair? submod) (cons path submod) path))
(unless (hash-ref runs-done (cons (cons path submod) phase) #f)
(define one-m (hash-ref one-mods (cons path submod) #f))
(when (one-mod-zo one-m) ; not excluded
(define decl (one-mod-decl one-m))
(define linkl (hash-ref (linkl-bundle-table (one-mod-zo one-m)) phase #f))
(define uses
(list*
;; The first implicit import might get used for syntax literals;
;; recognize it with a 'syntax-literals "phase"
(cons path/submod 'syntax-literals)
;; The second implicit import might get used to register a macro;
;; we'll map those registrations to the same implicit import:
'(#%transformer-register . transformer-register)
(for/list ([u (hash-ref (instance-variable-value decl 'phase-to-link-modules)
phase
null)])
(define path/submod (module-path-index->path (module-use-module u) path submod))
;; In case the import turns out to stay imported:
(define req-path (if (pair? path/submod) (car path/submod) path/submod))
(hash-set! excluded-module-mpis req-path (module-path-index-reroot (module-use-module u) orig-mpi))
(cons path/submod (module-use-phase u)))))
(define r (run (if (null? submod) path (cons path submod)) phase linkl uses))
(hash-set! runs-done (cons (cons path submod) phase) #t)
(define reqs (instance-variable-value decl 'requires))
(for* ([phase+reqs (in-list reqs)]
#:when (car phase+reqs)
[req (in-list (cdr phase+reqs))])
(define at-phase (- phase (car phase+reqs)))
(define path/submod (module-path-index->path req path submod))
(define full-mpi (module-path-index-reroot req orig-mpi))
(define req-path (if (pair? path/submod) (car path/submod) path/submod))
(unless (or (symbol? req-path)
(set-member? (current-excluded-modules) req-path))
(find-phase-runs! path/submod full-mpi #:phase at-phase)))
;; Adding after requires, so that `runs` ends up in the
;; reverse order that we want to emit code
(when linkl (set! runs (cons r runs))))))
(find-modules! (cons orig-path submod) #f)
(find-phase-runs! (cons orig-path submod) (module-path-index-join #f #f))
(values (reverse runs)
excluded-module-mpis))

288
pkgs/compiler-lib/compiler/demodularizer/gc-toplevels.rkt
View File

@ -1,288 +0,0 @@
#lang racket/base
(require racket/match
racket/list
racket/dict
racket/contract
compiler/zo-parse
"util.rkt")
; XXX Use efficient set structure
(define (gc-toplevels top)
(match top
[(struct compilation-top (max-let-depth binding-namess top-prefix form))
(define lift-start
(prefix-lift-start top-prefix))
(define max-depgraph-index
(+ (prefix-num-lifts top-prefix)
lift-start))
(define top-node max-depgraph-index)
(define DEP-GRAPH (make-vector (add1 top-node) (make-refs empty empty)))
(define build-graph! (make-build-graph! DEP-GRAPH))
(define _void (build-graph! (list top-node) form))
(define-values (used-tls stxs) (graph-dfs DEP-GRAPH top-node))
(define ordered-used-tls (sort (rest used-tls) <=)) ; This rest drops off the top-node
(define ordered-stxs (sort stxs <=))
(define (lift? i) (lift-start . <= . i))
(define-values (lifts normal-tls) (partition lift? ordered-used-tls))
(define new-prefix
(make-prefix
(length lifts)
(for/list ([i normal-tls])
(list-ref (prefix-toplevels top-prefix) i))
(for/list ([i ordered-stxs])
(list-ref (prefix-stxs top-prefix) i))))
(define new-lift-start
(prefix-lift-start new-prefix))
; XXX This probably breaks max-let-depth
(define new-form
((gc-toplevels-form
(lambda (pos) (index<=? pos ordered-used-tls))
(lambda (pos)
(if (lift? pos)
(+ new-lift-start (index<=? pos lifts))
(index<=? pos normal-tls)))
(lambda (stx-pos)
(index<=? stx-pos ordered-stxs))
(prefix-syntax-start new-prefix))
form))
(log-debug (format "Total TLS: ~S" (length normal-tls)))
(log-debug (format "Used TLS: ~S" normal-tls))
(log-debug (format "Total lifts: ~S" (length lifts)))
(log-debug (format "Used lifts: ~S" lifts))
(log-debug (format "Total stxs: ~S" (length stxs)))
(log-debug (format "Used stxs: ~S" ordered-stxs))
(make-compilation-top
max-let-depth
#hash()
new-prefix
new-form)]))
(define-struct refs (tl stx) #:transparent)
(define (make-build-graph! DEP-GRAPH)
(define (build-graph!* form lhs)
(match form
[(struct def-values (ids rhs))
(define new-lhs (map toplevel-pos ids))
; If we require one, we should require all, so make them reference each other
(for-each (lambda (tl) (build-graph! new-lhs tl)) ids)
(build-graph! new-lhs rhs)]
[(? def-syntaxes?)
(error 'build-graph "Doesn't handle syntax")]
[(? seq-for-syntax?)
(error 'build-graph "Doesn't handle syntax")]
[(struct inline-variant (direct inline))
(build-graph! lhs direct)]
[(struct req (reqs dummy))
(build-graph! lhs dummy)]
[(? mod?)
(error 'build-graph "Doesn't handle modules")]
[(struct seq (forms))
(for-each (lambda (f) (build-graph! lhs f)) forms)]
[(struct splice (forms))
(for-each (lambda (f) (build-graph! lhs f)) forms)]
[(and l (struct lam (name flags num-params param-types rest? closure-map closure-types tl-map max-let-depth body)))
(build-graph! lhs body)]
[(and c (struct closure (code gen-id)))
(build-graph! lhs code)]
[(and cl (struct case-lam (name clauses)))
(for-each (lambda (l) (build-graph! lhs l))
clauses)]
[(struct let-one (rhs body flonum? unused?))
(build-graph! lhs rhs)
(build-graph! lhs body)]
[(and f (struct let-void (count boxes? body)))
(build-graph! lhs body)]
[(and f (struct install-value (_ _ _ rhs body)))
(build-graph! lhs rhs)
(build-graph! lhs body)]
[(struct let-rec (procs body))
(for-each (lambda (l) (build-graph! lhs l)) procs)
(build-graph! lhs body)]
[(and f (struct boxenv (_ body)))
(build-graph! lhs body)]
[(and f (struct toplevel (_ pos _ _)))
(for-each (lambda (lhs)
(dict-update! DEP-GRAPH lhs
(match-lambda
[(struct refs (tls stxs))
(make-refs (list* pos tls) stxs)])))
lhs)]
[(and f (struct topsyntax (_ pos _)))
(for-each (lambda (lhs)
(dict-update! DEP-GRAPH lhs
(match-lambda
[(struct refs (tls stxs))
(make-refs tls (list* pos stxs))])))
lhs)]
[(struct application (rator rands))
(for-each (lambda (f) (build-graph! lhs f))
(list* rator rands))]
[(struct branch (test then else))
(for-each (lambda (f) (build-graph! lhs f))
(list test then else))]
[(struct with-cont-mark (key val body))
(for-each (lambda (f) (build-graph! lhs f))
(list key val body))]
[(struct with-immed-mark (key val body))
(for-each (lambda (f) (build-graph! lhs f))
(list key val body))]
[(struct beg0 (seq))
(for-each (lambda (f) (build-graph! lhs f))
seq)]
[(struct varref (tl dummy))
(build-graph! lhs tl)
(build-graph! lhs dummy)]
[(and f (struct assign (id rhs undef-ok?)))
(build-graph! lhs id)
(build-graph! lhs rhs)]
[(struct apply-values (proc args-expr))
(build-graph! lhs proc)
(build-graph! lhs args-expr)]
[(and f (struct primval (id)))
(void)]
[(and f (struct localref (unbox? pos clear? other-clears? type)))
(void)]
[(and v (not (? form?)))
(void)]))
(define-values (first-build-graph!** build-graph!**)
(build-form-memo build-graph!* #:void? #t))
(define (build-graph! lhs form) (first-build-graph!** form lhs))
build-graph!)
(define (graph-dfs g start-node)
(define visited? (make-hasheq))
(define (visit-tl n tls stxs)
(if (hash-has-key? visited? n)
(values tls stxs)
(match (dict-ref g n)
[(struct refs (n-tls n-stxs))
(hash-set! visited? n #t)
(define-values (new-tls1 new-stxs1)
(for/fold ([new-tls tls]
[new-stxs stxs])
([tl (in-list n-tls)])
(visit-tl tl new-tls new-stxs)))
(define new-stxs2
(for/fold ([new-stxs new-stxs1])
([stx (in-list n-stxs)])
(define this-stx (visit-stx stx))
(if this-stx
(list* this-stx new-stxs)
new-stxs)))
(values (list* n new-tls1)
new-stxs2)])))
(define stx-visited? (make-hasheq))
(define (visit-stx n)
(if (hash-has-key? stx-visited? n)
#f
(begin (hash-set! stx-visited? n #t)
n)))
(visit-tl start-node empty empty))
; index<=? : number? (listof number?) -> (or/c number? false/c)
; returns the index of n in l and assumes that l is sorted by <=
(define (index<=? n l)
(match l
[(list) #f]
[(list-rest f l)
(cond
[(= n f)
0]
[(< n f)
#f]
[else
(let ([rec (index<=? n l)])
(if rec (add1 rec) rec))])]))
(define (identity x) x)
(define (gc-toplevels-form keep? update-tl update-ts new-ts-midpt)
(define (inner-update form)
(match form
[(struct def-values (ids rhs))
(if (ormap (compose keep? toplevel-pos) ids)
(make-def-values (map update ids)
(update rhs))
#f)]
[(? def-syntaxes?)
(error 'gc-tls "Doesn't handle syntax")]
[(? seq-for-syntax?)
(error 'gc-tls "Doesn't handle syntax")]
[(struct req (reqs dummy))
(make-req reqs (update dummy))]
[(? mod?)
(error 'gc-tls "Doesn't handle modules")]
[(struct seq (forms))
(make-seq (filter identity (map update forms)))]
[(struct splice (forms))
(make-splice (filter identity (map update forms)))]
[(and l (struct lam (name flags num-params param-types rest? closure-map closure-types tl-map max-let-depth body)))
(struct-copy lam l
[toplevel-map #f] ; consevrative
[body (update body)])]
[(and c (struct closure (code gen-id)))
(struct-copy closure c
[code (update code)])]
[(and cl (struct case-lam (name clauses)))
(struct-copy case-lam cl
[clauses (map update clauses)])]
[(struct let-one (rhs body type unused?))
(make-let-one (update rhs) (update body) type unused?)]
[(and f (struct let-void (count boxes? body)))
(struct-copy let-void f
[body (update body)])]
[(and f (struct install-value (_ _ _ rhs body)))
(struct-copy install-value f
[rhs (update rhs)]
[body (update body)])]
[(struct let-rec (procs body))
(make-let-rec (map update procs) (update body))]
[(and f (struct boxenv (_ body)))
(struct-copy boxenv f [body (update body)])]
[(and f (struct toplevel (_ pos _ _)))
(struct-copy toplevel f
[pos (update-tl pos)])]
[(and f (struct topsyntax (_ pos _)))
(struct-copy topsyntax f
[pos (update-ts pos)]
[midpt new-ts-midpt])]
[(struct application (rator rands))
(make-application
(update rator)
(map update rands))]
[(struct branch (test then else))
(make-branch
(update test)
(update then)
(update else))]
[(struct with-cont-mark (key val body))
(make-with-cont-mark
(update key)
(update val)
(update body))]
[(struct beg0 (seq))
(make-beg0 (map update seq))]
[(struct varref (tl dummy))
(make-varref (update tl) (update dummy))]
[(and f (struct assign (id rhs undef-ok?)))
(struct-copy assign f
[id (update id)]
[rhs (update rhs)])]
[(struct apply-values (proc args-expr))
(make-apply-values
(update proc)
(update args-expr))]
[(and f (struct primval (id)))
f]
[(and f (struct localref (unbox? pos clear? other-clears? type)))
f]
[(and v (not (? form?)))
v]
))
(define-values (first-update update)
(build-form-memo inner-update))
first-update)
(provide/contract
[gc-toplevels (compilation-top? . -> . compilation-top?)])

164
pkgs/compiler-lib/compiler/demodularizer/gc.rkt Normal file
View File

@ -0,0 +1,164 @@
#lang racket/base
(require racket/match
racket/set
compiler/zo-structs
"remap.rkt")
;; Prune unnused definitions,
;; * soundly, with a simple approximation of `pure?`, by default
;; * unsoundly, assuming all definitions are pure, optionally
(provide gc-definitions)
(define (gc-definitions body internals lifts internals-pos
#:assume-pure? assume-pure?)
(define used (make-hasheqv)) ; pos -> 'used or thunk
(define graph (make-hasheq))
(define (used-pos! pos)
(when (pos . >= . internals-pos)
(define v (hash-ref used pos #f))
(hash-set! used pos 'used)
(when (procedure? v)
(v))))
(define (used! b)
(match b
[(toplevel depth pos const? ready?)
(used-pos! pos)]
[(inline-variant direct inline)
(used! direct)
(used! inline)]
[(closure code gen-id)
(unless (hash-ref graph gen-id #f)
(hash-set! graph gen-id #t)
(used! code))]
[(let-one rhs body type unused?)
(used! rhs)
(used! body)]
[(let-void count boxes? body)
(used! body)]
[(install-value count pos boxes? rhs body)
(used! rhs)
(used! body)]
[(let-rec procs body)
(for-each used! procs)
(used! body)]
[(boxenv pos body)
(used! body)]
[(application rator rands)
(used! rator)
(for-each used! rands)]
[(branch tst thn els)
(used! tst)
(used! thn)
(used! els)]
[(with-cont-mark key val body)
(used! key)
(used! val)
(used! body)]
[(beg0 forms)
(for-each used! forms)]
[(seq forms)
(for-each used! forms)]
[(varref toplevel dummy constant? unsafe?)
(used! toplevel)
(used! dummy)]
[(assign id rhs undef-ok?)
(used! id)
(used! rhs)]
[(apply-values proc args-expr)
(used! proc)
(used! args-expr)]
[(with-immed-mark key def-val body)
(used! key)
(used! def-val)
(used! body)]
[(case-lam name clauses)
(for-each used! clauses)]
[_
(cond
[(lam? b)
(define tl-map (lam-toplevel-map b))
(when tl-map
(for/set ([pos (in-set tl-map)])
(when (pos . >= . internals-pos)
(used-pos! pos))))
(used! (lam-body b))]
[else (void)])]))
(define (pure? b)
(match b
[(closure code gen-id) #t]
[(inline-variant direct inline) #t]
[(case-lam name clauses) #t]
[_ (lam? b)]))
(for ([b (in-list body)])
(match b
[(def-values ids rhs)
(define done? #f)
(define (used-rhs!)
(unless done?
(set! done? #t)
(used! rhs))
;; All in group are used together:
(for-each used! ids))
(for ([id (in-list ids)])
(define pos (toplevel-pos id))
(cond
[(eq? 'used (hash-ref used pos #f))
(used-rhs!)]
[else
(hash-set! used pos used-rhs!)]))
(unless (or assume-pure?
(pure? rhs))
(used-rhs!))]
[_ (used! b)]))
;; Anything not marked as used at this point can be dropped
(define new-internals
(for/list ([name (in-list internals)]
[pos (in-naturals internals-pos)]
#:when (or (eq? 'used (hash-ref used pos #f))
(begin
(log-debug "drop ~s" name)
#f)))
name))
(define lifts-pos (+ internals-pos (length internals)))
(define new-lifts
(for/list ([name (in-list lifts)]
[pos (in-naturals lifts-pos)]
#:when (or (eq? 'used (hash-ref used pos #f))
(begin
(log-debug "drop ~s" name)
#f)))
name))
(define old-pos-to-new-pos (make-hasheqv))
(for/fold ([new-pos internals-pos]) ([name (in-list (append internals lifts))]
[pos (in-naturals internals-pos)])
(cond
[(eq? 'used (hash-ref used pos #f))
(hash-set! old-pos-to-new-pos pos new-pos)
(add1 new-pos)]
[else new-pos]))
(define used-body
;; Drop unused definitions
(for/list ([b (in-list body)]
#:when (match b
[(def-values ids rhs)
(for/or ([id (in-list ids)])
(eq? 'used (hash-ref used (toplevel-pos id) #f)))]
[else (not (void? b))]))
b))
(define new-body (remap-positions used-body
(lambda (pos)
(if (pos . < . internals-pos)
pos
(hash-ref old-pos-to-new-pos pos)))))
(values new-body new-internals new-lifts))

5
pkgs/compiler-lib/compiler/demodularizer/import.rkt Normal file
View File

@ -0,0 +1,5 @@
#lang racket/base
(provide (struct-out import))
(struct import (name shape [pos #:mutable]))

3
pkgs/compiler-lib/compiler/demodularizer/info.rkt
View File

@ -1,3 +0,0 @@
#lang info
(define test-responsibles '((all jay)))

128
pkgs/compiler-lib/compiler/demodularizer/main.rkt
View File

@ -1,91 +1,63 @@
#lang racket/base #lang racket/base
(require compiler/cm (require racket/set
compiler/zo-marshal compiler/cm
"alpha.rkt" "find.rkt"
"gc-toplevels.rkt" "name.rkt"
"merge.rkt" "merge.rkt"
"module.rkt" "gc.rkt"
"mpi.rkt" "bundle.rkt"
"nodep.rkt" "write.rkt")
"replace-modidx.rkt")
(provide demodularize
(provide current-excluded-modules
garbage-collect-toplevels-enabled garbage-collect-toplevels-enabled
recompile-enabled current-excluded-modules
demodularize) recompile-enabled)
(define garbage-collect-toplevels-enabled (make-parameter #f)) (define garbage-collect-toplevels-enabled (make-parameter #f))
(define recompile-enabled (make-parameter #f)) (define recompile-enabled (make-parameter #f))
(define logger (make-logger 'demodularizer (current-logger))) (define logger (make-logger 'demodularizer (current-logger)))
(define (demodularize file-to-batch [output-file #f]) (define (demodularize input-file [given-output-file #f])
(parameterize ([current-logger logger]) (parameterize ([current-logger logger]
(define-values (base name must-be-dir?) (split-path file-to-batch)) [current-excluded-modules (for/set ([path (in-set (current-excluded-modules))])
(when must-be-dir? (normal-case-path (simplify-path (path->complete-path path))))])
(error 'demodularize "Cannot run on directory: ~a" file-to-batch))
(unless (file-exists? file-to-batch)
(error 'demodularize "File does not exist: ~a" file-to-batch))
;; Compile
(log-info "Compiling module") (log-info "Compiling module")
(parameterize ([current-namespace (make-base-empty-namespace)]) (parameterize ([current-namespace (make-base-empty-namespace)])
(managed-compile-zo file-to-batch)) (managed-compile-zo input-file))
(define merged-zo-path
(or output-file
(path-add-suffix file-to-batch #"_merged.zo")))
;; Transformations
(define path-cache (make-hasheq))
(log-info "Removing dependencies")
(define-values (batch-nodep top-lang-info top-self-modidx get-modvar-rewrite)
(parameterize ([MODULE-PATHS path-cache])
(nodep-file file-to-batch)))
(log-info "Merging modules")
(define batch-merge
(parameterize ([MODULE-PATHS path-cache])
(merge-compilation-top get-modvar-rewrite batch-nodep)))
(define batch-gcd
(if (garbage-collect-toplevels-enabled)
(begin
(log-info "GC-ing top-levels")
(gc-toplevels batch-merge))
batch-merge))
(log-info "Alpha-varying top-levels")
(define batch-alpha
(alpha-vary-ctop batch-gcd))
(log-info "Replacing self-modidx")
(define batch-replace-modidx
(replace-modidx batch-alpha top-self-modidx))
(define batch-modname
(string->symbol (regexp-replace #rx"\\.zo$" (path->string merged-zo-path) "")))
(log-info (format "Modularizing into ~a" batch-modname))
(define batch-mod
(wrap-in-kernel-module batch-modname batch-modname top-lang-info top-self-modidx batch-replace-modidx))
(log-info "Writing merged zo")
(void
(with-output-to-file
merged-zo-path
(lambda ()
(zo-marshal-to batch-mod (current-output-port)))
#:exists 'replace))
(void
(when (recompile-enabled)
(define recomp
(compiled-expression-recompile
(parameterize ([read-accept-compiled #t])
(call-with-input-file merged-zo-path read))))
(call-with-output-file merged-zo-path
(lambda (out)
(write recomp out))
#:exists 'replace)))))
(log-info "Finding modules")
(define-values (runs excluded-module-mpis) (find-modules input-file))
(log-info "Selecting names")
(define-values (names internals lifts imports) (select-names runs))
(log-info "Merging linklets")
(define-values (body first-internal-pos get-merge-info)
(merge-linklets runs names internals lifts imports))
(log-info "GCing definitions")
(define-values (new-body new-internals new-lifts)
(gc-definitions body internals lifts first-internal-pos
#:assume-pure? (garbage-collect-toplevels-enabled)))
(log-info "Bundling linklet")
(define bundle (wrap-bundle new-body new-internals new-lifts
excluded-module-mpis
get-merge-info))
(log-info "Writing bytecode")
(define output-file (or given-output-file
(path-add-suffix input-file #"_merged.zo")))
(write-module output-file bundle)
(when (recompile-enabled)
(log-info "Recompiling and rewriting bytecode")
(define zo (compiled-expression-recompile
(parameterize ([read-accept-compiled #t])
(call-with-input-file* output-file read))))
(call-with-output-file* output-file
#:exists 'replace
(lambda (out) (write zo out))))))

343
pkgs/compiler-lib/compiler/demodularizer/merge.rkt
View File

@ -1,229 +1,144 @@
#lang racket/base #lang racket/base
(require compiler/zo-structs
"run.rkt"
"name.rkt"
"import.rkt"
"remap.rkt")
(require racket/list (provide merge-linklets)
racket/match
racket/contract
compiler/zo-parse
"util.rkt"
"mpi.rkt"
"nodep.rkt"
"update-toplevels.rkt")
(define MODULE-TOPLEVEL-OFFSETS (make-hasheq)) (define (merge-linklets runs names internals lifts imports)
(define (syntax-literals-import? path/submod+phase)
(eq? (cdr path/submod+phase) 'syntax-literals))
(define (transformer-register-import? path/submod+phase)
(eq? (cdr path/submod+phase) 'transformer-register))
(define current-get-modvar-rewrite (make-parameter #f)) ;; Pick an order for the remaining imports:
(define (merge-compilation-top get-modvar-rewrite top) (define import-keys (for/list ([path/submod+phase (in-hash-keys imports)]
(parameterize ([current-get-modvar-rewrite get-modvar-rewrite]) ;; References to a 'syntax-literals "phase" are
(match top ;; references to the implicit syntax-literals
[(struct compilation-top (max-let-depth binding-namess prefix form)) ;; module; drop those:
(define-values (new-max-let-depth new-prefix gen-new-forms) #:unless (or (syntax-literals-import? path/submod+phase)
(merge-form max-let-depth prefix form)) (transformer-register-import? path/submod+phase)))
(define total-tls (length (prefix-toplevels new-prefix))) path/submod+phase))
(define total-stxs (length (prefix-stxs new-prefix)))
(define total-lifts (prefix-num-lifts new-prefix))
(log-debug (format "max-let-depth ~S to ~S" max-let-depth new-max-let-depth))
(log-debug (format "total toplevels ~S" total-tls))
(log-debug (format "total stxs ~S" total-stxs))
(log-debug (format "num-lifts ~S" total-lifts))
(for ([i (in-naturals)]
[p (in-list (prefix-toplevels new-prefix))])
(log-debug (format "new-prefix tls\t~v ~v" i p)))
(make-compilation-top
new-max-let-depth #hash() new-prefix
(make-splice (gen-new-forms new-prefix)))]
[else (error 'merge "unrecognized: ~e" top)])))
(define (merge-forms max-let-depth prefix forms) (define any-syntax-literals?
(if (empty? forms) (for/or ([path/submod+phase (in-hash-keys imports)])
(values max-let-depth prefix (lambda _ empty)) (syntax-literals-import? path/submod+phase)))
(let*-values ([(fmax-let-depth fprefix gen-fform) (merge-form max-let-depth prefix (first forms))] (define any-transformer-registers?
[(rmax-let-depth rprefix gen-rforms) (merge-forms fmax-let-depth fprefix (rest forms))]) (for/or ([path/submod+phase (in-hash-keys imports)])
(values rmax-let-depth (transformer-register-import? path/submod+phase)))
rprefix (define syntax-literals-pos 1)
(lambda args (define transformer-register-pos (+ (if any-syntax-literals? 1 0)
(append (apply gen-fform args) syntax-literals-pos))
(apply gen-rforms args))))))) (define import-counter (+ (if any-transformer-registers? 1 0)
transformer-register-pos))
(define (merge-form max-let-depth prefix form) ;; Map each remaining import to its position
(match form (define ordered-importss
[(? mod?) (for/list ([key (in-list import-keys)])
(merge-module max-let-depth prefix form)] (define ordered-imports (hash-ref imports key))
[(struct seq (forms)) (for ([name (in-list ordered-imports)])
(merge-forms max-let-depth prefix forms)] (define i (hash-ref names (cons key name)))
[(struct splice (forms)) (set-import-pos! i import-counter)
(merge-forms max-let-depth prefix forms)] (set! import-counter (add1 import-counter)))
[else ordered-imports))
(values max-let-depth prefix (lambda _ (list form)))])) ;; Keep all the same import shapes
(define import-shapess
(for/list ([key (in-list import-keys)])
(for/list ([name (in-list (hash-ref imports key))])
(import-shape (hash-ref names (cons key name))))))
(define (index-of v l) ;; Map all syntax-literal references to the same import.
(for/or ([e (in-list l)] ;; We could update each call to the access to use a suitable
[i (in-naturals)] ;; vector index.
#:when (eq? e v)) (for ([(path/submod+phase imports) (in-hash imports)]
i)) #:when (syntax-literals-import? path/submod+phase)
[name (in-list imports)])
(define i (hash-ref names (cons path/submod+phase name)))
(set-import-pos! i syntax-literals-pos))
(define (merge-prefix root-prefix mod-prefix) ;; Map the transformer-register import, if any
(match-define (struct prefix (root-num-lifts root-toplevels root-stxs root-src-insp-desc)) root-prefix) (let* ([path/submod+phase '(#%transformer-register . transformer-register)]
(match-define (struct prefix (mod-num-lifts mod-toplevels mod-stxs src-insp-desc)) mod-prefix) [imports (hash-ref imports path/submod+phase null)])
(make-prefix (+ root-num-lifts mod-num-lifts) (for ([name (in-list imports)])
(append root-toplevels mod-toplevels) (define i (hash-ref names (cons path/submod+phase name)))
(append root-stxs mod-stxs) (set-import-pos! i transformer-register-pos)))
root-src-insp-desc))
(struct toplevel-offset-rewriter (rewrite-fun meta) #:transparent) ;; Map internals and lifts to positions
(define first-internal-pos import-counter)
(define positions
(for/hash ([name (in-list (append internals lifts))]
[i (in-naturals first-internal-pos)])
(values name i)))
(define (compute-new-modvar mv rw) ;; For each linklet that we merge, make a mapping from
(match mv ;; the linklet's old position to new names (which can
[(struct module-variable (modidx sym pos phase constantness)) ;; then be mapped to new positions):
(match rw (define (make-position-mapping r)
[(struct modvar-rewrite (self-modidx provide->toplevel)) (define h (make-hasheqv))
(log-debug (format "Rewriting ~a@~a of ~S" sym pos (mpi->path* modidx))) (define linkl (run-linkl r))
(define tl (provide->toplevel sym pos)) (define importss (linkl-importss linkl))
(log-debug (format "Rewriting ~a@~a of ~S to ~S" sym pos (mpi->path* modidx) tl)) (define pos 1)
(match-define (toplevel-offset-rewriter rewrite-fun meta) (for ([imports (in-list importss)]
(hash-ref MODULE-TOPLEVEL-OFFSETS self-modidx [use (in-list (run-uses r))])
(lambda () (for ([name (in-list imports)])
(error 'compute-new-modvar "toplevel offset not yet computed: ~S" self-modidx)))) (hash-set! h pos (find-name names use name))
(log-debug (format "Rewriting ~a@~a of ~S (which is ~a) with ~S" sym pos (mpi->path* modidx) tl meta)) (set! pos (add1 pos))))
(define res (rewrite-fun tl)) (define path/submod+phase (cons (run-path/submod r) (run-phase r)))
(log-debug (format "Rewriting ~a@~a of ~S (which is ~a) with ~S and got ~S" (for ([name (in-list (append (linkl-exports linkl)
sym pos (mpi->path* modidx) tl meta res)) (linkl-internals linkl)
res])])) (linkl-lifts linkl)))]
[pos (in-naturals pos)])
(hash-set! h pos (find-name names path/submod+phase name)))
h)
(define (filter-rewritable-module-variable? name new-#f-idx toplevel-offset mod-toplevels) ;; Do we need the implicit initial variable for `(#%variable-reference)`?
(define-values ;; The slot will be reserved whether we use it or not, but the
(i new-toplevels remap) ;; slot is not necessarily initialized if we don't need it.
(for/fold ([i 0] (define saw-zero-pos-toplevel? #f)
[new-toplevels empty]
[remap empty]) (define body
([tl (in-list mod-toplevels)] (apply
[idx (in-naturals)]) append
(log-debug (format "[~S] mod-prefix tls\t~v ~v" (for/list ([r (in-list runs)])
name idx tl)) (define pos-to-name/import (make-position-mapping r))
(match tl (define (remap-toplevel-pos pos)
[(and mv (struct module-variable (modidx sym pos phase constantness)))
(define rw ((current-get-modvar-rewrite) modidx))
;; XXX We probably don't need to deal with #f phase
(unless (or (not phase) (zero? phase))
(error 'eliminate-module-variables "Non-zero phases not supported: ~S" mv))
(cond (cond
; Primitive module like #%paramz [(zero? pos)
[(symbol? rw) ;; Implicit variable for `(#%variable-reference)` stays in place:
(log-debug (format "~S from ~S" sym rw)) (set! saw-zero-pos-toplevel? #t)
(values (add1 i) 0]
(list* tl new-toplevels)
(list* (+ i toplevel-offset) remap))]
[(module-path-index? rw)
(values (add1 i)
(list* tl new-toplevels)
(list* (+ i toplevel-offset) remap))]
[(modvar-rewrite? rw)
(values i
new-toplevels
(list* (compute-new-modvar mv rw) remap))]
[else [else
(error 'filter-rewritable-module-variable? "Unsupported module-rewrite: ~S" rw)])] (define new-name/import (hash-ref pos-to-name/import pos))
[tl (if (import? new-name/import)
(cond (import-pos new-name/import)
[(and new-#f-idx (not tl)) (hash-ref positions new-name/import))]))
(log-debug (format "[~S] dropping a #f at ~v that would have been at ~v but is now at ~v"
name idx (+ i toplevel-offset) new-#f-idx))
(values i
new-toplevels
(list* new-#f-idx remap))]
[else
(values (add1 i)
(list* tl new-toplevels)
(list* (+ i toplevel-offset) remap))])])))
; XXX This would be more efficient as a vector
(values (reverse new-toplevels)
(reverse remap)))
(define (merge-module max-let-depth top-prefix mod-form) (remap-positions (linkl-body (run-linkl r))
(match mod-form remap-toplevel-pos
[(struct mod (name srcname self-modidx #:application-hook
mod-prefix provides requires body syntax-bodies (lambda (rator rands remap)
unexported mod-max-let-depth dummy lang-info ;; Check for a `(.get-syntax-literal! '<pos>)` call
internal-context binding-names (cond
flags pre-submodules post-submodules)) [(and (toplevel? rator)
(define top-toplevels (prefix-toplevels top-prefix)) (let ([i (hash-ref pos-to-name/import (toplevel-pos rator))])
(define toplevel-offset (length top-toplevels)) (and (import? i)
(define topsyntax-offset (length (prefix-stxs top-prefix))) (eqv? syntax-literals-pos (import-pos i)))))
(define lift-offset (prefix-num-lifts top-prefix)) ;; This is a `(.get-syntax-literal! '<pos>)` call
(define mod-toplevels (prefix-toplevels mod-prefix)) (application (remap rator)
(define new-#f-idx ;; To support syntax objects, change the offset
(index-of #f top-toplevels)) rands)]
(when new-#f-idx [else #f]))))))
(log-debug (format "[~S] found a #f entry in prefix already at ~v, squashing"
name new-#f-idx)))
(define-values (new-mod-toplevels toplevel-remap)
(filter-rewritable-module-variable? name new-#f-idx toplevel-offset mod-toplevels))
(define num-mod-toplevels
(length toplevel-remap))
(define mod-stxs
(length (prefix-stxs mod-prefix)))
(define mod-num-lifts
(prefix-num-lifts mod-prefix))
(define new-mod-prefix
(struct-copy prefix mod-prefix
[toplevels new-mod-toplevels]))
(define offset-meta (vector name srcname self-modidx))
(log-debug "Setting toplevel offsets rewriter for ~S and it is currently ~S"
offset-meta
(hash-ref MODULE-TOPLEVEL-OFFSETS self-modidx #f))
(hash-set! MODULE-TOPLEVEL-OFFSETS self-modidx
(toplevel-offset-rewriter
(lambda (n)
(log-debug "Finding offset ~a in ~S of ~S" n toplevel-remap offset-meta)
(list-ref toplevel-remap n))
offset-meta))
(unless (= (length toplevel-remap)
(length mod-toplevels))
(error 'merge-module "Not remapping everything: ~S ~S"
mod-toplevels toplevel-remap))
(log-debug (format "[~S] Incrementing toplevels by ~a"
name
toplevel-offset))
(log-debug (format "[~S] Incrementing lifts by ~a"
name
lift-offset))
(log-debug (format "[~S] Filtered mod-vars from ~a to ~a"
name
(length mod-toplevels)
(length new-mod-toplevels)))
(values (max max-let-depth mod-max-let-depth)
(merge-prefix top-prefix new-mod-prefix)
(lambda (top-prefix)
(log-debug (format "[~S] Updating top-levels" name))
(define top-lift-start (prefix-lift-start top-prefix))
(define mod-lift-start (prefix-lift-start mod-prefix))
(define total-lifts (prefix-num-lifts top-prefix))
(define max-toplevel (+ top-lift-start total-lifts))
(define update
(update-toplevels
(lambda (n)
(define new-idx
(cond
[(mod-lift-start . <= . n)
(log-debug (format "[~S] ~v is a lift"
name n))
(define which-lift (- n mod-lift-start))
(define lift-tl (+ top-lift-start lift-offset which-lift))
(when (lift-tl . >= . max-toplevel)
(error 'merge-module "[~S] lift error: orig(~a) which(~a) max(~a) lifts(~a) now(~a)"
name n which-lift num-mod-toplevels mod-num-lifts lift-tl))
lift-tl]
[else
;; xxx maybe change this to a vector after it is made to make this efficient
(list-ref toplevel-remap n)]))
(log-debug (format "[~S] ~v is remapped to ~v"
name n new-idx))
new-idx)
(lambda (n)
(+ n topsyntax-offset))
(prefix-syntax-start top-prefix)))
(map update body)))]))
(provide/contract (values body
[merge-compilation-top (-> get-modvar-rewrite/c first-internal-pos
compilation-top? ;; Communicates into to `wrap-bundle`:
compilation-top?)]) (lambda ()
(values runs
import-keys
ordered-importss
import-shapess
any-syntax-literals?
any-transformer-registers?
saw-zero-pos-toplevel?))))

38
pkgs/compiler-lib/compiler/demodularizer/module-path.rkt Normal file
View File

@ -0,0 +1,38 @@
#lang racket/base
(require syntax/modresolve)
(provide module-path-index->path
module-path-index-reroot)
(define (module-path-index->path req path submod)
(define mpi (module-path-index-build req path submod))
(define p (resolve-module-path-index mpi path))
;; Make sure a path name is normalized
(define p-path (if (pair? p) (cadr p) p))
(define p-submod (if (pair? p) (cddr p) '()))
(define p-simple-path (if (path? p-path)
(normal-case-path (simplify-path p-path))
p-path))
;; Combine path back with submod
(if (null? p-submod)
p-simple-path
(cons p-simple-path p-submod)))
(define (module-path-index-build req path submod)
(module-path-index-reroot req
(if (null? submod)
(module-path-index-join #f #f)
(module-path-index-join `(submod "." ,@submod)
(module-path-index-join #f #f)))))
(define (module-path-index-reroot req root-mpi)
(let loop ([req req])
(define-values (mod-path base) (module-path-index-split req))
(cond
[(not mod-path) root-mpi]
[else
(module-path-index-join mod-path
(and base (loop base)))])))

43
pkgs/compiler-lib/compiler/demodularizer/module.rkt
View File

@ -1,43 +0,0 @@
#lang racket/base
(require racket/list
racket/match
racket/contract
compiler/zo-parse
"util.rkt")
(define (->module-path-index s)
(if (module-path-index? s)
s
(module-path-index-join `(quote ,s) #f)))
(define (wrap-in-kernel-module name srcname lang-info self-modidx top)
(match top
[(struct compilation-top (max-let-depth binding-namess prefix form))
(define-values (reqs new-forms)
(partition req? (splice-forms form)))
(define requires
(map (compose ->module-path-index stx-obj-datum stx-content req-reqs) reqs))
(make-compilation-top
0
#hash()
(make-prefix 0 (list #f) empty (prefix-src-inspector-desc prefix))
(make-mod name srcname
self-modidx
prefix
empty ; provides
(list (cons 0 requires))
new-forms
empty ; syntax-body
(list) ; unexported
max-let-depth
(make-toplevel 0 0 #f #f) ; dummy
lang-info
#t
(hash) ; no names visible via `module->namespace`
empty
empty
empty))]))
(provide/contract
[wrap-in-kernel-module (symbol? symbol? lang-info/c module-path-index? compilation-top? . -> . compilation-top?)])

41
pkgs/compiler-lib/compiler/demodularizer/mpi.rkt
View File

@ -1,41 +0,0 @@
#lang racket/base
(require racket/contract
syntax/modresolve)
(define current-module-path (make-parameter #f))
(define (mpi->string modidx)
(cond
[(symbol? modidx) modidx]
[else
(mpi->path! modidx)]))
(define MODULE-PATHS (make-parameter #f))
(define (mpi->path! mpi)
(hash-ref!
(MODULE-PATHS) mpi
(lambda ()
(define _pth
(resolve-module-path-index mpi (current-module-path)))
(cond
[(path? _pth) (simplify-path _pth #t)]
[(and (pair? _pth)
(path? (cadr _pth)))
(list* 'submod (simplify-path (cadr _pth) #t) (cddr _pth))]
[else _pth]))))
(define (mpi->path* mpi)
(hash-ref (MODULE-PATHS) mpi
(lambda ()
(error 'mpi->path* "Cannot locate cache of path for ~S" mpi))))
(define submod-path/c
(cons/c 'submod
(cons/c (or/c symbol? path?)
(listof symbol?))))
(provide/contract
[MODULE-PATHS (parameter/c (or/c false/c hash?))]
[current-module-path (parameter/c (or/c path-string? submod-path/c))]
[mpi->path! (module-path-index? . -> . (or/c symbol? path? submod-path/c))]
[mpi->path* (module-path-index? . -> . (or/c symbol? path? pair? submod-path/c))])

61
pkgs/compiler-lib/compiler/demodularizer/name.rkt Normal file
View File

@ -0,0 +1,61 @@
#lang racket/base
(require compiler/zo-structs
"run.rkt"
"import.rkt")
(provide select-names
find-name)
(define (select-names runs)
(define names (make-hash)) ; path/submod+phase+sym -> symbol
(define used-names (make-hasheq))
(define internals (box '()))
(define lifts (box '()))
(define imports (make-hash)) ; path/submod+phase -> list-of-sym
;; Reserve the syntax-literals and transformer-register names:
(hash-set! used-names '.get-syntax-literal! #t)
(hash-set! used-names '.set-transformer! #t)
(define (pick-name name)
(let loop ([try-name name] [i 0])
(cond
[(hash-ref used-names try-name #f)
(let ([i (add1 i)])
(loop (string->symbol (format "~a_~a" name i)) i))]
[else
(hash-set! used-names try-name #t)
try-name])))
(for ([r (in-list (reverse runs))]) ; biases names to starting module
(define linkl (run-linkl r))
(define path/submod+phase (cons (run-path/submod r) (run-phase r)))
;; Process local definitions, first
(define (select-names! name-list category)
(for ([name (in-list name-list)])
(define new-name (pick-name name))
(hash-set! names (cons path/submod+phase name) new-name)
(set-box! category (cons new-name (unbox category)))))
(select-names! (linkl-exports linkl) internals)
(select-names! (linkl-internals linkl) internals)
(select-names! (linkl-lifts linkl) lifts))
;; Record any imports that will remain as imports; anything
;; not yet mapped must be a leftover import
(for ([r (in-list runs)])
(define linkl (run-linkl r))
(for ([import-names (in-list (linkl-importss linkl))]
[import-shapes (in-list (linkl-import-shapess linkl))]
[use (in-list (run-uses r))])
(for ([name (in-list import-names)]
[shape (in-list import-shapes)])
(unless (hash-ref names (cons use name) #f)
(hash-set! imports use (cons name (hash-ref imports use null)))
(hash-set! names (cons use name) (import name shape #f))))))
(values names (unbox internals) (unbox lifts) imports))
(define (find-name names use name)
(hash-ref names (cons use name)))

228
pkgs/compiler-lib/compiler/demodularizer/nodep.rkt
View File

@ -1,228 +0,0 @@
#lang racket/base
(require racket/list
racket/match
racket/contract
compiler/zo-parse
"util.rkt"
"mpi.rkt"
racket/set)
(define current-excluded-modules (make-parameter (set)))
(define ZOS (make-parameter #f))
(define MODULE-IDX-MAP (make-parameter #f))
(define PHASE*MODULE-CACHE (make-parameter #f))
(define (nodep-file file-to-batch)
(define idx-map (make-hash))
(parameterize ([ZOS (make-hash)]
[MODULE-IDX-MAP idx-map]
[PHASE*MODULE-CACHE (make-hasheq)])
(define (get-modvar-rewrite modidx)
(define pth (mpi->path* modidx))
(hash-ref idx-map pth
(lambda ()
(error 'get-modvar-rewrite "Cannot locate modvar rewrite for ~S" pth))))
(match (get-nodep-module-code/path file-to-batch 0)
[(struct @phase (_ (struct module-code (modvar-rewrite lang-info ctop))))
(values ctop lang-info (modvar-rewrite-modidx modvar-rewrite) get-modvar-rewrite)])))
(define (path->comp-top pth submod)
(hash-ref! (ZOS) (cons pth submod)
(λ ()
(define zo (call-with-input-file pth zo-parse))
(if submod
(extract-submod zo submod)
zo))))
(define (extract-submod zo submod)
(define m (compilation-top-code zo))
(struct-copy compilation-top
zo
[code (let loop ([m m])
(if (and (pair? (mod-name m))
(equal? submod (cdr (mod-name m))))
m
(or (ormap loop (mod-pre-submodules m))
(ormap loop (mod-post-submodules m)))))]))
(define (excluded? pth)
(and (path? pth)
(set-member? (current-excluded-modules) (path->string pth))))
(define (get-nodep-module-code/index mpi phase)
(define pth (mpi->path! mpi))
(cond
[(symbol? pth)
(hash-set! (MODULE-IDX-MAP) pth pth)
pth]
[(excluded? pth)
(hash-set! (MODULE-IDX-MAP) pth mpi)
mpi]
[else
(get-nodep-module-code/path pth phase)]))
(define-struct @phase (phase code))
(define-struct modvar-rewrite (modidx provide->toplevel))
(define-struct module-code (modvar-rewrite lang-info ctop))
(define @phase-ctop (compose module-code-ctop @phase-code))
(define (get-nodep-module-code/path pth phase)
(define MODULE-CACHE
(hash-ref! (PHASE*MODULE-CACHE) phase make-hash))
(if (hash-ref MODULE-CACHE pth #f)
#f
(hash-ref!
MODULE-CACHE pth
(lambda ()
(define-values (base file dir?) (split-path (if (path-string? pth)
pth
(cadr pth))))
(define base-directory
(if (path? base)
(path->complete-path base (current-directory))
(current-directory)))
(define-values (modvar-rewrite lang-info ctop)
(begin
(log-debug (format "Load ~S @ ~S" pth phase))
(nodep/dir
(parameterize ([current-load-relative-directory base-directory])
(path->comp-top
(build-compiled-path
base
(path-add-suffix file #".zo"))
(and (pair? pth) (cddr pth))))
pth
phase)))
(when (and phase (zero? phase))
(hash-set! (MODULE-IDX-MAP) pth modvar-rewrite))
(make-@phase
phase
(make-module-code modvar-rewrite lang-info ctop))))))
(define (nodep/dir top pth phase)
(define pth*
(cond
[(string? pth) (string->path pth)]
[(list? pth) (cadr pth)]
[else pth]))
(parameterize ([current-module-path pth*])
(nodep top phase)))
(define (nodep top phase)
(match top
[(struct compilation-top (max-let-depth binding-namess prefix form))
(define-values (modvar-rewrite lang-info new-form) (nodep-form form phase))
(values modvar-rewrite lang-info (make-compilation-top max-let-depth #hash() prefix new-form))]
[else (error 'nodep "unrecognized: ~e" top)]))
(define (nodep-form form phase)
(if (mod? form)
(let-values ([(modvar-rewrite lang-info mods)
(nodep-module form phase)])
(values modvar-rewrite lang-info (make-splice mods)))
(error 'nodep-form "Doesn't support non mod forms")))
; XXX interning is hack to fix test/add04.ss and provide/contract renaming
(define (intern s) (string->symbol (symbol->string s)))
(define (construct-provide->toplevel prefix provides)
(define provide-ht (make-hasheq))
(for ([tl (prefix-toplevels prefix)]
[i (in-naturals)])
(when (symbol? tl)
(hash-set! provide-ht (intern tl) i)))
(lambda (sym pos)
(define isym (intern sym))
(log-debug (format "Looking up ~S@~a [~S] in ~S" sym pos isym prefix))
(define res
(hash-ref provide-ht isym
(lambda ()
(error 'provide->toplevel "Cannot find ~S in ~S" sym prefix))))
(log-debug (format "Looked up ~S@~a and got ~v" sym pos res))
res))
(define (nodep-module mod-form phase)
(match mod-form
[(struct mod (name srcname self-modidx
prefix provides requires body syntax-bodies
unexported max-let-depth dummy lang-info
internal-context binding-names
flags pre-submodules post-submodules))
(define new-prefix prefix)
;; Cache all the mpi paths
(for-each (match-lambda
[(and mv (struct module-variable (modidx sym pos phase constantness)))
(mpi->path! modidx)]
[tl
(void)])
(prefix-toplevels new-prefix))
(define mvs (filter module-variable? (prefix-toplevels new-prefix)))
(log-debug (format "[~S] module-variables: ~S - ~S" name (length mvs) mvs))
(values (make-modvar-rewrite self-modidx (construct-provide->toplevel new-prefix provides))
lang-info
(append (requires->modlist requires phase)
(if (and phase (zero? phase))
(begin (log-debug (format "[~S] lang-info : ~S" name lang-info)) ; XXX Seems to always be #f now
(list (make-mod name srcname self-modidx
new-prefix provides requires body empty
unexported max-let-depth dummy lang-info internal-context #hash()
empty empty empty)))
(begin (log-debug (format "[~S] Dropping module @ ~S" name phase))
empty))))]
[else (error 'nodep-module "huh?: ~e" mod-form)]))
(define (+* l r)
(if (and l r) (+ l r) #f))
(define (requires->modlist requires current-phase)
(apply append
(map
(match-lambda
[(list-rest req-phase mpis)
(define phase (+* current-phase req-phase))
(apply append
(map (compose extract-modules (lambda (mpi) (get-nodep-module-code/index mpi phase))) mpis))])
requires)))
(define (all-but-last l)
(reverse (rest (reverse l))))
(define REQUIRED (make-hasheq))
(define (extract-modules ct)
(cond
[(compilation-top? ct)
(match (compilation-top-code ct)
[(and m (? mod?))
(list m)]
[(struct splice (mods))
mods])]
[(symbol? ct)
(if (hash-has-key? REQUIRED ct)
empty
(begin
(hash-set! REQUIRED ct #t)
(list (make-req (make-stx (make-stx-obj ct (wrap empty empty empty) #f #hasheq() 'clean)) (make-toplevel 0 0 #f #f)))))]
[(module-path-index? ct)
(if (hash-has-key? REQUIRED ct)
empty
(begin
(hash-set! REQUIRED ct #t)
(list (make-req (make-stx (make-stx-obj ct (wrap empty empty empty) #f #hasheq() 'clean)) (make-toplevel 0 0 #f #f)))))]
[(not ct)
empty]
[(@phase? ct)
(extract-modules (@phase-ctop ct))]
[else
(error 'extract-modules "Unknown extraction: ~S" ct)]))
(define get-modvar-rewrite/c
(module-path-index? . -> . (or/c symbol? modvar-rewrite? module-path-index?)))
(provide/contract
[struct modvar-rewrite
([modidx module-path-index?]
[provide->toplevel (symbol? exact-nonnegative-integer? . -> . exact-nonnegative-integer?)])]
[get-modvar-rewrite/c contract?]
[current-excluded-modules (parameter/c generic-set?)]
[nodep-file (-> path-string?
(values compilation-top? lang-info/c module-path-index? get-modvar-rewrite/c))])

79
pkgs/compiler-lib/compiler/demodularizer/remap.rkt Normal file
View File

@ -0,0 +1,79 @@
#lang racket/base
(require racket/match
racket/set
compiler/zo-structs)
(provide remap-positions)
(define (remap-positions body
remap-toplevel-pos ; integer -> integer
#:application-hook [application-hook (lambda (rator rands remap) #f)])
(define graph (make-hasheq))
(make-reader-graph
(for/list ([b (in-list body)])
(let remap ([b b])
(match b
[(toplevel depth pos const? ready?)
(define new-pos (remap-toplevel-pos pos))
(toplevel depth new-pos const? ready?)]
[(def-values ids rhs)
(def-values (map remap ids) (remap rhs))]
[(inline-variant direct inline)
(inline-variant (remap direct) (remap inline))]
[(closure code gen-id)
(cond
[(hash-ref graph gen-id #f)
=> (lambda (ph) ph)]
[else
(define ph (make-placeholder #f))
(hash-set! graph gen-id ph)
(define cl (closure (remap code) gen-id))
(placeholder-set! ph cl)
cl])]
[(let-one rhs body type unused?)
(let-one (remap rhs) (remap body) type unused?)]
[(let-void count boxes? body)
(let-void count boxes? (remap body))]
[(install-value count pos boxes? rhs body)
(install-value count pos boxes? (remap rhs) (remap body))]
[(let-rec procs body)
(let-rec (map remap procs) (remap body))]
[(boxenv pos body)
(boxenv pos (remap body))]
[(application rator rands)
(cond
[(application-hook rator rands (lambda (b) (remap b)))
=> (lambda (v) v)]
[else
;; Any other application
(application (remap rator) (map remap rands))])]
[(branch tst thn els)
(branch (remap tst) (remap thn) (remap els))]
[(with-cont-mark key val body)
(with-cont-mark (remap key) (remap val) (remap body))]
[(beg0 forms)
(beg0 (map remap forms))]
[(seq forms)
(seq (map remap forms))]
[(varref toplevel dummy constant? unsafe?)
(varref (remap toplevel) (remap dummy) constant? unsafe?)]
[(assign id rhs undef-ok?)
(assign (remap id) (remap rhs) undef-ok?)]
[(apply-values proc args-expr)
(apply-values (remap proc) (remap args-expr))]
[(with-immed-mark key def-val body)
(with-immed-mark (remap key) (remap def-val) (remap body))]
[(case-lam name clauses)
(case-lam name (map remap clauses))]
[_
(cond
[(lam? b)
(define tl-map (lam-toplevel-map b))
(define new-tl-map
(and tl-map
(for/set ([pos (in-set tl-map)])
(remap-toplevel-pos pos))))
(struct-copy lam b
[body (remap (lam-body b))]
[toplevel-map new-tl-map])]
[else b])])))))

29
pkgs/compiler-lib/compiler/demodularizer/replace-modidx.rkt
View File

@ -1,29 +0,0 @@
#lang racket/base
(require racket/match
racket/vector
racket/struct
"util.rkt")
(provide replace-modidx)
(define (replace-modidx expr self-modidx)
(define (inner-update e)
(match e
[(app prefab-struct-key (and key (not #f)))
(apply make-prefab-struct key
(map update
(struct->list e)))]
[(? module-path-index?)
(define-values (path mpi) (module-path-index-split e))
(if (not path)
self-modidx
(module-path-index-join path (update mpi)))]
[(cons a b)
(cons (update a) (update b))]
[(? vector?)
(vector-map update e)]
[else e]))
(define-values (first-update update)
(build-form-memo inner-update))
(first-update expr))

5
pkgs/compiler-lib/compiler/demodularizer/run.rkt Normal file
View File

@ -0,0 +1,5 @@
#lang racket/base
(provide (struct-out run))
(struct run (path/submod phase linkl uses))

108
pkgs/compiler-lib/compiler/demodularizer/update-toplevels.rkt
View File

@ -1,108 +0,0 @@
#lang racket/base
(require racket/match
racket/contract
compiler/zo-structs
"util.rkt")
(define (update-toplevels toplevel-updater topsyntax-updater topsyntax-new-midpt)
(define (inner-update form)
(match form
[(struct def-values (ids rhs))
(make-def-values (map update ids)
(update rhs))]
[(? def-syntaxes?)
(error 'increment "Doesn't handle syntax")]
[(? seq-for-syntax?)
(error 'increment "Doesn't handle syntax")]
[(struct inline-variant (direct inline))
(update direct)]
[(struct req (reqs dummy))
(make-req reqs (update dummy))]
[(? mod?)
(error 'increment "Doesn't handle modules")]
[(struct seq (forms))
(make-seq (map update forms))]
[(struct splice (forms))
(make-splice (map update forms))]
[(and l (struct lam (name flags num-params param-types rest? closure-map closure-types tl-map max-let-depth body)))
(struct-copy lam l
[toplevel-map #f] ; conservative
[body (update body)])]
[(and c (struct closure (code gen-id)))
(struct-copy closure c
[code (update code)])]
[(and cl (struct case-lam (name clauses)))
(define new-clauses
(map update clauses))
(struct-copy case-lam cl
[clauses new-clauses])]
[(struct let-one (rhs body type unused?))
(make-let-one (update rhs) (update body) type unused?)]
[(and f (struct let-void (count boxes? body)))
(struct-copy let-void f
[body (update body)])]
[(and f (struct install-value (_ _ _ rhs body)))
(struct-copy install-value f
[rhs (update rhs)]
[body (update body)])]
[(struct let-rec (procs body))
(make-let-rec (map update procs) (update body))]
[(and f (struct boxenv (_ body)))
(struct-copy boxenv f [body (update body)])]
[(and f (struct toplevel (_ pos _ _)))
(struct-copy toplevel f
[pos (toplevel-updater pos)])]
[(and f (struct topsyntax (_ pos _)))
(struct-copy topsyntax f
[pos (topsyntax-updater pos)]
[midpt topsyntax-new-midpt])]
[(struct application (rator rands))
(make-application
(update rator)
(map update rands))]
[(struct branch (test then else))
(make-branch
(update test)
(update then)
(update else))]
[(struct with-cont-mark (key val body))
(make-with-cont-mark
(update key)
(update val)
(update body))]
[(struct with-immed-mark (key val body))
(make-with-immed-mark
(update key)
(update val)
(update body))]
[(struct beg0 (seq))
(make-beg0 (map update seq))]
[(struct varref (tl dummy))
(make-varref (update tl) (update dummy))]
[(and f (struct assign (id rhs undef-ok?)))
(struct-copy assign f
[id (update id)]
[rhs (update rhs)])]
[(struct apply-values (proc args-expr))
(make-apply-values
(update proc)
(update args-expr))]
[(and f (struct primval (id)))
f]
[(and f (struct localref (unbox? pos clear? other-clears? type)))
f]
[(and f (not (? form?)))
f]
))
(define-values (first-update update)
(build-form-memo inner-update))
first-update)
(provide/contract
[update-toplevels
((exact-nonnegative-integer? . -> . exact-nonnegative-integer?)
(exact-nonnegative-integer? . -> . exact-nonnegative-integer?)
exact-nonnegative-integer?
. -> .
(form? . -> . form?))])

79
pkgs/compiler-lib/compiler/demodularizer/util.rkt
View File

@ -1,79 +0,0 @@
#lang racket/base
(require racket/contract
compiler/zo-parse)
(define (prefix-syntax-start pre)
(length (prefix-toplevels pre)))
(define (prefix-lift-start pre)
(define syntax-start (prefix-syntax-start pre))
(define total-stxs (length (prefix-stxs pre)))
(+ syntax-start total-stxs (if (zero? total-stxs) 0 1)))
(struct nothing ())
(define-syntax-rule (eprintf* . args) (void))
(define (build-form-memo inner-update #:void? [void? #f])
(define memo (make-hasheq))
(define (update form . args)
(eprintf* "Updating on ~a\n" form)
(define fin
(cond
[(hash-ref memo form #f)
=> (λ (x)
(eprintf* "Found in memo table\n")
x)]
[else
(eprintf* "Not in memo table\n")
(let ()
(define ph (make-placeholder (nothing)))
(hash-set! memo form ph)
(define nv (nothing))
(dynamic-wind void
(λ ()
(set! nv (apply inner-update form args)))
(λ ()
(if (nothing? nv)
(eprintf* "inner-update returned nothing (or there was an escape) on ~a\n" form)
(begin
(placeholder-set! ph nv)
(hash-set! memo form nv)))))
nv)]))
(eprintf* "Updating on ~a ---->\n ~a\n" form fin)
fin)
(define (first-update form . args)
(eprintf* "Top level update on ~a\n" form)
(define final (apply update form args))
(eprintf* "Top level update on ~a ---->\n ~a\n" form final)
(define fin (make-reader-graph final))
(eprintf* "Top level update on ~a ---->\n ~a [after reader-graph]\n" form fin)
fin)
(values first-update update))
(define lang-info/c
(or/c #f (vector/c module-path? symbol? any/c)))
(define (build-compiled-path base name)
(build-path
(cond [(path? base) base]
[(eq? base 'relative) 'same]
[(eq? base #f) (error 'batch "Impossible")])
"compiled"
name))
(provide/contract
[prefix-syntax-start (prefix? . -> . exact-nonnegative-integer?)]
[prefix-lift-start (prefix? . -> . exact-nonnegative-integer?)]
[eprintf ((string?) () #:rest (listof any/c) . ->* . void)]
[build-form-memo
(((unconstrained-domain-> any/c))
(#:void? boolean?)
. ->* .
(values (unconstrained-domain-> any/c)
(unconstrained-domain-> any/c)))]
[lang-info/c contract?]
[build-compiled-path ((or/c path-string? (symbols 'relative) false/c) path-string? . -> . (or/c path-string? (symbols 'same 'up)))])

11
pkgs/compiler-lib/compiler/demodularizer/write.rkt Normal file
View File

@ -0,0 +1,11 @@
#lang racket/base
(require compiler/zo-marshal)
(provide write-module)
(define (write-module output-file bundle)
(call-with-output-file*
output-file
#:exists 'truncate/replace
(lambda (o)
(zo-marshal-to bundle o))))

121
pkgs/compiler-lib/compiler/private/deserialize.rkt Normal file
View File

@ -0,0 +1,121 @@
#lang racket/base
(require racket/linklet)
;; Re-implement just enough deserialization to deal with 'decl
;; linklets, so we can get `required`, etc.
(provide deserialize-instance
(struct-out module-use))
(struct module-use (module phase))
(struct provided (binding protected? syntax?))
(define (deserialize-module-path-indexes gen-vec order-vec)
(define gen (make-vector (vector-length gen-vec) #f))
(for ([d (in-vector gen-vec)]
[i (in-naturals)])
(vector-set!
gen
i
(cond
[(eq? d 'top) (error 'deserialize-module-path-indexes "expected top")]
[(box? d) (module-path-index-join #f #f)]
[else
(module-path-index-join (vector-ref d 0)
(and ((vector-length d) . > . 1)
(vector-ref gen (vector-ref d 1))))])))
(for/vector #:length (vector-length order-vec) ([p (in-vector order-vec)])
(vector-ref gen p)))
(define (deserialize mpis inspector bulk-binding-registry
num-mutables mutable-vec
num-shared shared-vec
mutable-fill-vec
result-vec)
(unless (zero? num-mutables) (error 'deserialize "mutables not supported"))
(define shared-vs (make-vector num-shared #f))
(define shared-rest
(for/fold ([r (vector->list shared-vec)]) ([i (in-range num-shared)])
(define-values (v rest) (decode r mpis shared-vs))
(vector-set! shared-vs i v)
rest))
(unless (null? shared-rest)
(error 'deserialize "unexpected leftover serialized form for shared: ~s" shared-rest))
(define-values (v v-rest) (decode (vector->list result-vec) mpis shared-vs))
(unless (null? v-rest)
(error 'deserialize "unexpected leftover serialized form: ~s" v-rest))
v)
(define (decode r mpis shared-vs)
(let loop ([r r])
(define (discard r n)
(for/fold ([r (cdr r)]) ([i (in-range n)])
(define-values (v v-rest) (loop r))
v-rest))
(cond
[(null? r) (error 'deserialize "unexpected end of serialized form")]
[else
(define i (car r))
(case i
[(#:ref)
(values (vector-ref shared-vs (cadr r)) (cddr r))]
[(#:inspector)
(values 'inspector (cdr r))]
[(#:cons)
(define-values (a a-rest) (loop (cdr r)))
(define-values (d d-rest) (loop a-rest))
(values (cons a d) d-rest)]
[(#:list)
(define-values (rev rest)
(for/fold ([accum '()] [r (cddr r)]) ([i (in-range (cadr r))])
(define-values (a a-rest) (loop r))
(values (cons a accum) a-rest)))
(values (reverse rev) rest)]
[(#:mpi)
(values (vector-ref mpis (cadr r)) (cddr r))]
[(#:hash #:hasheq #:hasheqv)
(define ht (case i
[(#:hash) (hash)]
[(#:hasheq) (hasheq)]
[(#:hasheqv) (hasheqv)]))
(for/fold ([ht ht] [r (cddr r)]) ([i (in-range (cadr r))])
(define-values (k k-rest) (loop r))
(define-values (v v-rest) (loop k-rest))
(values (hash-set ht k v) v-rest))]
[(#:provided)
(define-values (bdg bdg-rest) (loop (cdr r)))
(define-values (prot? prot?-rest) (loop bdg-rest))
(define-values (stx? stx?-rest) (loop prot?-rest))
(values (provided bdg prot? stx?) stx?-rest)]
[(#:module-binding)
(values 'binding (discard r 10))]
[(#:simple-module-binding)
(values 'binding (discard r 4))]
[else
(cond
[(or (symbol? i)
(number? i)
(string? i)
(null? i)
(hash? i)
(boolean? i))
(values i (cdr r))]
[else
(error 'deserialize "unsupported instruction: ~s" i)])])])))
(define (syntax-module-path-index-shift . args)
(error 'syntax-module-path-index-shift "not supported"))
(define (syntax-shift-phase-level . args)
(error 'syntax-shift-phase-level "not supported"))
(define deserialize-instance
(make-instance 'deserialize #f 'constant
'deserialize-module-path-indexes deserialize-module-path-indexes
'syntax-module-path-index-shift syntax-module-path-index-shift
'syntax-shift-phase-level syntax-shift-phase-level
'module-use module-use
'deserialize deserialize))

13
pkgs/compiler-test/tests/compiler/demodularizer/demod-test.rkt
View File

@ -12,7 +12,7 @@
(apply system* command args)) (apply system* command args))
(values (get-output-string o) (get-output-string e))) (values (get-output-string o) (get-output-string e)))
(define (test-on-program filename) (define (test-on-program filename [exceptions null])
;; run modular program, capture output ;; run modular program, capture output
(define-values (modular-output modular-error) (define-values (modular-output modular-error)
(capture-output (find-exe) filename)) (capture-output (find-exe) filename))
@ -26,7 +26,9 @@
;; demodularize ;; demodularize
(parameterize ([current-input-port (open-input-string "")]) (parameterize ([current-input-port (open-input-string "")])
(system* (find-exe) "-l-" "raco" "demod" "-o" demod-filename filename)) (apply system* (find-exe) "-l-" "raco" "demod" "-o" demod-filename
(append exceptions
(list filename))))
;; run whole program ;; run whole program
(define-values (whole-output whole-error) (define-values (whole-output whole-error)
@ -50,4 +52,9 @@
(define ip (build-path tests i)) (define ip (build-path tests i))
(when (modular-program? ip) (when (modular-program? ip)
(printf "Checking ~a\n" ip) (printf "Checking ~a\n" ip)
(test-on-program (path->string ip))))) (test-on-program (path->string ip))
(printf "Checking ~a, skip racket/private/pre-base\n" ip)
(test-on-program (path->string ip)
(list "-e"
(path->string
(collection-file-path "pre-base.rkt" "racket/private")))))))

60
pkgs/racket-benchmarks/tests/racket/benchmarks/common/auto.rkt
View File

@ -252,6 +252,18 @@ exec racket -qu "$0" ${1+"$@"}
(bytes->number (caddr m)) (bytes->number (caddr m))
(bytes->number (cadddr m))))) (bytes->number (cadddr m)))))
(define (mk-chez bm)
(parameterize ([current-input-port
(open-input-string
(format
"(compile-file \"~a.sch\")\n(exit)\n"
bm))]
[current-output-port (open-output-nowhere)])
(system "scheme -q")))
(define (run-chez bm)
(system (format "scheme --script ~a.so" bm)))
(define (run-petite bm) (define (run-petite bm)
(parameterize ([current-input-port (parameterize ([current-input-port
(open-input-string (open-input-string
@ -260,11 +272,33 @@ exec racket -qu "$0" ${1+"$@"}
bm))]) bm))])
(system "petite"))) (system "petite")))
(define (extract-petite-times bm str) (define (extract-chez-times bm str)
(let ([m (regexp-match #rx#"([0-9]+) ms elapsed cpu time(?:, including ([0-9]+) ms collecting)?[ \n]* ([0-9]+) ms elapsed real time" str)]) (let ([m (regexp-match #rx#"([0-9.]+)s elapsed cpu time(?:, including ([0-9.]+)s collecting)?[ \n]* ([0-9.]+)s elapsed real time" str)])
(list (bytes->number (cadr m)) (define (s n) (inexact->exact (floor (* n 1000))))
(bytes->number (cadddr m)) (list (s (bytes->number (cadr m)))
(if (caddr m) (bytes->number (caddr m)) 0)))) (s (bytes->number (cadddr m)))
(if (caddr m) (s (bytes->number (caddr m))) 0))))
(define (setup-chez-sps bm)
(setup-sps bm "(only (chezscheme) time)"))
(define (mk-chez-sps bm)
(parameterize ([current-input-port
(open-input-string
(format (string-append
"(compile-file \"~a.sls\")\n")
bm))]
[current-output-port (open-output-bytes)])
(system "scheme")
;; Make sure compiled version is used:
(delete-file (format "~a.sls" bm))))
(define (run-chez-sps bm)
(system "scheme --script prog.sps"))
(define (clean-up-chez-sps bm)
(clean-up-sps bm)
(delete-file (format "~a.so" bm)))
;; requires guile 2.0.2 or higher ;; requires guile 2.0.2 or higher
(define (mk-guile bm) (define (mk-guile bm)
@ -537,9 +571,23 @@ exec racket -qu "$0" ${1+"$@"}
void void
void void
run-petite run-petite
extract-petite-times extract-chez-times
void void
racket-specific-progs) racket-specific-progs)
(make-impl 'chez
void
mk-chez
run-chez
extract-chez-times
void
racket-specific-progs)
(make-impl 'chez-sps
setup-chez-sps
mk-chez-sps
run-chez-sps
extract-chez-times
clean-up-chez-sps
racket-specific-progs)
(make-impl 'guile (make-impl 'guile
void void
mk-guile mk-guile

29
pkgs/racket-benchmarks/tests/racket/benchmarks/rx/auto.rkt
View File

@ -11,6 +11,7 @@ exec racket -qu "$0" ${1+"$@"}
"../common/cmdline.rkt") "../common/cmdline.rkt")
;; Needed for rxmzold, comment out otherwise: ;; Needed for rxmzold, comment out otherwise:
#;
(begin (begin
(define pregexp regexp) (define pregexp regexp)
(define byte-pregexp byte-regexp)) (define byte-pregexp byte-regexp))
@ -224,21 +225,21 @@ exec racket -qu "$0" ${1+"$@"}
(list 'stress-xs (make-bytes 1000 (char->integer #\x)) #"x*" 100000 '()) (list 'stress-xs (make-bytes 1000 (char->integer #\x)) #"x*" 100000 '())
(list 'stress-xs (make-bytes 10000 (char->integer #\x)) #"x*" 10000 '()) (list 'stress-xs (make-bytes 10000 (char->integer #\x)) #"x*" 10000 '())
(list 'stress-xs (make-bytes 100000 (char->integer #\x)) #"x*" 1000 '()) (list 'stress-xs (make-bytes 100000 (char->integer #\x)) #"x*" 1000 '())
(list 'stress-xy (make-bytes 100 (char->integer #\x)) #"[xy]*" 100000 '()) (list 'stress-xy (make-bytes 100 (char->integer #\x)) #"[xy]*" 1000000 '())
(list 'stress-xy (make-bytes 1000 (char->integer #\x)) #"[xy]*" 10000 '()) (list 'stress-xy (make-bytes 1000 (char->integer #\x)) #"[xy]*" 100000 '())
(list 'stress-xy (make-bytes 10000 (char->integer #\x)) #"[xy]*" 1000 '()) (list 'stress-xy (make-bytes 10000 (char->integer #\x)) #"[xy]*" 10000 '())
(list 'stress-xy (make-bytes 100000 (char->integer #\x)) #"[xy]*" 100 '()) (list 'stress-xy (make-bytes 100000 (char->integer #\x)) #"[xy]*" 1000 '())
(list 'stress-xysave (make-bytes 100 (char->integer #\x)) #"([xy])*" 100000 '()) (list 'stress-xysave (make-bytes 100 (char->integer #\x)) #"([xy])*" 100000 '())
(list 'stress-xory (make-bytes 100 (char->integer #\x)) #"(?:y|x)*" 10000 '()) (list 'stress-xory (make-bytes 100 (char->integer #\x)) #"(?:y|x)*" 100000 '())
(list 'stress-xory (make-bytes 1000 (char->integer #\x)) #"(?:y|x)*" 1000 '(python)) (list 'stress-xory (make-bytes 1000 (char->integer #\x)) #"(?:y|x)*" 10000 '(python))
(list 'stress-xory (make-bytes 10000 (char->integer #\x)) #"(?:y|x)*" 100 '(python)) (list 'stress-xory (make-bytes 10000 (char->integer #\x)) #"(?:y|x)*" 1000 '(python))
(list 'stress-xory (make-bytes 100000 (char->integer #\x)) #"(?:y|x)*" 10 '(pcre python)) (list 'stress-xory (make-bytes 100000 (char->integer #\x)) #"(?:y|x)*" 100 '(pcre python))
(list 'stress-xorysave (make-bytes 100 (char->integer #\x)) #"(y|x)*" 10000 '()) (list 'stress-xorysave (make-bytes 100 (char->integer #\x)) #"(y|x)*" 100000 '())
(list 'stress-yzorx (make-bytes 100 (char->integer #\x)) #"(?:[yz]|x)*" 10000 '()) (list 'stress-yzorx (make-bytes 100 (char->integer #\x)) #"(?:[yz]|x)*" 100000 '())
(list 'stress-yzorx (make-bytes 1000 (char->integer #\x)) #"(?:[yz]|x)*" 1000 '(python)) (list 'stress-yzorx (make-bytes 1000 (char->integer #\x)) #"(?:[yz]|x)*" 10000 '(python))
(list 'stress-yzorx (make-bytes 10000 (char->integer #\x)) #"(?:[yz]|x)*" 100 '(python)) (list 'stress-yzorx (make-bytes 10000 (char->integer #\x)) #"(?:[yz]|x)*" 1000 '(python))
(list 'stress-yzorx (make-bytes 100000 (char->integer #\x)) #"(?:[yz]|x)*" 10 '(pcre python)) (list 'stress-yzorx (make-bytes 100000 (char->integer #\x)) #"(?:[yz]|x)*" 100 '(pcre python))
(list 'stress-yzorxsave (make-bytes 100 (char->integer #\x)) #"([yz]|x)*" 10000 '()) (list 'stress-yzorxsave (make-bytes 100 (char->integer #\x)) #"([yz]|x)*" 100000 '())
(list 'stress-x2 (make-bytes 100 (char->integer #\x)) #"(?:x{2})*" 10000 '(rxmzold)) (list 'stress-x2 (make-bytes 100 (char->integer #\x)) #"(?:x{2})*" 10000 '(rxmzold))
(list 'stress-x2 (make-bytes 1000 (char->integer #\x)) #"(?:x{2})*" 10000 '(python rxmzold)) (list 'stress-x2 (make-bytes 1000 (char->integer #\x)) #"(?:x{2})*" 10000 '(python rxmzold))
(list 'stress-x2 (make-bytes 10000 (char->integer #\x)) #"(?:x{2})*" 100 '(python rxmzold)) (list 'stress-x2 (make-bytes 10000 (char->integer #\x)) #"(?:x{2})*" 100 '(python rxmzold))

14
pkgs/racket-doc/pkg/scribblings/dirs-catalog.scrbl
View File

@ -25,14 +25,16 @@ hold packages:
@commandline{racket -l- pkg/dirs-catalog @nonterm{dest-catalog} @nonterm{dir} ...} @commandline{racket -l- pkg/dirs-catalog @nonterm{dest-catalog} @nonterm{dir} ...}
The @DFlag{link}, @DFlag{merge}, @DFlag{check-metadata}, and The @DFlag{immediate}, @DFlag{link}, @DFlag{merge}, @DFlag{check-metadata}, and
@DFlag{quiet} flags correspond to optional keyword arguments of @DFlag{quiet} flags correspond to optional keyword arguments of
@racket[create-dirs-catalog]. @racket[create-dirs-catalog].
@history[#:added "6.1.1.6"] @history[#:added "6.1.1.6"
#:changed "6.90.0.4" @elem{Added @DFlag{immediate}.}]
@defproc[(create-dirs-catalog [catalog-path path-string?] @defproc[(create-dirs-catalog [catalog-path path-string?]
[dirs (listof path-string?)] [dirs (listof path-string?)]
[#:immediate? immediate? any/c #f]
[#:link? link? any/c #f] [#:link? link? any/c #f]
[#:merge? merge? any/c #f] [#:merge? merge? any/c #f]
[#:check-metadata? check-metadata? any/c #f] [#:check-metadata? check-metadata? any/c #f]
@ -43,7 +45,9 @@ Creates or modifies @racket[catalog-path] as a directory that works as
a catalog (see @secref["catalog-protocol"]) to list the packages that a catalog (see @secref["catalog-protocol"]) to list the packages that
are contained in each directory specified by @racket[dirs]. Packages are contained in each directory specified by @racket[dirs]. Packages
are discovered in @racket[dirs] as subdirectories that have an are discovered in @racket[dirs] as subdirectories that have an
@filepath{info.rkt} file. @filepath{info.rkt} file; if @racket[immediate?] is true, then each
directory is @racket[dirs] is checked for an immediate @filepath{info.rkt}
file before checking subdirectories.
If @racket[link?] is true, then the catalog specifies that the package If @racket[link?] is true, then the catalog specifies that the package
should be installed as a directory link, as opposed to copies. should be installed as a directory link, as opposed to copies.
@ -56,4 +60,6 @@ To create author and description information for each package in the
catalog, @racket[create-dirs-catalog] looks for a @racket[pkg-authors] catalog, @racket[create-dirs-catalog] looks for a @racket[pkg-authors]
and @racket[pkg-desc] definition in each package's @filepath{info.rkt} and @racket[pkg-desc] definition in each package's @filepath{info.rkt}
file. If either definition is missing and @racket[check-metadata?] is file. If either definition is missing and @racket[check-metadata?] is
true, an error is reported.} true, an error is reported.
@history[#:changed "6.90.0.4" @elem{Added the @racket[#:immediate] argument.}]}

1
pkgs/racket-doc/scribblings/foreign/derived.scrbl
View File

@ -17,6 +17,7 @@
@include-section["schedule.scrbl"] @include-section["schedule.scrbl"]
@include-section["port.scrbl"] @include-section["port.scrbl"]
@include-section["global.scrbl"] @include-section["global.scrbl"]
@include-section["os-thread.scrbl"]
@include-section["objc.scrbl"] @include-section["objc.scrbl"]
@include-section["ns.scrbl"] @include-section["ns.scrbl"]
@include-section["com.scrbl"] @include-section["com.scrbl"]

63
pkgs/racket-doc/scribblings/foreign/os-thread.scrbl Normal file
View File

@ -0,0 +1,63 @@
#lang scribble/doc
@(require "utils.rkt"
(for-label ffi/unsafe/os-thread))
@title{Operating System Threads}
@defmodule[ffi/unsafe/os-thread]{The
@racketmodname[ffi/unsafe/os-thread] library provides functions for
running constrained Racket code in a separate thread at the
operating-system level. Except for @racket[os-thread-enabled?], the
functions of @racketmodname[ffi/unsafe/os-thread] are currently
supported only when @racket[(system-type 'vm)] returns
@racket['chez-scheme], and even then only in certain build modes. The
functions raise @racket[exn:fail:unsupported] when not supported.}
@history[#:added "6.90.0.9"]
@defproc[(os-thread-enabled?) boolean?]{
Returns @racket[#t] if the other functions of
@racketmodname[ffi/unsafe/os-thread] work without raising
@racket[exn:fail:unsupported], @racket[#f] otherwise.}
@defproc[(call-in-os-thread [thunk (-> any)]) void?]{
Runs @racket[thunk] in a separate operating-system thread, which runs
concurrently to all Racket threads.
The @racket[thunk] is run in @tech{atomic mode}, and it must not
inspect its continuation or use any Racket thread functions (such as
@racket[thread] or @racket[current-thread]), any Racket
synchronization functions (such as @racket[semaphore-post] or
@racket[sync]), or any parameters (such as
@racket[current-output-port]). Variables may be safely mutated with
@racket[set!], and vectors, mutable pairs, boxes, mutable structure
fields, and @racket[eq?]- and @racket[eqv?]-based hash tables can be
mutated, but the visibility of mutations to other threads is
unspecified except as synchronized through @racket[os-semaphore-wait]
and @racket[os-semaphore-post].}
@defproc[(make-os-semaphore) any]{
Creates a semaphore that can be used with @racket[os-semaphore-wait]
and @racket[os-semaphore-post] to synchronize an operating-system
thread with Racket threads and other operating-system threads.}
@defproc[(os-semaphore-post [sema any/c]) void?]{
Analogous to @racket[semaphore-post], but posts to a semaphore created
by @racket[make-os-semaphore].}
@defproc[(os-semaphore-wait [sema any/c]) void?]{
Analogous to @racket[semaphore-wait], but waits on a semaphore created
by @racket[make-os-semaphore]. Waiting blocks the current thread; if
the current thread is a Racket thread, then waiting also blocks all
Racket threads.}

9
pkgs/racket-doc/scribblings/foreign/types.scrbl
View File

@ -553,10 +553,11 @@ For @tech{callouts} to foreign functions with the generated type:
@item{If @racket[blocking?] is true, then a foreign @tech{callout} @item{If @racket[blocking?] is true, then a foreign @tech{callout}
deactivates tracking of the calling OS thread---to the degree deactivates tracking of the calling OS thread---to the degree
supported by the Racket variant---during the foreign call. supported by the Racket variant---during the foreign call. The
Currently the value of @racket[blocking?] has no effect, but it value of @racket[blocking?] affects only the @tech[#:doc
may enable activity such as concurrent garbage collection in guide.scrbl]{CS} variant of Racket, where it enable activity
future variants of Racket. If the blocking @tech{callout} can such as garbage collection in other OS threads while the
@tech{callout} blocks. If the blocking @tech{callout} can
invoke any @tech{callbacks} back to Racket, those invoke any @tech{callbacks} back to Racket, those
@tech{callbacks} must be constructed with a non-@racket[#f] @tech{callbacks} must be constructed with a non-@racket[#f]
value of @racket[async-apply], even if they are always applied value of @racket[async-apply], even if they are always applied

30
pkgs/racket-doc/scribblings/foreign/unexported.scrbl
View File

@ -45,25 +45,47 @@ cstructs, and another ctype for user-defined ctypes.}
@defproc[(ffi-call [ptr cpointer?] [in-types (listof ctype?)] [out-type ctype?] @defproc[(ffi-call [ptr cpointer?] [in-types (listof ctype?)] [out-type ctype?]
[abi (or/c #f 'default 'stdcall 'sysv) #f] [abi (or/c #f 'default 'stdcall 'sysv) #f]
[save-errno? any/c] [save-errno? any/c]
[orig-place? any/c]) [orig-place? any/c]
[lock-name (or/c #f string?) #f]
[blocking? any/c #f])
procedure?]{ procedure?]{
The primitive mechanism that creates Racket ``callout'' values for The primitive mechanism that creates Racket @tech{callout} values for
@racket[_cprocedure]. The given @racket[ptr] is wrapped in a @racket[_cprocedure]. The given @racket[ptr] is wrapped in a
Racket-callable primitive function that uses the types to specify how Racket-callable primitive function that uses the types to specify how
values are marshaled.} values are marshaled.}
@defproc[(ffi-call-maker [in-types (listof ctype?)] [out-type ctype?]
[abi (or/c #f 'default 'stdcall 'sysv) #f]
[save-errno? any/c]
[orig-place? any/c]
[lock-name (or/c #f string?) #f]
[blocking? any/c #f])
(cpointer . -> . procedure?)]{
@defproc[(ffi-callback [proc any/c] [in-types any/c] [out-type any/c] A curried variant of @racket[ffi-call] that takes the foreign-procedure pointer
separately.}
@defproc[(ffi-callback [proc procedure?] [in-types any/c] [out-type any/c]
[abi (or/c #f 'default 'stdcall 'sysv) #f] [abi (or/c #f 'default 'stdcall 'sysv) #f]
[atomic? any/c #f] [atomic? any/c #f]
[async-apply (or/c #f ((-> any) . -> . any)) #f]) [async-apply (or/c #f ((-> any) . -> . any)) #f])
ffi-callback?]{ ffi-callback?]{
The symmetric counterpart of @racket[ffi-call]. It receives a Racket The symmetric counterpart of @racket[ffi-call]. It receives a Racket
procedure and creates a callback object, which can also be used as a procedure and creates a @tech{callback} object, which can also be used as a
C pointer.} C pointer.}
@defproc[(ffi-callback-maker [in-types any/c] [out-type any/c]
[abi (or/c #f 'default 'stdcall 'sysv) #f]
[atomic? any/c #f]
[async-apply (or/c #f ((-> any) . -> . any)) #f])
(procedure? . -> . ffi-callback?)]{
A curried variant of @racket[ffi-callback] that takes the callback procedure
separately.}
@defproc[(ffi-callback? [x any/c]) boolean?]{ @defproc[(ffi-callback? [x any/c]) boolean?]{

6
pkgs/racket-doc/scribblings/guide/performance.scrbl
View File

@ -419,13 +419,13 @@ string or byte string, write a constant @tech{regexp} using an
@section[#:tag "gc-perf"]{Memory Management} @section[#:tag "gc-perf"]{Memory Management}
The Racket implementation is available in two variants: @deftech{3m} and The Racket implementation is available in three variants: @deftech{3m},
@deftech{CGC}. The @tech{3m} variant uses a modern, @deftech{CGC}, and @deftech{CS}. The @tech{3m} and @tech{CS} variants use a modern,
@deftech{generational garbage collector} that makes allocation @deftech{generational garbage collector} that makes allocation
relatively cheap for short-lived objects. The @tech{CGC} variant uses relatively cheap for short-lived objects. The @tech{CGC} variant uses
a @deftech{conservative garbage collector} which facilitates a @deftech{conservative garbage collector} which facilitates
interaction with C code at the expense of both precision and speed for interaction with C code at the expense of both precision and speed for
Racket memory management. The 3m variant is the standard one. Racket memory management. The @tech{3m} variant is currently the standard one.
Although memory allocation is reasonably cheap, avoiding allocation Although memory allocation is reasonably cheap, avoiding allocation
altogether is normally faster. One particular place where allocation altogether is normally faster. One particular place where allocation

9
pkgs/racket-doc/scribblings/raco/decompile.scrbl
View File

@ -4,7 +4,7 @@
"common.rkt" "common.rkt"
(for-label racket/base (for-label racket/base
compiler/decompile compiler/decompile
(only-in compiler/zo-parse compilation-top? req) (only-in compiler/zo-parse linkl-directory? linkl-bundle? linkl?)
compiler/zo-marshal)) compiler/zo-marshal))
@title[#:tag "decompile"]{@exec{raco decompile}: Decompiling Bytecode} @title[#:tag "decompile"]{@exec{raco decompile}: Decompiling Bytecode}
@ -133,7 +133,7 @@ Many forms in the decompiled code, such as @racket[module],
@defmodule[compiler/decompile] @defmodule[compiler/decompile]
@defproc[(decompile [top compilation-top?]) any/c]{ @defproc[(decompile [top (or/c linkl-directory? linkl-bundle? linkl?)]) any/c]{
Consumes the result of parsing bytecode and returns an S-expression Consumes the result of parsing bytecode and returns an S-expression
(as described above) that represents the compiled code.} (as described above) that represents the compiled code.}
@ -148,11 +148,11 @@ Consumes the result of parsing bytecode and returns an S-expression
@defmodule[compiler/zo-marshal] @defmodule[compiler/zo-marshal]
@defproc[(zo-marshal-to [top compilation-top?] [out output-port?]) void?]{ @defproc[(zo-marshal-to [top (or/c linkl-directory? linkl-bundle?)] [out output-port?]) void?]{
Consumes a representation of bytecode and writes it to @racket[out].} Consumes a representation of bytecode and writes it to @racket[out].}
@defproc[(zo-marshal [top compilation-top?]) bytes?]{ @defproc[(zo-marshal [top (or/c linkl-directory? linkl-bundle?)]) bytes?]{
Consumes a representation of bytecode and generates a byte string for Consumes a representation of bytecode and generates a byte string for
the marshaled bytecode.} the marshaled bytecode.}
@ -160,4 +160,3 @@ the marshaled bytecode.}
@; ------------------------------------------------------------ @; ------------------------------------------------------------
@include-section["zo-struct.scrbl"] @include-section["zo-struct.scrbl"]

10
pkgs/racket-doc/scribblings/raco/exe-api.scrbl
View File

@ -71,7 +71,7 @@ parameter is true.
null] null]
[#:gracket? gracket? any/c #f] [#:gracket? gracket? any/c #f]
[#:mred? mred? any/c #f] [#:mred? mred? any/c #f]
[#:variant variant (or/c 'cgc '3m) [#:variant variant (or/c 'cgc '3m 'cs)
(system-type 'gc)] (system-type 'gc)]
[#:aux aux (listof (cons/c symbol? any/c)) null] [#:aux aux (listof (cons/c symbol? any/c)) null]
[#:collects-path collects-path [#:collects-path collects-path
@ -384,7 +384,7 @@ have been applied as needed to refer to the existing file).}
[cmdline (listof string?)] [cmdline (listof string?)]
[aux (listof (cons/c symbol? any/c)) null] [aux (listof (cons/c symbol? any/c)) null]
[launcher? any/c #f] [launcher? any/c #f]
[variant (one-of/c 'cgc '3m) (system-type 'gc)] [variant (one-of/c 'cgc '3m'cs) (system-type 'gc)]
[collects-path (or/c #f [collects-path (or/c #f
path-string? path-string?
(listof path-string?)) (listof path-string?))
@ -477,9 +477,9 @@ A unit that imports nothing and exports @racket[compiler:embed^].}
@defproc[(find-exe [#:cross? cross? any/c #f] @defproc[(find-exe [#:cross? cross? any/c #f]
[#:untetherd? untethered? any/c #f] [#:untetherd? untethered? any/c #f]
[gracket? any/c #f] [gracket? any/c #f]
[variant (or/c 'cgc '3m) (if cross? [variant (or/c 'cgc '3m 'cs) (if cross?
(cross-system-type 'gc) (cross-system-type 'gc)
(system-type 'gc))]) (system-type 'gc))])
path?]{ path?]{
Finds the path to the @exec{racket} or @exec{gracket} (when Finds the path to the @exec{racket} or @exec{gracket} (when

4
pkgs/racket-doc/scribblings/raco/exe.scrbl
View File

@ -146,6 +146,10 @@ The @exec{raco exe} command accepts the following command-line flags:
variant of Racket, which is the default only when running a variant of Racket, which is the default only when running a
@exec{raco exe} that is based on the @gtech{CGC} variant.} @exec{raco exe} that is based on the @gtech{CGC} variant.}
@item{@DFlag{cs} --- generate an executable based on the @gtech{cs}
variant of Racket, which is the default unless running a @exec{raco
exe} that is based on the @gtech{CS} variant.}
@item{@DPFlag{aux} @nonterm{file} --- attach information to the @item{@DPFlag{aux} @nonterm{file} --- attach information to the
executable based on @nonterm{file}'s suffix; see executable based on @nonterm{file}'s suffix; see
@racket[extract-aux-from-path] for a list of recognized suffixes @racket[extract-aux-from-path] for a list of recognized suffixes

20
pkgs/racket-doc/scribblings/raco/launcher.scrbl
View File

@ -55,9 +55,9 @@ the following additional associations apply to launchers:
Racket or GRacket binary, like @exec{raco.exe}. No other Racket or GRacket binary, like @exec{raco.exe}. No other
@racket[aux] associations are used for an old-style launcher.} @racket[aux] associations are used for an old-style launcher.}
@item{@racket['exe-name] (Mac OS, @racket['script-3m] or @item{@racket['exe-name] (Mac OS, @racket['script-3m],
@racket['script-cgc] variant) --- provides the base name for a @racket['script-cgc] or @racket['script-cs] variant) --- provides the base name for a
@racket['3m]-/@racket['cgc]-variant launcher, which the script @racket['3m]-/@racket['cgc]-/@racket['cs]-variant launcher, which the script
will call ignoring @racket[args]. If this name is not provided, will call ignoring @racket[args]. If this name is not provided,
the script will go through the GRacket executable as usual.} the script will go through the GRacket executable as usual.}
@ -527,24 +527,24 @@ are as follows:
A parameter that indicates a variant of Racket or GRacket to use for A parameter that indicates a variant of Racket or GRacket to use for
launcher creation and for generating launcher names. The default is launcher creation and for generating launcher names. The default is
the result of @racket[(system-type 'gc)]. On Unix and Windows, the the result of @racket[(system-type 'gc)]. On Unix and Windows, the
possibilities are @racket['cgc] and @racket['3m]. On Mac OS, the possibilities are @racket['cgc], @racket['3m], and @racket['cs]. On Mac OS, the
@racket['script-3m] and @racket['script-cgc] variants are also @racket['script-cgc], @racket['script-3m], and @racket['script-cs] variants are also
available for GRacket launchers.} available for GRacket launchers.}
@defproc[(available-gracket-variants) (listof symbol?)]{ @defproc[(available-gracket-variants) (listof symbol?)]{
Returns a list of symbols corresponding to available variants of GRacket Returns a list of symbols corresponding to available variants of GRacket
in the current Racket installation. The list normally includes at in the current Racket installation. The list normally includes at
least one of @racket['3m] or @racket['cgc]--- whichever is the result least one of @racket['3m], @racket['cgc], or @racket['cs]--- whichever is the result
of @racket[(system-type 'gc)]---and may include the other, as well as of @racket[(system-type 'gc)]---and may include the others, as well as
@racket['script-3m] and/or @racket['script-cgc] on Mac OS.} @racket['script-3m], @racket['script-cgc], and/or @racket['script-cs] on Mac OS.}
@defproc[(available-racket-variants) (listof symbol?)]{ @defproc[(available-racket-variants) (listof symbol?)]{
Returns a list of symbols corresponding to available variants of Returns a list of symbols corresponding to available variants of
Racket in the current Racket installation. The list normally Racket in the current Racket installation. The list normally
includes at least one of @racket['3m] or @racket['cgc]---whichever is includes at least one of @racket['3m], @racket['cgc], or @racket['cs]---whichever is
the result of @racket[(system-type 'gc)]---and may include the other.} the result of @racket[(system-type 'gc)]---and may include the others.}
@deftogether[( @deftogether[(
@defproc[(mred-launcher-up-to-date? [dest path-string?] @defproc[(mred-launcher-up-to-date? [dest path-string?]

19
pkgs/racket-doc/scribblings/raco/make.scrbl
View File

@ -830,4 +830,23 @@ module and use @exec{raco make} in its default mode.
@(close-eval cm-eval) @(close-eval cm-eval)
@; ---------------------------------------------------------------------- @; ----------------------------------------------------------------------
@include-section["api.scrbl"] @include-section["api.scrbl"]
@; ----------------------------------------------------------------------
@section{API for Reading Compilation Dependencies}
@defmodule[compiler/depend]{The @racketmodname[compiler/depend] module
provides a function to inspect and traverse the dependency information
generated by @exec{raco make}, @exec{raco setup}, or @racketmodname[compiler/cm].}
@history[#:added "6.90.0.13"]
@defproc[(module-recorded-dependencies [module-file path?])
(listof (and path? (complete-path? path?)))]{
Given a @racket[module-file] for a file that has been compiled with
@exec{raco make}, @exec{raco setup}, or @racketmodname[compiler/cm],
returns a list of dependencies for @racket[module-file] by reading and
traversing dependency-information files left behind by compilation.}

39
pkgs/racket-doc/scribblings/raco/setup.scrbl
View File

@ -285,6 +285,28 @@ flags:
install archive into the installation instead of a user-specific install archive into the installation instead of a user-specific
location.} location.}
]}
@item{Bootstrapping:
@itemize[
@item{@DFlag{boot} @nonterm{module-file} @nonterm{build-dir} --- For
use by directly running @racketmodname[setup] instead of
through @exec{raco setup}, loads @nonterm{module-file} in the
same way that @exec{raco setup} normally loads itself,
auto-detecting the need to start from sources and rebuild the
compiled files---even for the compilation manager itself. The
@nonterm{build-dir} path is installed as the only path in
@racket[current-compiled-file-roots], so all compiled files
go there.}
@item{@DFlag{chain} @nonterm{module-file} @nonterm{build-dir} ---
Like @DFlag{boot}, but adds @nonterm{build-dir} to the start of
@racket[current-compiled-file-roots] instead of replacing the
current value, which means that libraries already built in the
normal location (including the compilation manager itself) will
be used instead of rebuilt. This mode makes sense for
cross-compilation.}
]} ]}
] ]
@ -1174,6 +1196,19 @@ form.}
} }
@; ----------------------------------------
@subsection{Setup Start Module}
@defmodule[setup]{The @racketmodname[setup] library implements
@exec{raco setup}, including the part that bootstraps @exec{raco setup}
if its own implementation needs to be compiled.}
When running @racketmodname[setup] via @exec{racket}, supply the
@exec{@Flag{N} raco} to ensure that command-line arguments are parsed
the same way as for @exec{raco setup}, as opposed to a legacy
command-line mode.
@; ------------------------------------------------------------------------ @; ------------------------------------------------------------------------
@section[#:tag ".plt-archives"]{API for Installing @filepath{.plt} Archives} @section[#:tag ".plt-archives"]{API for Installing @filepath{.plt} Archives}
@ -2019,7 +2054,7 @@ platform's installation already includes those libraries.
@history[#:added "6.3"] @history[#:added "6.3"]
@defproc[(cross-system-type [mode (or/c 'os 'word 'gc 'link 'machine @defproc[(cross-system-type [mode (or/c 'os 'word 'gc 'vm 'link 'machine
'so-suffix 'so-mode 'fs-change) 'so-suffix 'so-mode 'fs-change)
'os]) 'os])
(or/c symbol? string? bytes? exact-positive-integer? vector?)]{ (or/c symbol? string? bytes? exact-positive-integer? vector?)]{
@ -2032,7 +2067,7 @@ cross-installation mode, the results are the same as for
See also @racket['cross] mode for @racket[system-type].} See also @racket['cross] mode for @racket[system-type].}
@defproc[(cross-system-library-subpath [mode (or/c 'cgc '3m #f) @defproc[(cross-system-library-subpath [mode (or/c 'cgc '3m 'cs #f)
(system-type 'gc)]) (system-type 'gc)])
path-for-some-system?]{ path-for-some-system?]{

21
pkgs/racket-doc/scribblings/raco/zo-parse.scrbl
View File

@ -16,19 +16,17 @@ The @racketmodname[compiler/zo-parse] module re-exports
@racketmodname[compiler/zo-structs] in addition to @racketmodname[compiler/zo-structs] in addition to
@racket[zo-parse]. @racket[zo-parse].
@defproc[(zo-parse [in input-port? (current-input-port)]) compilation-top?]{ @defproc[(zo-parse [in input-port? (current-input-port)]) (or/c linkl-directory? linkl-bundle?)]{
Parses a port (typically the result of opening a @filepath{.zo} file) Parses a port (typically the result of opening a @filepath{.zo} file)
containing bytecode. Beware that the structure types used to containing bytecode. Beware that the structure types used to
represent the bytecode are subject to frequent changes across Racket represent the bytecode are subject to frequent changes across Racket
versons. versons.
The parsed bytecode is returned in a @racket[compilation-top] The parsed bytecode is returned in a @racket[link-directory] or
structure. For a compiled module, the @racket[compilation-top] @racket[link-bundle] structure---the latter only for the compilation
structure will contain a @racket[mod] structure. For a top-level of a module that contains no submodules.
sequence, it will normally contain a @racket[seq] or @racket[splice]
structure with a list of top-level declarations and expressions.
The bytecode representation of an expression is closer to an Within a linklet, the bytecode representation of an expression is closer to an
S-expression than a traditional, flat control string. For example, an S-expression than a traditional, flat control string. For example, an
@racket[if] form is represented by a @racket[branch] structure that @racket[if] form is represented by a @racket[branch] structure that
has three fields: a test expression, a ``then'' expression, and an has three fields: a test expression, a ``then'' expression, and an
@ -67,14 +65,7 @@ The @racketmodname[compiler/zo-parse] module re-exports
bucket array in the same way that it captured and restores a local bucket array in the same way that it captured and restores a local
variable. Mutable local variables are boxed similarly to global variable. Mutable local variables are boxed similarly to global
variables, but individual boxes are referenced from the stack and variables, but individual boxes are referenced from the stack and
closures. closures.}
Quoted syntax (in the sense of @racket[quote-syntax]) is treated like
a global variable, because it must be instantiated for an appropriate
phase. A @racket[prefix] structure within a @racket[compilation-top]
or @racket[mod] structure indicates the list of global variables and
quoted syntax that need to be instantiated (and put into an array on
the stack) before evaluating expressions that might use them.}
@defproc[(decode-module-binding [binding module-binding?] @defproc[(decode-module-binding [binding module-binding?]

571
pkgs/racket-doc/scribblings/raco/zo-struct.scrbl
View File

@ -34,96 +34,99 @@ structures that are produced by @racket[zo-parse] and consumed by
@; -------------------------------------------------- @; --------------------------------------------------
@section{Prefix} @section{Prefix}
@defstruct+[(compilation-top zo) @deftogether[(
([max-let-depth exact-nonnegative-integer?] @defstruct+[(linkl-directory zo)
[binding-namess (hash/c exact-nonnegative-integer? ([table (hash/c (listof symbol?) linkl-bundle?)])]
(hash/c symbol? stx?))] @defstruct+[(linkl-bundle zo)
[prefix prefix?] ([table (hash/c (or/c symbol? fixnum?) (or linkl? any/c))])]
[code (or/c form? any/c)])]{ )]{
Wraps compiled code. Wraps compiled code.
The @racket[max-let-depth] field indicates the Module and top-level compilation produce one or more linklets that
maximum stack depth that @racket[code] creates (not counting the represent independent evaluation in a specific phase. Even a single
@racket[prefix] array). top-level expression or a module with only run-time code will
generate multiple linklets to implement metadata and syntax data. A
module with no submodules is represented directly by a
@racket[linkl-bundle], while any other compiled form is represented
by a @racket[linkl-directory].
The @racket[binding-namess] field provides a per-phase mapping from A linklet bundle maps an integer to a linklet representing forms to
symbols that appear in @racket[prefix] for top-level evaluate at the integer-indicated phase. Symbols are mapped to
@racket[def-values] forms and in top-level @racket[def-syntaxes] metadata, such as a module's name as compiled or a linklet
forms. Each symbol is mapped to an identifier that will be bound implementing literal syntax objects. A linklet directory normally
(after introduction into the namespace) by the definition. maps @racket['()] to the main linklet bundle for a module or a single
top-level form; for a linklet directory that corresponds to a
sequence of top-level forms, however, there is no ``main'' linklet
bundle, and symbol forms of integers are used to order the linkets.
For a module with submodules, the linklet directory maps submodule
paths (as lists of symbols) to linklet bundles for the corresponding
submodules.}
The @racket[prefix] field describes top-level variables, @defstruct+[(linkl zo)
module-level variables, and quoted syntax-objects accessed by ([name symbol?]
@racket[code]. [importss (listof (listof symbol?))]
[import-shapess (listof (listof (or/c #f 'constant 'fixed
function-shape?
struct-shape?)))]
[exports (listof symbol?)]
[internals (listof (or/c symbol? #f))]
[lifts (listof symbol?)]
[source-names (hash/c symbol? symbol?)]
[body (listof (or/c form? any/c))]
[max-let-depth exact-nonnegative-integer?]
[need-instance-access? boolean?])]{
The @racket[code] field contains executable code; it is normally a Represents a linklet, which corresponds to a module body or a
@racket[form], but a literal value is represented as itself.} top-level sequence at a single phase.
@defstruct+[(prefix zo) The @racket[name] of a linklet is for debugging purposes, similar to
([num-lifts exact-nonnegative-integer?] the inferred name of a @racket[lambda] form.
[toplevels (listof (or/c #f symbol? global-bucket?
module-variable?))]
[stxs (listof (or stx? #f))]
[src-inspector-desc symbol?])]{
Represents a ``prefix'' that is pushed onto the stack to initiate
evaluation. The prefix is an array, where buckets holding the
values for @racket[toplevels] are first, then the buckets for the
@racket[stxs], then a bucket for another array if @racket[stxs] is
non-empty, then @racket[num-lifts] extra buckets for lifted local
procedures.
In @racket[toplevels], each element is one of the following: The @racket[importss] list of lists describes the linklet's imports.
@itemize[ Each of the elements of the out list corresponds to an import
@item{a @racket[#f], which indicates a dummy variable that is used source, and each element of an inner list is the symbolic name of an
to access the enclosing module/namespace at run time;} export from that source. The @racket[import-shapess] list is in
@item{a symbol, which is a reference to a variable defined in the parallel to @racket[imports]; it reflects optimization assumptions
enclosing module;} by the compiler that are used by the bytecode validator and checked
@item{a @racket[global-bucket], which is a top-level variable (appears when the linklet is instantiated.
only outside of modules); or}
@item{a @racket[module-variable], which indicates a variable imported
from another module.}
]
The variable buckets and syntax objects that are recorded in a prefix The @racket[exports] list describes the linklet's defined names that
are accessed by @racket[toplevel] and @racket[topsyntax] expression are exported. The @racket[internals] list describes additional
forms. definitions within the linket, but they are not accessible from the
outside of a linklet or one of its instances; a @racket[#f] can appear
When an element of @racket[stxs] is @racket[#f], it coresponds to a in place of an unreferenced internal definition that has been removed.
syntax object that was optimized away at the last minute. The slot The @racket[lifts] list
must not be referenced by a @racket[topsyntax] form. is an extension of @racket[internals] for procedures that are lifted
by the compiler; these procedures have certain properties that can be
checked by the bytecode validator.
The @racket[src-inspector-desc] field provides an inspector name that Each symbol in @racket[exports],
is used within syntax-object bindings. At run time, the prefix gets @racket[internals], and @racket[lifts] must be distinct from any
an inspector, and bindings that reference the same inspector name are other symbol in those lists. The @racket[source-names] table maps
granted access capabilities through that inspector.} symbols in @racket[exports], @racket[internals], and @racket[lifts]
to other symbols, potentially not distinct, that correspond to
original source names for the definition. The @racket[source-names]
table is used only for debugging.
@defstruct+[(global-bucket zo) ([name symbol?])]{ When a linklet is instantiated, variables correponding to the
Represents a top-level variable, and used only in a flattening of the lists @racket[importss], @racket[exports],
@racket[prefix]. Because modules cannot require top-level @racket[internals], and @racket[lifts] are placed in an array (in
variables, these will only appear in the top level that order) for access via @racket[toplevel] references. The initial
@racket[prefix]. Additionally, symbols in the top-level slot is reserved for a variable-like reference that strongly retains
prefix are an alias for @racket[global-bucket] structs, a connection to an instance of its enclosing linklet.
making them redundant.}
@defstruct+[(module-variable zo) The @racket[bodys] list is the executable content of the linklet. The
([modidx module-path-index?] value of the last element in @racket[bodys] may be returned when the
[sym symbol?] linklet is instantiated, depending on the way that it's instantiated.
[pos exact-integer?]
[phase exact-nonnegative-integer?] The @racket[max-let-depth] field indicates the maximum size of the
[constantness (or/c #f 'constant 'fixed stack that will be created by any @racket[body].
function-shape? struct-shape?)])]{
Represents a top-level variable, and used only in a @racket[prefix]. The @racket[need-instance-access?] boolean indicates whether the
The @racket[pos] may record the variable's offset within its module, linklet contains a @racket[toplevel] for position 0. A @racket[#t] is
or it can be @racket[-1] if the variable is always located by name. allowed (but suboptimal) if not such reference is present in the
The @racket[phase] indicates the phase level of the definition within linklet body.}
its module. The @racket[constantness] field is either @racket['constant],
a @racket[function-shape] value, or a @racket[struct-shape] value
to indicate that
variable's value is always the same for every instantiation of its module;
@racket['fixed] to indicate
that it doesn't change within a particular instantiation of the module;
or @racket[#f] to indicate that the variable's value
can change even for one particular instantiation of its module.}
@defstruct+[function-shape @defstruct+[function-shape
([arity procedure-arity?] ([arity procedure-arity?]
@ -137,11 +140,11 @@ returns.}
@deftogether[( @deftogether[(
@defstruct+[struct-shape ()] @defstruct+[struct-shape ()]
@defstruct+[(struct-type-shape struct-shape) ([field-count exact-nonnegative-integer?])] @defstruct+[(struct-type-shape struct-shape) ([field-count exact-nonnegative-integer?] [authentic? boolean?])]
@defstruct+[(constructor-shape struct-shape) ([arity exact-nonnegative-integer?])] @defstruct+[(constructor-shape struct-shape) ([arity exact-nonnegative-integer?])]
@defstruct+[(predicate-shape struct-shape) ()] @defstruct+[(predicate-shape struct-shape) ([authentic? boolean?])]
@defstruct+[(accessor-shape struct-shape) ([field-count exact-nonnegative-integer?])] @defstruct+[(accessor-shape struct-shape) ([field-count exact-nonnegative-integer?] [authentic? boolean?])]
@defstruct+[(mutator-shape struct-shape) ([field-count exact-nonnegative-integer?])] @defstruct+[(mutator-shape struct-shape) ([field-count exact-nonnegative-integer?] [authentic? boolean?])]
@defstruct+[(struct-type-property-shape struct-shape) ([has-guard? boolean?])] @defstruct+[(struct-type-property-shape struct-shape) ([has-guard? boolean?])]
@defstruct+[(property-predicate-shape struct-shape) ()] @defstruct+[(property-predicate-shape struct-shape) ()]
@defstruct+[(property-accessor-shape struct-shape) ()] @defstruct+[(property-accessor-shape struct-shape) ()]
@ -156,10 +159,10 @@ binding, constructor, etc.}
@; -------------------------------------------------- @; --------------------------------------------------
@section{Forms} @section{Forms and Inline Variants}
@defstruct+[(form zo) ()]{ @defstruct+[(form zo) ()]{
A supertype for all forms that can appear in compiled code (including A supertype for all forms that can appear in a linklet body (including
@racket[expr]s), except for literals that are represented as @racket[expr]s), except for literals that are represented as
themselves.} themselves.}
@ -167,170 +170,24 @@ binding, constructor, etc.}
([ids (listof toplevel?)] ([ids (listof toplevel?)]
[rhs (or/c expr? seq? inline-variant? any/c)])]{ [rhs (or/c expr? seq? inline-variant? any/c)])]{
Represents a @racket[define-values] form. Each element of Represents a @racket[define-values] form. Each element of
@racket[ids] will reference via the prefix either a top-level variable @racket[ids] references a defined variable in the enclosing linklet.
or a local module variable.
After @racket[rhs] is evaluated, the stack is restored to its depth After @racket[rhs] is evaluated, the stack is restored to its depth
from before evaluating @racket[rhs].} from before evaluating @racket[rhs].}
@deftogether[( @defstruct+[(inline-variant zo) ([direct expr?]
@defstruct+[(def-syntaxes form) ([ids (listof symbol?)] [inline expr?])]{
[rhs (or/c expr? seq? any/c)]
[prefix prefix?]
[max-let-depth exact-nonnegative-integer?]
[dummy (or/c toplevel? #f)])]
@defstruct+[(seq-for-syntax form)
([forms (listof (or/c form? any/c))]
[prefix prefix?]
[max-let-depth exact-nonnegative-integer?]
[dummy (or/c toplevel? #f)])]
)]{
Represents a @racket[define-syntaxes] or
@racket[begin-for-syntax] form. The @racket[rhs] expression or set of
@racket[forms] forms has its own @racket[prefix], which is pushed before evaluating
@racket[rhs] or the @racket[forms]; the stack is restored after obtaining the result values.
The @racket[max-let-depth] field indicates the maximum size of the
stack that will be created by @racket[rhs] (not counting
@racket[prefix]). The @racket[dummy] variable is used to access the enclosing
namespace.}
@defstruct+[(req form) ([reqs stx?]
[dummy toplevel?])]{
Represents a top-level @racket[#%require] form (but not one in a
@racket[module] form) with a sequence of specifications @racket[reqs].
The @racket[dummy] variable is used to access the top-level
namespace.}
@defstruct+[(seq form) ([forms (listof (or/c form? any/c))])]{
Represents a @racket[begin] form, either as an expression or at the
top level (though the latter is more commonly a @racket[splice] form).
When a @racket[seq] appears in an expression position, its
@racket[forms] are expressions.
After each form in @racket[forms] is evaluated, the stack is restored
to its depth from before evaluating the form.}
@defstruct+[(splice form) ([forms (listof (or/c form? any/c))])]{
Represents a top-level @racket[begin] form where each evaluation is
wrapped with a continuation prompt.
After each form in @racket[forms] is evaluated, the stack is restored
to its depth from before evaluating the form.}
@defstruct+[(inline-variant form) ([direct expr?]
[inline expr?])]{
Represents a function that is bound by @racket[define-values], where the Represents a function that is bound by @racket[define-values], where the
function has two variants. function has two variants.
The first variant is used for normal calls to the function. The second may The first variant is used for normal calls to the function. The second may
be used for cross-module inlining of the function.} be used for cross-module inlining of the function.}
@defstruct+[(mod form)
([name (or/c symbol? (listof symbol?))]
[srcname symbol?]
[self-modidx module-path-index?]
[prefix prefix?]
[provides (listof (list/c (or/c exact-integer? #f)
(listof provided?)
(listof provided?)))]
[requires (listof (cons/c (or/c exact-integer? #f)
(listof module-path-index?)))]
[body (listof (or/c form? any/c))]
[syntax-bodies (listof (cons/c exact-positive-integer?
(listof (or/c def-syntaxes?
seq-for-syntax?))))]
[unexported (listof (list/c exact-nonnegative-integer?
(listof symbol?)
(listof symbol?)))]
[max-let-depth exact-nonnegative-integer?]
[dummy toplevel?]
[lang-info (or/c #f (vector/c module-path? symbol? any/c))]
[internal-context (or/c #f #t stx? (vectorof stx?))]
[binding-names (hash/c exact-integer?
(hash/c symbol? (or/c #t stx?)))]
[flags (listof (or/c 'cross-phase))]
[pre-submodules (listof mod?)]
[post-submodules (listof mod?)])]{
Represents a @racket[module] declaration.
The @racket[provides] and @racket[requires] lists are each an
association list from phases to exports or imports. In the case of
@racket[provides], each phase maps to two lists: one for exported
variables, and another for exported syntax. In the case of
@racket[requires], each phase maps to a list of imported module paths.
The @racket[body] field contains the module's run-time (i.e., phase
0) code. The @racket[syntax-bodies] list has a list of forms for
each higher phase in the module body; the phases are in order
starting with phase 1. The @racket[body] forms use @racket[prefix],
rather than any prefix in place for the module declaration itself,
while members of lists in @racket[syntax-bodies] have their own
prefixes. After each form in @racket[body] or @racket[syntax-bodies]
is evaluated, the stack is restored to its depth from before
evaluating the form.
The @racket[unexported] list contains lists of symbols for
unexported definitions that can be accessed through macro expansion
and that are implemented through the forms in @racket[body] and
@racket[syntax-bodies]. Each list in @racket[unexported] starts
with a phase level.
The @racket[max-let-depth] field indicates the maximum stack depth
created by @racket[body] forms (not counting the @racket[prefix]
array).
The @racket[dummy] variable is used to access the top-level
namespace.
The @racket[lang-info] value specifies an optional module path that
provides information about the module's implementation language.
The @racket[internal-context] value describes the lexical context of
the body of the module. This value is used by
@racket[module->namespace]. A @racket[#f] value means that the
context is unavailable or empty. A @racket[#t] value means that the
context is computed by re-importing all required modules. A
syntax-object value embeds lexical information; the syntax object
should contain a vector of two elements, where the first element of
the vector is a syntax object for the module's body, which includes
the outside-edge and inside-edge scopes, and the second element of
the vector is a syntax object that has just the module's inside-edge
scope.
The @racket[binding-names] value provides additional information to
@racket[module->namespace] to correlate symbol names for variables
and syntax definitions to identifiers that map to those variables. A
separate table of names exists for each phase, and a @racket[#t]
mapping for a name indicates that it is mapped but inaccessible
(because the relevant scopes are inaccessible).
The @racket[flags] field records certain properties of the module.
The @racket['cross-phase] flag indicates that the module body is
evaluated once and the results shared across instances for all phases; such a
module contains only definitions of functions, structure types, and
structure type properties.
The @racket[pre-submodules] field records @racket[module]-declared
submodules, while the @racket[post-submodules] field records
@racket[module*]-declared submodules.}
@defstruct+[(provided zo)
([name symbol?]
[src (or/c module-path-index? #f)]
[src-name symbol?]
[nom-src (or/c module-path-index? #f)]
[src-phase exact-nonnegative-integer?]
[protected? boolean?])]{
Describes an individual provided identifier within a @racket[mod]
instance.}
@; -------------------------------------------------- @; --------------------------------------------------
@section{Expressions} @section{Expressions}
@defstruct+[(expr form) ()]{ @defstruct+[(expr form) ()]{
A supertype for all expression forms that can appear in compiled code, A supertype for all expression forms that can appear in compiled code,
except for literals that are represented as themselves and some except for literals that are represented as themselves.}
@racket[seq] structures (which can appear as an expression as long as
it contains only other things that can be expressions).}
@defstruct+[(lam expr) @defstruct+[(lam expr)
([name (or/c symbol? vector?)] ([name (or/c symbol? vector?)]
@ -367,7 +224,7 @@ binding, constructor, etc.}
refers to a syntax-object constant, the variables and constants are refers to a syntax-object constant, the variables and constants are
represented in the closure by capturing a prefix (in the sense represented in the closure by capturing a prefix (in the sense
of @racket[prefix]). The @racket[toplevel-map] field indicates of @racket[prefix]). The @racket[toplevel-map] field indicates
which top-level and lifted variables are actually used by the which top-level variables (i.e., linklet imports and definitions) are actually used by the
closure (so that variables in a prefix can be pruned by the run-time closure (so that variables in a prefix can be pruned by the run-time
system if they become unused) and whether any syntax objects are system if they become unused) and whether any syntax objects are
used (so that the syntax objects as a group can be similarly used (so that the syntax objects as a group can be similarly
@ -497,8 +354,8 @@ binding, constructor, etc.}
[pos exact-nonnegative-integer?] [pos exact-nonnegative-integer?]
[const? boolean?] [const? boolean?]
[ready? boolean?])]{ [ready? boolean?])]{
Represents a reference to a top-level or imported variable via the Represents a reference to an imported or defined variable within
@racket[prefix] array. The @racket[depth] field indicates the number a linklet. The @racket[depth] field indicates the number
of stack slots to skip to reach the prefix array, and @racket[pos] is of stack slots to skip to reach the prefix array, and @racket[pos] is
the offset into the array. the offset into the array.
@ -513,21 +370,11 @@ binding, constructor, etc.}
@racket[#f], then a check is needed to determine whether the @racket[#f], then a check is needed to determine whether the
variable is defined. variable is defined.
When the @racket[toplevel] is the right-hand side for When the @racket[toplevel] is the left-hand side for
@racket[def-values], then @racket[const?] is @racket[#f]. If @racket[def-values], then @racket[const?] is @racket[#f]. If
@racket[ready?] is @racket[#t], the variable is marked as immutable @racket[ready?] is @racket[#t], the variable is marked as immutable
after it is defined.} after it is defined.}
@defstruct+[(topsyntax expr)
([depth exact-nonnegative-integer?]
[pos exact-nonnegative-integer?]
[midpt exact-nonnegative-integer?])]{
Represents a reference to a quoted syntax object via the
@racket[prefix] array. The @racket[depth] field indicates the number
of stack slots to skip to reach the prefix array, and @racket[pos] is
the offset into the array. The @racket[midpt] value is used
internally for lazy calculation of syntax information.}
@defstruct+[(application expr) @defstruct+[(application expr)
([rator (or/c expr? seq? any/c)] ([rator (or/c expr? seq? any/c)]
[rands (listof (or/c expr? seq? any/c))])]{ [rands (listof (or/c expr? seq? any/c))])]{
@ -556,6 +403,12 @@ binding, constructor, etc.}
restored to its depth from before evaluating @racket[key] or restored to its depth from before evaluating @racket[key] or
@racket[val].} @racket[val].}
@defstruct+[(seq expr) ([forms (listof (or/c expr? any/c))])]{
Represents a @racket[begin] form.
After each form in @racket[forms] is evaluated, the stack is restored
to its depth from before evaluating the form.}
@defstruct+[(beg0 expr) ([seq (listof (or/c expr? seq? any/c))])]{ @defstruct+[(beg0 expr) ([seq (listof (or/c expr? seq? any/c))])]{
Represents a @racket[begin0] expression. Represents a @racket[begin0] expression.
@ -567,13 +420,20 @@ binding, constructor, etc.}
expression in the list.} expression in the list.}
@defstruct+[(varref expr) ([toplevel (or/c toplevel? #t)] @defstruct+[(varref expr) ([toplevel (or/c toplevel? #t)]
[dummy (or/c toplevel? #f)])]{ [dummy (or/c toplevel? #f)]
[constant? boolean?]
[from-unsafe? boolean?])]{
Represents a @racket[#%variable-reference] form. The @racket[toplevel] Represents a @racket[#%variable-reference] form. The @racket[toplevel]
field is @racket[#t] if the original reference was to a constant local field is @racket[#t] if the original reference was to a constant local
binding. The @racket[dummy] field binding. The @racket[dummy] field
accesses a variable bucket that strongly references its namespace (as accesses a variable bucket that strongly references its namespace (as
opposed to a normal variable bucket, which only weakly references its opposed to a normal variable bucket, which only weakly references its
namespace); it can be @racket[#f].} namespace); it can be @racket[#f].
The value of @racket[constant?] is true when the @racket[toplevel]
field is not @racket[#t] but the referenced variable is known to be
constant. The value of @racket[from-unsafe?] is true when the module
that created the reference was compiled in unsafe mode.}
@defstruct+[(assign expr) @defstruct+[(assign expr)
([id toplevel?] ([id toplevel?]
@ -616,210 +476,3 @@ binding, constructor, etc.}
Represents a direct reference to a variable imported from the run-time Represents a direct reference to a variable imported from the run-time
kernel.} kernel.}
@; --------------------------------------------------
@section{Syntax Objects}
@defstruct+[(stx-obj zo)
([datum any/c]
[wrap wrap?]
[srcloc (or/c #f srcloc?)]
[props (hash/c symbol? any/c)]
[tamper-status (or/c 'clean 'armed 'tainted)])]{
Represents a syntax object, where @racket[wrap] contains lexical
information, @racket[srcloc] is the source location,
@racket[props] contains preserved properties,
and @racket[tamper-status] is taint information. When the
@racket[datum] part is itself compound, its pieces are wrapped
as @racket[stx-obj]s, too.
The content of @racket[wrap] is typically cyclic, since it includes
scopes that contain bindings that refer to scopes.}
@defstruct+[(wrap zo) ([shifts (listof module-shift?)]
[simple-scopes (listof scope?)]
[multi-scopes (listof (list/c multi-scope? (or/c #f exact-integer?)))])]{
Lexical information for a syntax object. The @racket[shifts] field
allows binding information to be relative to the enclosing module's
run-time path. The @racket[simple-scopes] field records scopes that
are attached to the syntax object at all phases, and @racket[multi-scopes]
records phase-specific scopes (which are always attached as a group)
along with a phase shift for every scope within the group.}
@defstruct+[(module-shift zo) ([from (or/c #f module-path-index?)]
[to (or/c #f module-path-index?)]
[from-inspector-desc (or/c #f symbol?)]
[to-inspector-desc (or/c #f symbol?)])]{
Records a history of module path index replacements. These replacements
are applied in reverse order, and a module instantiation typically adds
one more shift to replace the current ``self'' module path index
with a run-time module path. The @racket[from] and @racket[to]
fields should be both @racket[#f] or both non-@racket[#f].
The @racket[from-inspector-desc] and @racket[to-inspector-desc] fields
similarly should be both @racket[#f] or both non-@racket[#f]. They
record a history of code-inspector replacements.}
@defstruct+[(scope zo) ([name (or/c 'root exact-nonnegative-integer?)]
[kind symbol?]
[bindings (listof (list/c symbol? (listof scope?) binding?)) #;#:mutable]
[bulk-bindings (listof (list/c (listof scope?) all-from-module?)) #;#:mutable]
[multi-owner (or/c #f multi-scope?) #;#:mutable])]{
Represents a scope. When @racket[name] is @racket['root] then the
scope represents the unique all-phases scope that is shared among
non-module namespaces. Otherwise, @racket[name] is intended to be
distinct for each @racket[scope] instance within a module or top-level
compilation, but the @racket[eq?]-identity of the @racket[scope]
instance ultimately determines its identity. The @racket[kind] symbol
similarly acts as a debugging hint in the same way as for
@racket[syntax-debug-info].
The @racket[bindings] list indicates some bindings that are associated
with the scope. Each element of the list includes a symbolic name, a
list of scopes (including the enclosing one), and the binding for the
combination of name and scope set. A given symbol can appear in
multiple elements of @racket[bindings], but the combination of the
symbol and scope set are unique within @racket[bindings] and across
all scopes. The mapping of a symbol and scope set to a binding is
recorded with an arbitrary member of the scope set.
The @racket[bulk-bindings] field lists bindings of all exports from a
given module, which is an optimization over including each export in
@racket[bindings]. Elements of @racket[bindings] take precedence over
elements of @racket[bulk-bindings], and earlier elements of
@racket[bulk-bindings] take precedence over later elements.
If the @racket[scope] represents a scope at a particular phase for a
group of phase-specific scopes, @racket[mark-owner] refers to the
group.}
@defstruct+[(multi-scope zo) ([name exact-nonnegative-integer?]
[src-name any/c]
[scopes (listof (list/c (or/c #f exact-integer?) scope?)) #;#:mutable])]{
Represents a set of phase-specific scopes that are added or removed
from lexical information as a group. As for @racket[scope], the
@racket[name] field is intended to be distinct for different groups,
but the @racket[eq?] identity of the @racket[multi-scope] record
ultimately determines its identity. The @racket[src-name] field
similarly acts as a debugging hint in the same way as for
@racket[syntax-debug-info].
Scopes within the group are instantiated at different phases on
demand. The @racket[scopes] field lists all of the scopes instantiated
for the group, and the phase at which it is instantiated. Each element
of @racket[scopes] must have a @racketidfont{multi-owner} field
value that refers back to the @racket[multi-scope].}
@defstruct+[(binding zo) ()]{
A supertype for all binding representations.}
@defstruct+[(module-binding binding) ([encoded any/c])]{
Represents a binding to a module or top-level definition. The
@racket[encoded] field can be unpacked using
@racket[decode-module-binding], providing the symbol name for which
the binding is the target (since @racket[encoded] can be relative to
that name).}
@defstruct+[(decoded-module-binding binding) ([path (or/c #f module-path-index?)]
[name symbol?]
[phase exact-integer?]
[nominal-path (or/c #f module-path-index?)]
[nominal-export-name symbol?]
[nominal-phase (or/c #f exact-integer?)]
[import-phase (or/c #f exact-integer?)]
[inspector-desc (or/c #f symbol?)])]{
Represents a binding to a module or top-level definition---like
@racket[module-binding], but in normalized form:
@itemlist[
@item{@racket[path]: the referenced module.}
@item{@racket[name]: the referenced definition within its module.}
@item{@racket[phase]: the phase of the referenced definition within
its module.}
@item{@racket[nominal-path]: the module that was explicitly imported
into the binding context; this path can be different from
@racket[path] when a definition is re-exported.}
@item{@racket[nominal-export-name]: the name of the binding as
exported from @racket[nominal-path], which can be different from
@racket[name] due to renaming on export.}
@item{@racket[nominal-phase]: the phase of the export from
@racket[nominal-path], which can be different from @racket[phase]
due to re-export from a module that imports at a phase level other
than @racket[0].}
@item{@racket[import-phase]: the phase of the import of
@racket[nominal-path], which shifted (if non-@racket[0]) the
binding phase relative to the export phase from
@racket[nominal-path].}
@item{@racket[inspector-desc]: a name for an inspector (mapped to a
specific inspector at run time) that determines access to the
definition.}
]}
@defstruct+[(local-binding binding) ([name symbol?])]{
Represents a local binding (i.e., not at the top level or module level).
Such bindings rarely appear in bytecode, since @racket[quote-syntax]
prunes them.}
@defstruct+[(free-id=?-binding binding) ([base (and/c binding?
(not/c free-id=?-binding?))]
[id stx-obj?]
[phase (or/c #f exact-integer?)])]{
Represents a binding that includes a @racket[free-identifier=?] alias
(to an identifier with a particular phase shift) as well as a base binding.}
@defstruct+[(all-from-module zo) ([path module-path-index?]
[phase (or/c exact-integer? #f)]
[src-phase (or/c exact-integer? #f)]
[inspector-desc symbol?]
[exceptions (listof symbol?)]
[prefix (or/c symbol? #f)])]{
Describes a bulk import as an optimization over individual imports of
a module's exports:
@itemlist[
@item{@racket[path]: the imported module.}
@item{@racket[phase]: the phase of the import module's exports.}
@item{@racket[src-phase]: the phase at which @racket[path] was
imported; @racket[src-phase] combined with @racket[phase]
determines the phase of the bindings.}
@item{@racket[inspector-desc]: a name for an inspector (mapped to a
specific inspector at run time) that determines access to the
definition.}
@item{@racket[exceptions]: exports of @racket[path] that are omitted
from the bulk import.}
@item{@racket[prefix]: a prefix, if any, applied (after
@racket[exceptions]) to each of the imported names.}
]}

12
pkgs/racket-doc/scribblings/reference/data.scrbl
View File

@ -119,6 +119,18 @@ For any @racket[v], @racket[(unbox (box v))] returns @racket[v].
Sets the content of @racket[box] to @racket[v].} Sets the content of @racket[box] to @racket[v].}
@deftogether[(
@defproc[(unbox* [box (and box? (not/c impersonator?))]) any/c]
@defproc[(set-box*! [box (and/c box? (not/c immutable?) (not/c impersonator?))]
[v any/c]) void?]
)]{
Like @racket[unbox] and @racket[set-box!], but constrained to work on
boxes that are not @tech{impersonators}.
@history[#:added "6.90.0.15"]}
@defproc[(box-cas! [box (and/c box? (not/c immutable?) (not/c impersonator?))] @defproc[(box-cas! [box (and/c box? (not/c immutable?) (not/c impersonator?))]
[old any/c] [old any/c]
[new any/c]) [new any/c])

7
pkgs/racket-doc/scribblings/reference/eval.scrbl
View File

@ -205,7 +205,12 @@ Like @racket[load], but @racket[load/cd] sets both
handler}.} handler}.}
@defparam[current-load-extension proc (path? (or/c symbol? #f) . -> . any)]{ @defparam[current-load-extension proc (path? (or/c #f
symbol?
(cons/c (or/c #f symbol?)
(non-empty-listof symbol?)))
. -> .
any)]{
A @tech{parameter} that determines a @deftech{extension-load handler}, which is A @tech{parameter} that determines a @deftech{extension-load handler}, which is
called by @racket[load-extension] and the default @tech{compiled-load called by @racket[load-extension] and the default @tech{compiled-load

460
pkgs/racket-doc/scribblings/reference/linklet.scrbl Normal file
View File

@ -0,0 +1,460 @@
#lang scribble/doc
@(require "mz.rkt"
(for-label racket/linklet
racket/unsafe/ops))
@title[#:tag "linklets"]{Linklets and the Core Compiler}
@defmodule[racket/linklet]
A @deftech{linklet} is a primitive element of compilation, bytecode
marshaling, and evaluation. Racket's implementations of modules,
macros, and top-level evaluation are all built on linklets. Racket
programmers generally do not encounter linklets directly, but the
@racketmodname[racket/linklet] library provides access to linklet
facilities.
A single Racket module (or collection of top-level forms) is typically
implemented by multiple linklets. For example, each phase of
evaluation that exists in a module is implemented in a separate
linklet. A linklet is also used for metadata such as the @tech{module
path index}es for a module's @racket[require]s. These linklets, plus
some other metadata, are combined to form a @deftech{linklet bundle}.
Information in a @tech{linklet bundle} is keyed by either a symbol or
a @tech{fixnum}. A @tech{linklet directory} contiaining
@tech{linklet}s can be marshaled to and from a byte stream by
@racket[write] and (with @racket[read-accept-compiled] is enabled)
@racket[read].
When a Racket module has submodules, the @tech{linklet bundles} for
the module and the submodules are grouped together in a
@deftech{linklet directory}. A @tech{linklet directory} can have
nested linklet directories. Information in a linklet directory is
keyed by @racket[#f] or a symbol, where @racket[#f] must be mapped to
a @tech{linklet bundle} (if anything) and each symbol must be mapped
to a @tech{linklet directory}. A @tech{linklet directory} can be
equivalently viewed as a mapping from a lists of symbols to a
@tech{linklet bundle}. Like @tech{linklet bundles}, a @tech{linklet
directory} can be marshaled to and from a byte stream by
@racket[write] and @racket[read]; the marshaled form allows individual
@tech{linklet bundles} to be loaded independently.
A linklet consists of a set of variable definitions and expressions,
an exported subset of the defined variable names, a set of variables to export
from the linklet despite having no corresponding definition, and a set
of imports that provide other variables for the linklet to use. To run
a linklet, it is instantiated as as @deftech{linklet instance} (or
just @defterm{instance}, for short). When a linklet is instantiated,
it receives other @tech{linklet instances} for its imports, and it
extracts a specified set of variables that are exported from each of
the given instances. The newly created @tech{linklet instance}
provides its exported variables for use by other linklets or for
direct access via @racket[instance-variable-value]. A @tech{linklet
instance} can be synthesized directly with @racket[make-instance].
A linklet is created by compiling an enriched S-expression
representation of its source. Since linklets exist below the layer of
macros and syntax objects, linklet compilation does not use
@tech{syntax objects}. Instead, linklet compilation uses
@deftech{correlated objects}, which are like @tech{syntax objects}
without lexical-context information and without the constraint that
content is coerced to correlated objects. Using an S-expression or
@tech{correlated object}, the grammar of a linklet as recognized by
@racket[compile-linklet] is
@specform[(linklet [[imported-id/renamed ...] ...]
[exported-id/renamed ...]
defn-or-expr ...)
#:grammar
([imported-id/renamed imported-id
(external-imported-id internal-imported-id)]
[exported-id/renamed exported-id
(internal-exported-id external-exported-id)])]
Each import set @racket[[_imported-id/renamed ...]] refers to a single
imported instance, and each @racket[_import-id/renamed] corresponds to
a variable from that instance. If separate
@racket[_external-imported-id] and @racket[_internal-imported-id] are
specified, then @racket[_external-imported-id] is the name of the
variable as exported by the instance, and
@racket[_internal-imported-id] is the name used to refer to the
variable in the @racket[_defn-or-expr]s. For exports, separate
@racket[_internal-exported-id] and @racket[_external-exported-id]
names corresponds to the variable name as exported as referenced
in the @racket[_defn-or-expr]s, respectively.
The grammar of an @racket[_defn-or-expr] is similar to the expander's
grammar of fully expanded expressions (see @secref["fully-expanded"])
with some exceptions: @racket[quote-syntax] and @racket[#%top] are not allowed;
@racket[#%plain-lambda] is spelled @racket[lambda];
@racket[#%plain-app] is omitted (i.e., application is implicit);
@racket[lambda], @racket[case-lambda], @racket[let-values], and
@racket[letrec-values] can have only a single body expression; and
numbers, booleans, strings, and byte strings are self-quoting.
Primitives are accessed directly by name, and shadowing is not allowed
within a @racketidfont{linklet} form for primitive names, imported
variables, defined variables, or local variables.
When a @racket[_exported-id/renamed] has no corresponding definition
among the @racket[_defn-or-expr]s, then the variable is effectively
defined as uninitialized; referencing the variable will trigger
@racket[exn:fail:contract:variable], the same as referencing a
variable before it is defined. When a target instance is provided to
@racket[instantiate-linklet], any existing variable with the same name
will be left as-is, instead of set to undefined. This treatment of
uninitialized variables provides core support for top-level evaluation
where variables may be referenced and then defined in a separate
element of compilation.
@history[#:added "6.6.1"]
@; --------------------------------------------------
@defproc[(linklet? [v any/c]) boolean?]{
Returns @racket[#t] if @racket[v] is a @tech{linklet}, @racket[#f]
otherwise.}
@defproc*[([(compile-linklet [form (or/c correlated? any/c)]
[name any/c #f]
[import-keys #f #f]
[get-import #f #f]
[serializable? any/c #t]
[unsafe-mode? any/c #f])
linklet?]
[(compile-linklet [form (or/c correlated? any/c)]
[name any/c]
[import-keys vector?]
[get-import (or/c #f (any/c . -> . (values (or/c linklet? instance? #f)
(or/c vector? #f))))
#f]
[serializable? any/c #t]
[unsafe-mode? any/c #f])
(values linklet? vector?)])]{
Takes an S-expression or @tech{correlated object} for a
@schemeidfont{linklet} form and produces a @tech{linklet}.
As long as @racket[serializable?] is true, the
resulting linklet can be marshaled to and from a byte stream when it is
part of a @tech{linklet bundle}.
The optional @racket[name] is associated to the linklet for debugging
purposes and as the default name of the linklet's instance.
The optional @racket[import-keys] and @racket[get-import] arguments
support cross-linklet optimization. If @racket[import-keys] is a
vector, it must have as many elements as sets of imports in
@racket[form]. If the compiler becomes interested in optimizing a
reference to an imported variable, it passes back to
@racket[get-import] (if non-@racket[#f]) the element of @racket[import-keys] that
corresponds to the variable's import set. The @racket[get-import]
function can then return a linklet or instance that represents an instance to be
provided to the compiled linklet when it is eventually instantiated;
ensuring consistency between reported linklet or instance and the eventual
instance is up to the caller of @racket[compile-linklet]. If
@racket[get-import] returns @racket[#f] as its first value, the
compiler will be prevented from make any assumptions about the
imported instance. The second result from @racket[get-import] is an
optional vector of keys to provide transitive information on a
returned linklet's imports (and is not allowed for a returned instance);
the returned vector must have the same
number of elements as the linklet has imports. When vector elements
are @racket[eq?] and non-@racket[#f], the compiler can assume that
they correspond to the same run-time instance. A @racket[#f]
value for @racket[get-import] is equivalent to a function that
always returns two @racket[#f] results.
When @racket[import-keys] is not @racket[#f], then the compiler is
allowed to grow or shrink the set of imported instances for the
linklet. The result vector specifies the keys of the imports for the
returned linklet. Any key that is @racket[#f] or a @tech{linklet instance}
must be preserved intact, however.
If @racket[unsafe-mode?] is true, then the linklet is compiled in
@deftech{unsafe mode}: uses of safe operations within the linklet can
be converted to unsafe operations on the assumption that the relevant
contracts are satisfied. For example, @racket[car] is converted to
@racket[unsafe-car]. Some substituted unsafe operations may not have
directly accessible names, such as the unsafe variant of
@racket[in-list] that can be substituted in @tech{unsafe mode}. An
unsafe operation is substituted only if its (unchecked) contract is
subsumed by the safe operation's contract. The fact that the linklet
is compiled in @tech{unsafe mode} can be exposed through
@racket[variable-reference-from-unsafe?] using a variable reference
produced by a @racket[#%variable-reference] form within the module
body.}
@defproc*[([(recompile-linklet [linklet linklet?]
[name any/c #f]
[import-keys #f #f]
[get-import (any/c . -> . (values (or/c linklet? #f)
(or/c vector? #f)))
(lambda (import-key) (values #f #f))])
linklet?]
[(recompile-linklet [linklet linklet?]
[name any/c]
[import-keys vector?]
[get-import (any/c . -> . (values (or/c linklet? #f)
(or/c vector? #f)))
(lambda (import-key) (values #f #f))])
(values linklet? vector?)])]{
Like @racket[compile-linklet], but takes an already-compiled linklet
and potentially optimizes it further.}
@defproc[(eval-linklet [linklet linklet?]) linklet?]{
Returns a variant of a @racket[linklet] that is prepared for JIT
compilation such that every later use of the result linklet with
@racket[instantiate-linklet] shares the JIT-generated code. However,
the result of @racket[eval-linklet] cannot be marshaled to a byte
stream as part of a @tech{linklet bundle}, and it cannot be used with
@racket[recompile-linklet].}
@defproc*[([(instantiate-linklet [linklet linklet?]
[import-instances (listof instance?)]
[target-instance? #f #f]
[use-prompt? any/c #t])
instance?]
[(instantiate-linklet [linklet linklet?]
[import-instances (listof instance?)]
[target-instance instance?]
[use-prompt? any/c #t])
any])]{
Instantiates @racket[linklet] by running its definitions and
expressions, using the given @racket[import-instances] for its
imports. The number of instances in @racket[import-instances] must
match the number of import sets in @racket[linklet].
If @racket[target-instance] is @racket[#f] or not provided, the result
is a fresh instance for the linklet. If @racket[target-instance] is an
instance, then the instance is used and modified for the linklet
definitions and expressions, and the result is the value of the last
expression in the linklet.
The linklet's exported variables are accessible in the result instance
or in @racket[target-instance] using the linklet's external name for
each export. If @racket[target-instance] is provided as
non-@racket[#f], its existing variables remain intact if they are not
modified by a linklet definition.
If @racket[use-prompt?] is true, then the evaluation each definition
and expression in the linklet is wrapped in a @tech{prompt} in the
same ways as an expression in a module body.}
@defproc[(linklet-import-variables [linklet linklet?])
(listof (listof symbol?))]{
Returns a description of a linklet's imports. Each element of the
result list corresponds to an import set as satisfied by a single
instance on instantiation, and each member of the set is a variable
name that is used from the corresponding imported instance.}
@defproc[(linklet-export-variables [linklet linklet?])
(listof symbol?)]{
Returns a description of a linklet's exports. Each element of the list
corresponds to a variable that is made available by the linklet in its
instance.}
@defproc[(linklet-directory? [v any/c]) boolean?]{
Returns @racket[#t] if @racket[v] is a @tech{linklet directory},
@racket[#f] otherwise.}
@defproc[(hash->linklet-directory [content (and/c hash? hash-eq? immutable? (not/c impersonator?))])
linklet-directory?]{
Constructs a @tech{linklet directory} given mappings in the form of a
@tech{hash table}. Each key of @racket[content] must be either a
symbol or @racket[#f], each symbol must be mapped to a @tech{linklet
directory}, and @racket[#f] must be mapped to a @tech{linklet bundle}
or not mapped.}
@defproc[(linklet-directory->hash [linklet-directory linklet-directory?])
(and/c hash? hash-eq? immutable? (not/c impersonator?))]{
Extracts the content of a @tech{linklet directory} into a @tech{hash
table}.}
@defproc[(linklet-bundle? [v any/c]) boolean?]{
Returns @racket[#t] if @racket[v] is a @tech{linklet bundle},
@racket[#f] otherwise.}
@defproc[(hash->linklet-bundle [content (and/c hash? hash-eq? immutable? (not/c impersonator?))])
linklet-bundle?]{
Constructs a @tech{linklet bundle} given mappings in the form of a
@tech{hash table}. Each key of @racket[content] must be either a
symbol or a @tech{fixnum}. Values in the hash table are unconstrained,
but the intent is that they are all @tech{linklets} or values that can
be recovered from @racket[write] output by @racket[read].}
@defproc[(linklet-bundle->hash [linklet-bundle linklet-bundle?])
(and/c hash? hash-eq? immutable? (not/c impersonator?))]{
Extracts the content of a @tech{linklet bundle} into a @tech{hash
table}.}
@defproc[(instance? [v any/c]) boolean?]{
Returns @racket[#t] if @racket[v] is a @tech{linklet instance},
@racket[#f] otherwise.}
@defproc[(make-instance [name any/c]
[data any/c #f]
[mode (or/c #f 'constant 'consistent) #f]
[variable-name symbol?]
[variable-value any/c] ... ...)
instance?]{
Constructs a @tech{linklet instance} directly. Besides associating an
arbitrary @racket[name] and @racket[data] value to the instance, the
instance is populated with variables as specified by
@racket[variable-name] and @racket[variable-value].
The optional @racket[data] and @racket[mode] arguments must be
provided if any @racket[variable-name] and @racket[variable-value]
arguments are provided. The @racket[mode] argument is used as in
@racket[instance-set-variable-value!] for every
@racket[variable-name].}
@defproc[(instance-name [instance instance?]) any/c]{
Returns the value associated to @racket[instance] as its name---either
the first value provided to @racket[make-instance] or the name of a
linklet that was instantiated to create the instance.}
@defproc[(instance-data [instance instance?]) any/c]{
Returns the value associated to @racket[instance] as its data---either
the second value provided to @racket[make-instance] or the default
@racket[#f].}
@defproc[(instance-variable-names [instance instance?]) (list symbol?)]{
Returns a list of all names for all variables accessible from
@racket[instance].}
@defproc[(instance-variable-value [instance instance?]
[name symbol?]
[fail-k any/c (lambda () (error ....))])
any]{
Returns the value of the variable exported as @racket[name] from
@racket[instance]. If no such variable is exported, then
@racket[fail-k] is used in the same way as by @racket[hash-ref].}
@defproc[(instance-set-variable-value! [instance instance?]
[name symbol?]
[v any/c]
[mode (or/c #f 'constant 'consistent) #f])
void?]{
Sets or creates the variable exported as @racket[name] in
@racket[instance] so that its value is @racket[v], as long as the
variable does not exist already as constant. If a variable for
@racket[name] exists as constant, the @exnraise[exn:fail:contract].
If @racket[mode] is a single, then the variable is created or changed
to be constant. If @racket[mode] is @racket['consistent], then
the optimizer can assume that the value has the same shape in all
instances that are used to satisfy a linklet's imports.}
@defproc[(instance-unset-variable! [instance instance?]
[name symbol?])
void?]{
Changes @racket[instance] so taht it does not export a variable as
@racket[name], as long as @racket[name] does not exist as a constant
variable. If a variable for @racket[name] exists as constant, the
@exnraise[exn:fail:contract].}
@defproc[(variable-reference->instance [varref variable-reference?]
[ref-site? any/c #f])
(if ref-site? (or/c instance? #f symbol?) instance?)]{
Extracts the instance where the variable of @racket[varref] is defined
if @var[ref-site?] is @racket[#f], and returns the instance where
@racket[varref] itself resides if @racket[ref-site?] is true. This
notion of @tech{variable reference} is the same as at the module level
and can reflect the linklet instance that implements a particular
phase of a module instance.
When @var[ref-site?] is @racket[#f], the result is @racket[#f] when
@racket[varref] is from @racket[(#%variable-reference)] with no
identifier. The result is a symbol if @racket[varref] refers to a
primitive.}
@deftogether[(
@defproc[(correlated? [v any/c]) boolean?]
@defproc[(correlated-source [stx correlated?]) any]
@defproc[(correlated-line [stx correlated?])
(or/c exact-positive-integer? #f)]
@defproc[(correlated-column [stx correlated?])
(or/c exact-nonnegative-integer? #f)]
@defproc[(correlated-position [stx correlated?])
(or/c exact-positive-integer? #f)]
@defproc[(correlated-span [stx correlated?])
(or/c exact-nonnegative-integer? #f)]
@defproc[(correlated-e [stx correlated?]) any]
@defproc[(correlated->datum [stx (or/c correlated? any/c)]) any]
@defproc[(datum->correlated [v any/c]
[srcloc (or/c correlated? #f
(list/c any/c
(or/c exact-positive-integer? #f)
(or/c exact-nonnegative-integer? #f)
(or/c exact-positive-integer? #f)
(or/c exact-nonnegative-integer? #f))
(vector/c any/c
(or/c exact-positive-integer? #f)
(or/c exact-nonnegative-integer? #f)
(or/c exact-positive-integer? #f)
(or/c exact-nonnegative-integer? #f)))
#f])
correlated?]
@defproc*[([(correlated-property [stx correlated?]
[key any/c]
[val any/c])
correlated?]
[(correlated-property [stx correlated?] [key any/c]) any/c])]
@defproc[(correlated-property-symbol-keys [stx correlated?]) list?]
)]{
Like @racket[syntax?], @racket[syntax-source], @racket[syntax-line],
@racket[syntax-column], @racket[syntax-position],
@racket[syntax-span], @racket[syntax-e], @racket[syntax->datum],
@racket[datum->syntax], @racket[syntax-property], and
@racket[syntax-property-symbol-keys], but for @tech{correlated
objects}.
Unlike @racket[datum->syntax], @racket[datum->correlated] does not
recur through the given S-expression and convert pieces to
@tech{correlated objects}. Instead, a @tech{correlated object} is
simply wrapped around the immediate value. In contrast,
@racket[correlated->datum] recurs through its argument (which is not
necessarily a @tech{correlated object}) to discover any
@tech{correlated objects} and convert them to plain S-expressions.}

4
pkgs/racket-doc/scribblings/reference/memory.scrbl
View File

@ -193,7 +193,9 @@ call. If no will is ready for immediate execution,
@defproc[(will-try-execute [executor any/c]) any]{ @defproc[(will-try-execute [executor any/c]) any]{
Like @racket[will-execute] if a will is ready for immediate Like @racket[will-execute] if a will is ready for immediate
execution. Otherwise, @racket[#f] is returned.} execution. Otherwise, @racket[v] is returned.
@history[#:changed "6.90.0.4" @elem{Added the @racket[v] argument.}]}
@;------------------------------------------------------------------------ @;------------------------------------------------------------------------
@section[#:tag "garbagecollection"]{Garbage Collection} @section[#:tag "garbagecollection"]{Garbage Collection}

22
pkgs/racket-doc/scribblings/reference/namespaces.scrbl
View File

@ -170,7 +170,8 @@ exception.}
@defproc[(namespace-set-variable-value! [sym symbol?] @defproc[(namespace-set-variable-value! [sym symbol?]
[v any/c] [v any/c]
[map? any/c #f] [map? any/c #f]
[namespace namespace? (current-namespace)]) [namespace namespace? (current-namespace)]
[as-constant? any/c #f])
void?]{ void?]{
Sets the value of @racket[sym] in the top-level environment of Sets the value of @racket[sym] in the top-level environment of
@ -180,7 +181,13 @@ it is not already defined.
If @racket[map?] is supplied as true, then the namespace's If @racket[map?] is supplied as true, then the namespace's
@tech{identifier} mapping is also adjusted (see @tech{identifier} mapping is also adjusted (see
@secref["namespace-model"]) in the @tech{phase level} corresponding to @secref["namespace-model"]) in the @tech{phase level} corresponding to
the @tech{base phase}, so that @racket[sym] maps to the variable.} the @tech{base phase}, so that @racket[sym] maps to the variable.
If @racket[as-constant?] is true, then the variable is made a constant
(so future assignments are rejected) after @racket[v] is installed as
the value.
@history[#:changed "6.6.1" @elem{Added the @racket[as-constant?] argument.}]}
@defproc[(namespace-undefine-variable! [sym symbol?] @defproc[(namespace-undefine-variable! [sym symbol?]
@ -502,8 +509,7 @@ an anonymous module variable as produced by
Returns @racket[#t] if the module of the variable reference itself Returns @racket[#t] if the module of the variable reference itself
(not necessarily a referenced variable) is compiled in unsafe mode, (not necessarily a referenced variable) is compiled in unsafe mode,
@racket[#f] otherwise. Since unsafe-mode compilation is not currently @racket[#f] otherwise.
supported, the result is always @racket[#f].
The @racket[variable-reference-from-unsafe?] procedure is intended for The @racket[variable-reference-from-unsafe?] procedure is intended for
use as use as
@ -512,6 +518,12 @@ use as
(variable-reference-from-unsafe? (#%variable-reference)) (variable-reference-from-unsafe? (#%variable-reference))
] ]
which the compiler can currently optimize to a literal @racket[#f]. which the compiler can optimize to a literal @racket[#t] or
@racket[#f] (since the enclosing module is being compiled in
@tech{unsafe mode} or not).
Currently @tech{unsafe mode} can be controlled only through the
@tech{linklet} interface, but future changes may make @tech{unsafe
mode} more accessible at the module level.
@history[#:added "6.12.0.4"]} @history[#:added "6.12.0.4"]}

10
pkgs/racket-doc/scribblings/reference/readtables.scrbl
View File

@ -150,7 +150,7 @@ already-consumed character(s): the source name, a line number or
@racket[#f]. When the reader macro is triggered by @racket[read] (or @racket[#f]. When the reader macro is triggered by @racket[read] (or
@racket[read/recursive]), the procedure is passed only two arguments @racket[read/recursive]), the procedure is passed only two arguments
if it accepts two arguments, otherwise it is passed six arguments if it accepts two arguments, otherwise it is passed six arguments
where the last four are all @racket[#f]. See @secref["reader-procs"] where the third is always @racket[#f]. See @secref["reader-procs"]
for information on the procedure's results. for information on the procedure's results.
A reader macro normally reads characters from the given input port to A reader macro normally reads characters from the given input port to
@ -264,7 +264,7 @@ character and the @racket[#f] readtable.}
((if (eof-object? v) ((if (eof-object? v)
raise-read-eof-error raise-read-eof-error
raise-read-error) raise-read-error)
"expected `,' or `>'" src l c p 1)]))])) "expected `,` or `>`" src l c p 1)]))]))
(define (make-delims-table) (define (make-delims-table)
;; Table to use for recursive reads to disallow delimiters ;; Table to use for recursive reads to disallow delimiters
@ -274,7 +274,7 @@ character and the @racket[#f] readtable.}
[(ch port) (misplaced-delimiter ch port #f #f #f #f)] [(ch port) (misplaced-delimiter ch port #f #f #f #f)]
[(ch port src line col pos) [(ch port src line col pos)
(raise-read-error (raise-read-error
(format "misplaced `~a' in tuple" ch) (format "misplaced `~a` in tuple" ch)
src line col pos 1)])]) src line col pos 1)])])
(make-readtable (current-readtable) (make-readtable (current-readtable)
#\, 'terminating-macro misplaced-delimiter #\, 'terminating-macro misplaced-delimiter
@ -286,14 +286,14 @@ character and the @racket[#f] readtable.}
(define parse-open-tuple (define parse-open-tuple
(case-lambda (case-lambda
[(ch port) [(ch port)
;; `read' mode ;; `read` mode
(wrap (parse port (wrap (parse port
(lambda () (lambda ()
(read/recursive port #f (read/recursive port #f
(make-delims-table))) (make-delims-table)))
(object-name port)))] (object-name port)))]
[(ch port src line col pos) [(ch port src line col pos)
;; `read-syntax' mode ;; `read-syntax` mode
(datum->syntax (datum->syntax
#f #f
(wrap (parse port (wrap (parse port

8
pkgs/racket-doc/scribblings/reference/runtime.scrbl
View File

@ -27,18 +27,20 @@ In @indexed-racket['word] mode, the result is either @racket[32] or
or 64-bit program. or 64-bit program.
In @indexed-racket['vm] mode, In @indexed-racket['vm] mode,
the only possible symbol result is: the possible symbol results are:
@itemize[ @itemize[
@item{@indexed-racket['racket]} @item{@indexed-racket['racket]}
@item{@indexed-racket['chez-scheme]}
] ]
In @indexed-racket['gc] mode, In @indexed-racket['gc] mode,
the possible symbol results are: the possible symbol results are:
@itemize[ @itemize[
@item{@indexed-racket['cgc]} @item{@indexed-racket['cgc] --- when @racket[(system-type 'vm)] is @racket['racket]}
@item{@indexed-racket['3m]} @item{@indexed-racket['3m] --- when @racket[(system-type 'vm)] is @racket['racket]}
@item{@indexed-racket['cs] --- when @racket[(system-type 'vm)] is @racket['chez-scheme]}
] ]
In @indexed-racket['link] mode, the possible symbol results are: In @indexed-racket['link] mode, the possible symbol results are:

1
pkgs/racket-doc/scribblings/reference/security.scrbl
View File

@ -18,3 +18,4 @@
@include-section["code-inspectors.scrbl"] @include-section["code-inspectors.scrbl"]
@include-section["plumbers.scrbl"] @include-section["plumbers.scrbl"]
@include-section["sandbox.scrbl"] @include-section["sandbox.scrbl"]
@include-section["linklet.scrbl"]

31
pkgs/racket-doc/scribblings/reference/stx-trans.scrbl
View File

@ -269,7 +269,10 @@ recursively (i.e., expansion proceeds to sub-expressions).
If @racket[stop-ids] is @racket[#f] If @racket[stop-ids] is @racket[#f]
instead of a list, then @racket[stx] is expanded only as long as the instead of a list, then @racket[stx] is expanded only as long as the
outermost form of @racket[stx] is a macro (i.e., expansion does not outermost form of @racket[stx] is a macro (i.e., expansion does not
proceed to sub-expressions). proceed to sub-expressions). Independent of @racket[stop-ids], when
@racket[local-expand] encounters an identifier that has a local binding
but no binding in the current expansion context, the variable is left
as-is (as opposed to triggering an ``out of context'' syntax error).
A fully expanded form can include the A fully expanded form can include the
bindings listed in @secref["fully-expanded"] plus the bindings listed in @secref["fully-expanded"] plus the
@ -346,23 +349,31 @@ expansion history to external tools.
an explicit wrapper.}]} an explicit wrapper.}]}
@defproc[(syntax-local-expand-expression [stx any/c]) @defproc[(syntax-local-expand-expression [stx any/c] [opaque-only? #f])
(values syntax? syntax?)]{ (values (if opaque-only? #f syntax?) syntax?)]{
Like @racket[local-expand] given @racket['expression] and an empty Like @racket[local-expand] given @racket['expression] and an empty
stop list, but with two results: a syntax object for the fully stop list, but with two results: a syntax object for the fully
expanded expression, and a syntax object whose content is opaque. The expanded expression, and a syntax object whose content is opaque.
latter can be used in place of the former (perhaps in a larger
The latter can be used in place of the former (perhaps in a larger
expression produced by a macro transformer), and when the macro expression produced by a macro transformer), and when the macro
expander encounters the opaque object, it substitutes the fully expander encounters the opaque object, it substitutes the fully
expanded expression without re-expanding it; the expanded expression without re-expanding it; the
@exnraise[exn:fail:syntax] if the expansion context includes @exnraise[exn:fail:syntax] if the expansion context includes
@tech{scopes} that were not present for the original expansion, in which @tech{scopes} that were not present for the original expansion, in
case re-expansion might produce different results. Consistent use of which case re-expansion might produce different results. Consistent
@racket[syntax-local-expand-expression] and the opaque object thus use of @racket[syntax-local-expand-expression] and the opaque object
avoids quadratic expansion times when local expansions are nested. thus avoids quadratic expansion times when local expansions are
nested.
@transform-time[]} If @racket[opaque-only?] is true, then the first result is @racket[#f]
instead of the expanded expression. Obtaining only the second, opaque
result can be more efficient in some expansion contexts.
@transform-time[]
@history[#:changed "6.90.0.13" @elem{Added the @racket[opaque-only?] argument.}]}
@defproc[(local-transformer-expand [stx any/c] @defproc[(local-transformer-expand [stx any/c]

1
pkgs/racket-doc/scribblings/reference/unsafe.scrbl
View File

@ -655,6 +655,7 @@ fixnum).}
@history[#:added "6.9.0.2"] @history[#:added "6.9.0.2"]
} }
@; ------------------------------------------------------------------------ @; ------------------------------------------------------------------------
@include-section["unsafe-undefined.scrbl"] @include-section["unsafe-undefined.scrbl"]

17
pkgs/racket-doc/scribblings/reference/vectors.scrbl
View File

@ -72,6 +72,23 @@ slot is position @racket[0], and the last slot is one less than
Updates the slot @racket[pos] of @racket[vec] to contain @racket[v].} Updates the slot @racket[pos] of @racket[vec] to contain @racket[v].}
@deftogether[(
@defproc[(vector*-length [vec (and/c vector? (not/c impersonator?))]) exact-nonnegative-integer?]
@defproc[(vector*-ref [vec (and/c vector? (not/c impersonator?))] [pos exact-nonnegative-integer?]) any/c]
@defproc[(vector*-set! [vec (and/c vector? (not/c immutable?) (not/c impersonator?))]
[pos exact-nonnegative-integer?]
[v any/c])
void?]
)]{
Like @racket[vector-length], @racket[vector-ref], and
@racket[vector-set!], but constrained to work on vectors that are not
@tech{impersonators}.
@history[#:added "6.90.0.15"]}
@defproc[(vector-cas! [vec (and/c vector? (not/c immutable?) (not/c impersonator?))] @defproc[(vector-cas! [vec (and/c vector? (not/c immutable?) (not/c impersonator?))]
[pos exact-nonnegative-integer?] [pos exact-nonnegative-integer?]
[old-v any/c] [old-v any/c]

25
pkgs/racket-doc/syntax/scribblings/modcode.scrbl
View File

@ -7,7 +7,7 @@
@defproc[(get-module-code [path path-string?] @defproc[(get-module-code [path path-string?]
[#:submodule-path submodule-path (listof symbol?) '()] [#:submodule-path submodule-path (listof symbol?) '()]
[#:sub-path compiled-subdir0 (and/c path-string? relative-path?) "compiled"] [#:sub-path compiled-subdir0 (and/c path-string? relative-path?) (get-default-compiled-sub-path)]
[compiled-subdir (and/c path-string? relative-path?) compiled-subdir0] [compiled-subdir (and/c path-string? relative-path?) compiled-subdir0]
[#:roots roots (listof (or/c path-string? 'same)) (current-compiled-file-roots)] [#:roots roots (listof (or/c path-string? 'same)) (current-compiled-file-roots)]
[#:compile compile-proc0 (any/c . -> . any) compile] [#:compile compile-proc0 (any/c . -> . any) compile]
@ -31,7 +31,7 @@ specified by @racket[path] and @racket[submodule-path], where
@racket[submodule-path] is empty for a root module or a list for a @racket[submodule-path] is empty for a root module or a list for a
submodule. submodule.
The @racket[compiled-subdir] argument defaults to @racket["compiled"]; The @racket[compiled-subdir] argument defaults to @racket[(get-default-compiled-sub-path)];
it specifies the sub-directory to search for a compiled version of the it specifies the sub-directory to search for a compiled version of the
module. The @racket[roots] list specifies a compiled-file search path module. The @racket[roots] list specifies a compiled-file search path
in the same way as the @racket[current-compiled-file-roots] parameter. in the same way as the @racket[current-compiled-file-roots] parameter.
@ -77,11 +77,14 @@ If @racket[notify-proc] is supplied, it is called for the file
(source, @filepath{.zo} or extension) that is chosen. (source, @filepath{.zo} or extension) that is chosen.
If @racket[read-syntax-proc] is provided, it is used to read the If @racket[read-syntax-proc] is provided, it is used to read the
module from a source file (but not from a bytecode file).} module from a source file (but not from a bytecode file).
@history[#:changed "6.90.0.7" @elem{Use @racket[(get-default-compiled-sub-path)]
for the default value of @racket[compiled-subdir].}]}
@defproc[(get-module-path [path path-string?] @defproc[(get-module-path [path path-string?]
[#:submodule? submodule? boolean?] [#:submodule? submodule? boolean?]
[#:sub-path compiled-subdir0 (and/c path-string? relative-path?) "compiled"] [#:sub-path compiled-subdir0 (and/c path-string? relative-path?) (get-default-compiled-sub-path)]
[compiled-subdir (and/c path-string? relative-path?) compiled-subdir0] [compiled-subdir (and/c path-string? relative-path?) compiled-subdir0]
[#:roots roots (listof (or/c path-string? 'same)) (current-compiled-file-roots)] [#:roots roots (listof (or/c path-string? 'same)) (current-compiled-file-roots)]
[#:choose choose-proc [#:choose choose-proc
@ -107,7 +110,18 @@ The @racket[submodule?] argument represents whether the desired module is a
submodule of the one specified by @racket[path]. When @racket[submodule?] is submodule of the one specified by @racket[path]. When @racket[submodule?] is
true, the result is never a @racket['so] path, as native libraries cannot true, the result is never a @racket['so] path, as native libraries cannot
provide submodules. provide submodules.
}
@history[#:changed "6.90.0.7" @elem{Use @racket[(get-default-compiled-sub-path)]
for the default value of @racket[compiled-subdir].}]}
@defproc[(get-default-compiled-sub-path) path-string?]{
If @racket[(use-compiled-file-paths)] is not @racket['()], returns the
first element of the list. Otherwise, results @racket["compiled"].
@history[#:added "6.90.0.7"]}
@defproc[(get-metadata-path [path path-string?] @defproc[(get-metadata-path [path path-string?]
[#:roots roots (listof (or/c path-string? 'same)) [#:roots roots (listof (or/c path-string? 'same))
@ -131,7 +145,6 @@ file for @filepath{/path/to/source.rkt} might be stored in
A parameter whose value is used like @racket[open-input-file] to read A parameter whose value is used like @racket[open-input-file] to read
a module source or @filepath{.zo} file.} a module source or @filepath{.zo} file.}
@defstruct[(exn:get-module-code exn:fail) ([path path?])]{ @defstruct[(exn:get-module-code exn:fail) ([path path?])]{
An exception structure type for exceptions raised by An exception structure type for exceptions raised by

16
pkgs/racket-test-core/tests/racket/basic.rktl
View File

@ -227,7 +227,7 @@
(box-tests make-weak-box weak-box-value weak-box? #f #f 'weak-box-value #t) (box-tests make-weak-box weak-box-value weak-box? #f #f 'weak-box-value #t)
;; test clearing weak boxes ;; test clearing weak boxes
(when (eq? '3m (system-type 'gc)) (unless (eq? 'cgc (system-type 'gc))
(let* ([s (gensym)] (let* ([s (gensym)]
[b (make-weak-box s)]) [b (make-weak-box s)])
(test s weak-box-value b) (test s weak-box-value b)
@ -2898,17 +2898,21 @@
(cons 1 (loop (sub1 i)))))) (cons 1 (loop (sub1 i))))))
exn:fail:contract?))) exn:fail:contract?)))
not-inc))) not-inc)))
(list proc (procedure-reduce-arity proc ar))))]) (list proc (procedure-reduce-arity proc ar))))]
[representable-arity? (lambda (a)
(or (not (eq? 'chez-scheme (system-type 'vm)))
(a . < . 4096)))])
(let ([check-all-but-one (let ([check-all-but-one
(lambda (+) (lambda (+)
(check-ok + 0 '(0) '(1)) (check-ok + 0 '(0) '(1))
(check-ok + 2 '(2) '(0 1 3 4)) (check-ok + 2 '(2) '(0 1 3 4))
(check-ok + 10 '(10) (list 0 11 (expt 2 70))) (check-ok + 10 '(10) (filter representable-arity? (list 0 11 (expt 2 70))))
(check-ok + (expt 2 70) (list (expt 2 70)) (list 0 10 (add1 (expt 2 70)))) (when (representable-arity? (expt 2 70))
(check-ok + (make-arity-at-least 2) (list 2 5 (expt 2 70)) (list 0 1)) (check-ok + (expt 2 70) (list (expt 2 70)) (filter representable-arity? (list 0 10 (add1 (expt 2 70))))))
(check-ok + (make-arity-at-least 2) (filter representable-arity? (list 2 5 (expt 2 70))) (list 0 1))
(check-ok + (list 2 4) '(2 4) '(0 3)) (check-ok + (list 2 4) '(2 4) '(0 3))
(check-ok + (list 2 4) '(4 2) '(0 3)) (check-ok + (list 2 4) '(4 2) '(0 3))
(check-ok + (list 0 (make-arity-at-least 2)) (list 0 2 5 (expt 2 70)) (list 1)) (check-ok + (list 0 (make-arity-at-least 2)) (filter representable-arity? (list 0 2 5 (expt 2 70))) (list 1))
(check-ok + (list 4 (make-arity-at-least 2)) '(2 3 4 10) '(0 1)) (check-ok + (list 4 (make-arity-at-least 2)) '(2 3 4 10) '(0 1))
(check-ok + (list 2 (make-arity-at-least 4)) '(2 4 10) '(0 1 3)))]) (check-ok + (list 2 (make-arity-at-least 4)) '(2 4 10) '(0 1 3)))])
(check-all-but-one +) (check-all-but-one +)

2
pkgs/racket-test-core/tests/racket/chaperone.rktl
View File

@ -1922,7 +1922,7 @@
(set! access-k k) (set! access-k k)
k))] k))]
[test (lambda (val proc . args) [test (lambda (val proc . args)
;; Avoid printign hash-table argument, which implicitly uses `ref': ;; Avoid printing hash-table argument, which implicitly uses `ref':
(let ([got (apply proc args)]) (let ([got (apply proc args)])
(test #t (format "~s ~s ~s" proc val got) (equal? val got))))]) (test #t (format "~s ~s ~s" proc val got) (equal? val got))))])
(test #f hash-iterate-first h1) (test #f hash-iterate-first h1)

1
pkgs/racket-test-core/tests/racket/core-tests.rktl
View File

@ -27,6 +27,7 @@
(load-relative "prompt.rktl") (load-relative "prompt.rktl")
(load-relative "will.rktl") (load-relative "will.rktl")
(load-relative "namespac.rktl") (load-relative "namespac.rktl")
(load-relative "expobs.rktl")
(load-relative "collects.rktl") (load-relative "collects.rktl")
(load-relative "modprot.rktl") (load-relative "modprot.rktl")
(load-relative "chaperone.rktl") (load-relative "chaperone.rktl")

9851
pkgs/racket-test-core/tests/racket/expobs-regression.rktd Normal file
View File

File diff suppressed because it is too large Load Diff

185
pkgs/racket-test-core/tests/racket/expobs.rktl Normal file
View File

@ -0,0 +1,185 @@
(load-relative "loadtest.rktl")
(Section 'expobs)
(require '#%expobs)
(define generate-expobs-regression? #f)
(define checking-against-old-expander? #f)
(define expobs-traces-path
(build-path (current-load-relative-directory)
"expobs-regression.rktd"))
(define (get-trace e)
(struct stx-boundary (v) #:prefab)
(define (stx-essence s)
(define syms (make-hasheq))
(define (stx-essence s)
(cond
[(syntax? s)
(if checking-against-old-expander?
(stx-essence (syntax->datum s))
;; We care about the outer countour of pairs versus syntax objects,
;; but not the interior details:
(stx-boundary (stx-essence (syntax->datum s))))]
[(pair? s) (cons (stx-essence (car s))
(stx-essence (cdr s)))]
[(symbol? s) (or (hash-ref syms s #f)
(let ([new-s (string->symbol (format "s~a" (hash-count syms)))])
(hash-set! syms s new-s)
new-s))]
[(or (number? s) (boolean? s) (keyword? s) (null? s)) s]
[else '#:opaque]))
(stx-essence s))
(define trace '())
(parameterize ([current-expand-observe (lambda (num args)
(set! trace (cons (cons num (stx-essence args)) trace)))])
(with-handlers ([exn:fail:syntax? void]) ; syntax error ok: check trace up to error
(expand (if (and (pair? e) (eq? 'module (car e)))
e
`(#%expression ,e)))))
(let ([l (reverse trace)])
l))
;; ----------------------------------------
(when generate-expobs-regression?
(define new-expected-traces (make-hash))
(define (generate-trace e)
(hash-set! new-expected-traces e (get-trace e)))
(for-each generate-trace
'((#%top . __x)
__x
(#%plain-app 1 2)
(quote-syntax (stx-quoted))
(quote quoted)
(set! __x 99)
(letrec-values ([(x) __y] [(y z) __w]) __x)
(let-values ([(x) __y] [(y z) __w]) __x)
(begin 1 __x (+ 3 4))
(case-lambda [(x) x] [(x y) (+ x y)])
(#%variable-reference __z)
(begin0 '3 '5)
(with-continuation-mark __x __y __z)
(if 1 2 3)
(lambda (x)
(define y (+ x x))
y)
(let ()
(define (ok x) '8)
(ok 5))
(let ()
(define (ok x) '8)
(define (second y) (ok y))
(second 5))
(let ()
(define (ok x) (second x))
(define (second y) 8)
(ok 5))
(let ()
(define (first z) z)
(define (ok x) (second x))
(printf "extra expression\n")
(define (second y) 8)
(ok (first 5)))
(#%stratified-body
(define (first z) z)
(define (ok x) (second x))
(define (second y) 8)
(ok (first 5)))
(#%stratified-body
(define (first z) z)
(define (ok x) (second x))
(define (second y) 8)
(ok (first 5))
;; syntax error:
(define more 'oops))
(let ()
(define-syntax (ok stx) (quote-syntax 8))
(ok 5))
(let ()
(define-syntax (ok stx) (quote-syntax 8))
(define-syntax (second stx) (quote-syntax (ok 6)))
(second 5))
(let ()
(define-syntax (ok stx) (quote-syntax 8))
(define (ident x) x)
9)
(let ()
(define-syntax (ok stx) (quote-syntax 8))
(define-syntax (second stx) (quote-syntax (ok 6)))
(define (ident x) x)
(define (second-ident y) y)
(ident (second-ident (second))))
(let ()
(define-syntax-rule (ok x) x)
(ok 5))
(let ()
(define-syntax (ok stx)
(local-expand (cadr (syntax-e stx)) 'expression #f))
(ok 9))
(let ()
(define-syntax (ok stx)
(define-values (exp opaque)
(syntax-local-expand-expression (cadr (syntax-e stx))))
opaque)
(#%expression (ok 9)))
(let ()
(define-syntax (lift stx)
(syntax-local-lift-expression #'(+ 1 2)))
(lift))
(let ()
(define-syntax (lift stx)
(syntax-local-lift-require 'racket/list #'foldl))
(lift))
(module m '#%kernel
5)
(module m racket/base
'done)
(module m racket/base
(define (proc x) x)
(provide proc))
(module m racket/base
(define-syntax (ok stx) (quote-syntax 8))
(ok)
(list (ok) (ok)))
(module m racket/base
(require racket/list)
foldl)
(module m racket/base
(define-syntax (ok stx)
(syntax-local-lift-require 'racket/list #'foldl))
(ok))
))
(call-with-output-file expobs-traces-path
#:exists 'truncate
(lambda (o)
((dynamic-require 'racket/pretty 'pretty-write) new-expected-traces o))))
;; ----------------------------------------
(define expected-traces
(call-with-input-file expobs-traces-path read))
(define (trace-equal? t1 t2)
(unless (= (length t1) (length t2))
(printf "trace lengths differ\n"))
(for ([v1 (in-list t1)]
[v2 (in-list t2)]
[i (in-naturals)])
(unless (equal? v1 v2)
(printf "different at ~a: ~s ~s\n" i v1 v2)))
(equal? t1 t2))
(for ([(e trace) (in-hash expected-traces)])
(test #t `(trace ,e) (trace-equal? (get-trace e) trace)))
;; ----------------------------------------
(report-errs)

90
pkgs/racket-test-core/tests/racket/foreign-test.rktl
View File

@ -18,7 +18,8 @@
(test #f malloc 0 _int) (test #f malloc 0 _int)
(test #f malloc _int 0) (test #f malloc _int 0)
(test 0 bytes-length (make-sized-byte-string #f 0)) (unless (eq? 'cs (system-type 'gc))
(test 0 bytes-length (make-sized-byte-string #f 0)))
;; Check integer-range checking: ;; Check integer-range checking:
(let () (let ()
@ -323,9 +324,10 @@
(set-box! b #f))) (set-box! b #f)))
;; --- ;; ---
;; test exposing internal mzscheme functionality ;; test exposing internal mzscheme functionality
(test '(1 2) (when (eq? 'racket (system-type 'vm))
(get-ffi-obj 'scheme_make_pair #f (_fun _scheme _scheme -> _scheme)) (test '(1 2)
1 '(2)) (get-ffi-obj 'scheme_make_pair #f (_fun _scheme _scheme -> _scheme))
1 '(2)))
;; --- ;; ---
;; test arrays ;; test arrays
(let ([p (malloc _c7_list)]) ;; should allocate the right size (let ([p (malloc _c7_list)]) ;; should allocate the right size
@ -573,7 +575,7 @@
(test 'hello hash-ref ht seventeen3 #f))) (test 'hello hash-ref ht seventeen3 #f)))
;; Check proper handling of offsets: ;; Check proper handling of offsets:
(let () (when (eq? 'racket (system-type 'vm))
(define scheme_make_sized_byte_string (define scheme_make_sized_byte_string
(get-ffi-obj 'scheme_make_sized_byte_string #f (_fun _pointer _intptr _int -> _scheme))) (get-ffi-obj 'scheme_make_sized_byte_string #f (_fun _pointer _intptr _int -> _scheme)))
;; Non-gcable: ;; Non-gcable:
@ -605,7 +607,7 @@
(define _stuff-pointer (_cpointer 'stuff)) (define _stuff-pointer (_cpointer 'stuff))
(define p (cast (ptr-add (malloc 10) 5) _pointer _thing-pointer)) (define p (cast (ptr-add (malloc 10) 5) _pointer _thing-pointer))
(cpointer-gcable? p) (test #t cpointer-gcable? p)
(define q (cast p _thing-pointer _stuff-pointer)) (define q (cast p _thing-pointer _stuff-pointer))
(test (cast p _pointer _intptr) (test (cast p _pointer _intptr)
cast q _pointer _intptr) cast q _pointer _intptr)
@ -647,7 +649,7 @@
(define ENOENT 2) (define ENOENT 2)
(define ERANGE 34) (define ERANGE 34)
(define _getcwd ;; sets errno = ERANGE if path longer than buffer (define _getcwd ;; sets errno = ERANGE if path longer than buffer
(get-ffi-obj '_getcwd msvcrt (_fun #:save-errno 'posix _bytes _int -> _void))) (get-ffi-obj '_getcwd msvcrt (_fun #:save-errno 'posix _bytes/nul-terminated _int -> _void)))
(define _chdir ;; sets errno = ENOENT if path doesn't exist (define _chdir ;; sets errno = ENOENT if path doesn't exist
(get-ffi-obj '_chdir msvcrt (_fun #:save-errno 'posix _string -> _int))) (get-ffi-obj '_chdir msvcrt (_fun #:save-errno 'posix _string -> _int)))
(define (bad/ERANGE) (_getcwd (make-bytes 1) 1)) (define (bad/ERANGE) (_getcwd (make-bytes 1) 1))
@ -664,7 +666,7 @@
(delete-test-files) (delete-test-files)
(let () (when (eq? 'racket (system-type 'vm))
(define _values (get-ffi-obj 'scheme_values #f (_fun _int (_list i _racket) -> _racket))) (define _values (get-ffi-obj 'scheme_values #f (_fun _int (_list i _racket) -> _racket)))
(test-values '(1 "b" three) (lambda () (_values 3 (list 1 "b" 'three))))) (test-values '(1 "b" three) (lambda () (_values 3 (list 1 "b" 'three)))))
@ -679,8 +681,9 @@
(test 4.4t0 extflvector-ref v 2) (test 4.4t0 extflvector-ref v 2)
(test 2.2t0 ptr-ref (ptr-add (extflvector->cpointer v) (ctype-sizeof _longdouble)) _longdouble)) (test 2.2t0 ptr-ref (ptr-add (extflvector->cpointer v) (ctype-sizeof _longdouble)) _longdouble))
;; Check a corner of UTF-16 conversion: (when (eq? 'racket (system-type 'vm))
(test "\U171D3" cast (cast "\U171D3" _string/utf-16 _gcpointer) _gcpointer _string/utf-16) ;; Check a corner of UTF-16 conversion:
(test "\U171D3" cast (cast "\U171D3" _string/utf-16 _gcpointer) _gcpointer _string/utf-16))
;; check async: ;; check async:
(when test-async? (when test-async?
@ -1000,6 +1003,8 @@
;; --- inplace tests ;; --- inplace tests
(define can-in-place? (not (eq? 'chez-scheme (system-type 'vm))))
(define-serializable-cstruct _NOIN ([a _int])) (define-serializable-cstruct _NOIN ([a _int]))
(define-serializable-cstruct _INS ([a _int]) #:serialize-inplace) (define-serializable-cstruct _INS ([a _int]) #:serialize-inplace)
@ -1008,7 +1013,7 @@
(define-serializable-cstruct _INSD ([a _int]) (define-serializable-cstruct _INSD ([a _int])
#:serialize-inplace #:deserialize-inplace #:serialize-inplace #:deserialize-inplace
#:malloc-mode (if (eq? 'racket (system-type 'vm)) #:malloc-mode (if can-in-place?
(lambda (_) (error "should not get here")) (lambda (_) (error "should not get here"))
malloc/register)) malloc/register))
@ -1041,7 +1046,7 @@
;; modified ;; modified
(set-INS-a! ins 456) (set-INS-a! ins 456)
(define ds2 (deserialize s)) (define ds2 (deserialize s))
(check-equal? 456 (INS-a ds2))) (check-equal? (if can-in-place? 456 123) (INS-a ds2)))
;; inplace deser ;; inplace deser
(let () (let ()
@ -1208,44 +1213,45 @@
;; ---------------------------------------- ;; ----------------------------------------
(define scheme_make_type (when (eq? 'racket (system-type 'vm))
(get-ffi-obj 'scheme_make_type #f (_fun _string -> _short))) (define scheme_make_type
(define scheme_register_type_gc_shape (get-ffi-obj 'scheme_make_type #f (_fun _string -> _short)))
(get-ffi-obj 'scheme_register_type_gc_shape #f (_fun _short (_list i _intptr) -> _void))) (define scheme_register_type_gc_shape
(get-ffi-obj 'scheme_register_type_gc_shape #f (_fun _short (_list i _intptr) -> _void)))
(define SHAPE_STR_TERM 0) (define SHAPE_STR_TERM 0)
(define SHAPE_STR_PTR_OFFSET 1) (define SHAPE_STR_PTR_OFFSET 1)
(define-cstruct _tagged ([type-tag _short] (define-cstruct _tagged ([type-tag _short]
[obj1 _racket] [obj1 _racket]
[non2 _intptr] [non2 _intptr]
[obj3 _racket] [obj3 _racket]
[non4 _intptr]) [non4 _intptr])
#:define-unsafe #:define-unsafe
#:malloc-mode 'tagged) #:malloc-mode 'tagged)
(test #t cpointer-predicate-procedure? tagged?) (test #t cpointer-predicate-procedure? tagged?)
(define t (scheme_make_type "new-type")) (define t (scheme_make_type "new-type"))
(scheme_register_type_gc_shape t (list SHAPE_STR_PTR_OFFSET tagged-obj1-offset (scheme_register_type_gc_shape t (list SHAPE_STR_PTR_OFFSET tagged-obj1-offset
SHAPE_STR_PTR_OFFSET tagged-obj3-offset SHAPE_STR_PTR_OFFSET tagged-obj3-offset
SHAPE_STR_TERM)) SHAPE_STR_TERM))
(define obj1 (make-string 10)) (define obj1 (make-string 10))
(define obj2 (make-bytes 12)) (define obj2 (make-bytes 12))
(define obj3 (make-bytes 14)) (define obj3 (make-bytes 14))
(define obj4 (make-string 16)) (define obj4 (make-string 16))
(define obj2-addr (cast obj2 _racket _intptr)) (define obj2-addr (cast obj2 _racket _intptr))
(define obj4-addr (cast obj4 _racket _intptr)) (define obj4-addr (cast obj4 _racket _intptr))
(define o (make-tagged t obj1 obj2-addr obj3 obj4-addr)) (define o (make-tagged t obj1 obj2-addr obj3 obj4-addr))
(collect-garbage) (collect-garbage)
(eq? (tagged-obj1 o) obj1) (eq? (tagged-obj1 o) obj1)
(eq? (tagged-obj3 o) obj3) (eq? (tagged-obj3 o) obj3)
(= (tagged-non2 o) obj2-addr) (= (tagged-non2 o) obj2-addr)
(= (tagged-non4 o) obj4-addr) (= (tagged-non4 o) obj4-addr))
;; ---------------------------------------- ;; ----------------------------------------

28
pkgs/racket-test-core/tests/racket/jitinline.rktl
View File

@ -47,7 +47,9 @@
thing? rock? stone? thing? rock? stone?
continuation-mark-set-first)) continuation-mark-set-first))
(let ([s (with-handlers ([exn? exn-message]) (let ([s (with-handlers ([exn? exn-message])
(let ([bad bad-value]) (let ([bad (if (eq? bad-value 'unsafe-undefined)
unsafe-undefined
bad-value)])
(cond (cond
[first-arg (proc first-arg bad)] [first-arg (proc first-arg bad)]
[second-arg (proc bad second-arg)] [second-arg (proc bad second-arg)]
@ -702,8 +704,14 @@
(bin-exact 'b 'vector-ref #(a b c) 1) (bin-exact 'b 'vector-ref #(a b c) 1)
(bin-exact 'c 'vector-ref #(a b c) 2) (bin-exact 'c 'vector-ref #(a b c) 2)
(bin-exact 'a 'vector*-ref #(a b c) 0 #t)
(bin-exact 'b 'vector*-ref #(a b c) 1)
(bin-exact 'c 'vector*-ref #(a b c) 2)
(un-exact 'a 'unbox (box 'a) #t) (un-exact 'a 'unbox (box 'a) #t)
(un-exact 'a 'unbox* (box 'a) #t)
(un-exact 3 'vector-length (vector 'a 'b 'c) #t) (un-exact 3 'vector-length (vector 'a 'b 'c) #t)
(un-exact 3 'vector*-length (vector 'a 'b 'c) #t)
(bin-exact 1.1 'flvector-ref (flvector 1.1 2.2 3.3) 0 #t) (bin-exact 1.1 'flvector-ref (flvector 1.1 2.2 3.3) 0 #t)
(bin-exact 3.3 'flvector-ref (flvector 1.1 2.2 3.3) 2) (bin-exact 3.3 'flvector-ref (flvector 1.1 2.2 3.3) 2)
@ -837,7 +845,7 @@
(bin-exact 3.3t0 'extflvector-ref (extflvector 1.1t0 2.2t0 3.3t0) 2) (bin-exact 3.3t0 'extflvector-ref (extflvector 1.1t0 2.2t0 3.3t0) 2)
(un-exact 3 'extflvector-length (extflvector 1.1t0 2.2t0 3.3t0) #t) (un-exact 3 'extflvector-length (extflvector 1.1t0 2.2t0 3.3t0) #t)
(bin-exact 5 'check-not-unsafe-undefined 5 'check-not-unsafe-undefined #:bad-value unsafe-undefined) (bin-exact 5 'check-not-unsafe-undefined 5 'check-not-unsafe-undefined #:bad-value 'unsafe-undefined)
) )
(let ([test-setter (let ([test-setter
@ -857,6 +865,7 @@
3rd-all-ok?)) 3rd-all-ok?))
'(0 1 2))))]) '(0 1 2))))])
(test-setter make-vector #f 7 'vector-set! vector-set! vector-ref #t) (test-setter make-vector #f 7 'vector-set! vector-set! vector-ref #t)
(test-setter make-vector #f 7 'vector*-set! vector*-set! vector*-ref #t)
(test-setter make-bytes 0 7 'bytes-set! bytes-set! bytes-ref #f) (test-setter make-bytes 0 7 'bytes-set! bytes-set! bytes-ref #f)
(test-setter make-string #\a #\7 'string-set! string-set! string-ref #f) (test-setter make-string #\a #\7 'string-set! string-set! string-ref #f)
(test-setter make-flvector 1.0 7.0 'flvector-set! flvector-set! flvector-ref #f) (test-setter make-flvector 1.0 7.0 'flvector-set! flvector-set! flvector-ref #f)
@ -869,14 +878,29 @@
(test-setter (lambda (n v) (chap-vec (chap-vec (make-vector n v)))) (test-setter (lambda (n v) (chap-vec (chap-vec (make-vector n v))))
#f 7 'vector-set! vector-set! vector-ref #t))) #f 7 'vector-set! vector-set! vector-ref #t)))
(err/rt-test (apply (list-ref (list (lambda (v) (vector*-length v))) (random 1))
(list (chaperone-vector (vector 1 2 3) (lambda (vec i val) val) (lambda (vec i val) val)))))
(err/rt-test (apply (list-ref (list (lambda (v) (vector*-ref v 0))) (random 1))
(list (chaperone-vector (vector 1 2 3) (lambda (vec i val) val) (lambda (vec i val) val)))))
(err/rt-test (apply (list-ref (list (lambda (v) (unbox* v))) (random 1))
(list (chaperone-box (box 1) (lambda (b v) v) (lambda (b v) v)))))
(err/rt-test (apply (list-ref (list (lambda (v) (vector-set! v 0 #t))) (random 1)) (err/rt-test (apply (list-ref (list (lambda (v) (vector-set! v 0 #t))) (random 1))
(list (vector-immutable 1 2 3)))) (list (vector-immutable 1 2 3))))
(err/rt-test (apply (list-ref (list (lambda (v) (vector*-set! v 0 #t))) (random 1))
(list (vector-immutable 1 2 3))))
(err/rt-test (apply (list-ref (list (lambda (v) (vector*-set! v 0 #t))) (random 1))
(list (chaperone-vector (vector 1 2 3) (lambda (vec i val) val) (lambda (vec i val) val)))))
(err/rt-test (apply (list-ref (list (lambda (s) (string-set! s 0 #\a))) (random 1)) (err/rt-test (apply (list-ref (list (lambda (s) (string-set! s 0 #\a))) (random 1))
(list "123"))) (list "123")))
(err/rt-test (apply (list-ref (list (lambda (s) (bytes-set! s 0 0))) (random 1)) (err/rt-test (apply (list-ref (list (lambda (s) (bytes-set! s 0 0))) (random 1))
(list #"123"))) (list #"123")))
(err/rt-test (apply (list-ref (list (lambda (b) (set-box! b #t))) (random 1)) (err/rt-test (apply (list-ref (list (lambda (b) (set-box! b #t))) (random 1))
(list (box-immutable 1)))) (list (box-immutable 1))))
(err/rt-test (apply (list-ref (list (lambda (b) (set-box*! b #t))) (random 1))
(list (box-immutable 1))))
(err/rt-test (apply (list-ref (list (lambda (v) (set-box*! v 'no))) (random 1))
(list (chaperone-box (box 1) (lambda (b v) v) (lambda (b v) v)))))
(let ([v (box 1)]) (let ([v (box 1)])
(check-error-message 'set-box! (eval `(lambda (x) (set-box! x 10)))) (check-error-message 'set-box! (eval `(lambda (x) (set-box! x 10))))

125
pkgs/racket-test-core/tests/racket/macro.rktl
View File

@ -1675,6 +1675,95 @@
(test '(1 2 3) dynamic-require ''uses-local-lift-values-at-expansion-time 'l) (test '(1 2 3) dynamic-require ''uses-local-lift-values-at-expansion-time 'l)
;; ----------------------------------------
;; Check that `local-expand` tentatively allows out-of-context identifiers
(module tentatively-out-of-context racket/base
(require (for-syntax racket/base))
(define-syntax (new-lam stx)
(syntax-case stx ()
[(_ x body)
(with-syntax ([(_ (x+) body+)
(local-expand #'(lambda (x) body) 'expression null)])
(with-syntax ([body++ ;; double-expand body
(local-expand #'body+ 'expression null)])
#'(lambda (x+) body++)))]))
((new-lam X X) 100))
;; ----------------------------------------
;; Check that properties interact properly with the rename transformer
;; that is used to implement `let-syntax` [example from Stephen Chang]
(define-syntax (test-key-property-as-val stx)
(syntax-case stx ()
[(_ x)
(with-syntax ([x/prop (syntax-property #'x 'key 'val)])
(with-syntax ([(lam _ (lv1 _ (lv2 _ x+)))
(local-expand
#'(lambda (x)
(let-syntax ([x (lambda (stx) #'x)])
x/prop))
'expression null)])
#`'#,(syntax-property #'x+ 'key)))]))
(test 'val 'let-syntax-rename-transformer-property (test-key-property-as-val stx))
;; ----------------------------------------
;; Check that a chain of rename transformers maintains properties correctly
(module chains-properties-through-two-rename-transformer racket/base
(require (for-syntax racket/base))
(define a 'a)
(define-syntax b (make-rename-transformer (syntax-property #'a 'ids 'b)))
(define-syntax c (make-rename-transformer (syntax-property #'b 'ids 'c)))
(define-syntax (inspect stx)
(syntax-case stx ()
[(_ e)
(let ([e (local-expand #'e 'expression null)])
#`(quote #,(syntax-property e 'ids)))]))
(provide prop-val)
(define prop-val (inspect c)))
(test '(b . c) dynamic-require ''chains-properties-through-two-rename-transformer 'prop-val)
;; ----------------------------------------
;; Check that the wrong properties are *not* added when a rename transformer is involed
(module inner-and-outer-properties-around-rename-transformers racket/base
(require (for-syntax racket/base))
(define-syntax (some-define stx)
(syntax-case stx ()
[(_ x)
#'(define-syntax x
(make-rename-transformer
(syntax-property #'void 'prop 'inner)))]))
(some-define x)
(define-syntax (wrapper stx)
(syntax-case stx ()
[(_ e)
(local-expand
(syntax-property #'e 'prop 'outer)
'expression null)]))
(define-syntax (#%app stx)
(syntax-case stx ()
[(_ f)
#`(quote #,(syntax-property #'f 'prop))]))
(provide prop-val)
(define prop-val (wrapper (x))))
(test 'inner dynamic-require ''inner-and-outer-properties-around-rename-transformers 'prop-val)
;; ---------------------------------------- ;; ----------------------------------------
;; Check that a `prop:rename-transformer` procedure is called in a ;; Check that a `prop:rename-transformer` procedure is called in a
;; `syntax-transforming?` mode when used as an expression ;; `syntax-transforming?` mode when used as an expression
@ -1707,6 +1796,13 @@
(ax))]) (ax))])
(test 'two values also-x))) (test 'two values also-x)))
;; ----------------------------------------
;; Make sure top-level definition replaces a macro binding
(define-syntax-rule (something-previously-bound-as-syntax) 1)
(define something-previously-bound-as-syntax 5)
(test 5 values something-previously-bound-as-syntax)
;; ---------------------------------------- ;; ----------------------------------------
;; Check that ellipsis-counts errors are reported when a single ;; Check that ellipsis-counts errors are reported when a single
;; pattern variable is used at different depths ;; pattern variable is used at different depths
@ -1716,6 +1812,35 @@
#'([(b (b ...)) ...] ...))) #'([(b (b ...)) ...] ...)))
(lambda (exn) (regexp-match? #rx"incompatible ellipsis" (exn-message exn)))) (lambda (exn) (regexp-match? #rx"incompatible ellipsis" (exn-message exn))))
;; ----------------------------------------
;; Check `local-expand` for a `#%module-begin` that
;; routes `require`s through a macro (which involves use-site
;; scopes)
(module module-begin-check/mb racket/base
(require (for-syntax racket/base))
(provide (except-out (all-from-out racket/base)
#%module-begin)
(rename-out [mb #%module-begin]))
(define-syntax (mb stx)
(syntax-case stx ()
[(_ f ... last)
(local-expand #'(#%module-begin f ... last)
'module-begin
(list #'module*))])))
(module module-begin-check/y racket/base
(provide y)
(define y 'y))
(module x 'module-begin-check/mb
(define-syntax-rule (req mod ...)
(require mod ...))
(req 'module-begin-check/y)
(void y))
;; ---------------------------------------- ;; ----------------------------------------
;; Check that expansion to `#%module-begin` is prepared to handle ;; Check that expansion to `#%module-begin` is prepared to handle
;; definition contexts ;; definition contexts

87
pkgs/racket-test-core/tests/racket/modprot.rktl
View File

@ -212,45 +212,10 @@
(#%require '#%unsafe) (#%require '#%unsafe)
(display unsafe-car))) (display unsafe-car)))
(require compiler/zo-structs (require (only-in racket/unsafe/ops unsafe-car)
compiler/zo-marshal) compiler/zo-structs
compiler/zo-marshal
(define unsafe-synth-zo (only-in '#%linklet primitive->compiled-position))
(let ([bstr
(zo-marshal
(compilation-top
10
#hash()
(prefix 0
(list 'dummy)
null
'insp0)
(mod 'unsafe
'unsafe
(module-path-index-join #f #f)
(prefix 0
(list (module-variable (module-path-index-join ''#%unsafe #f)
'unsafe-car
-1
0
#f))
null
'insp0)
null
null
null ; body
null
null
0
(toplevel 0 0 #f #f)
#f
#f
#hash()
null
null
null)))])
(parameterize ([read-accept-compiled #t])
(read (open-input-bytes bstr)))))
;; - - - - - - - - - - - - - - - - - - - - ;; - - - - - - - - - - - - - - - - - - - -
@ -268,7 +233,10 @@
(define (mp-try-all zero one two/no-protect two/protect (define (mp-try-all zero one two/no-protect two/protect
three/nabbed three/pnabbed three/snabbed three/nfnabbed three/nfpnabbed three/nfsnabbed three/nabbed three/pnabbed three/snabbed three/nfnabbed three/nfpnabbed three/nfsnabbed
three/normal three/normal
get-one-inspector get-three-inspector fail-pnab? fail-prot? fail-three? np-ok? fail-three-comp?) get-one-inspector get-three-inspector fail-pnab? fail-prot? fail-three? np-ok? fail-three-comp?
#:via-2-ok? [via-2-ok? #f]
#:unprot-ok? [unprot-ok? #f]
#:early-ok? [early-ok? #f])
(let ([try (let ([try
(lambda (two three v fail-three?) (lambda (two three v fail-three?)
(let ([ns (make-base-namespace)] (let ([ns (make-base-namespace)]
@ -291,17 +259,17 @@
(test #t regexp-match? (test #t regexp-match?
(if (byte-regexp? v) v (byte-regexp (string->bytes/utf-8 (format "~a\n" v)))) (if (byte-regexp? v) v (byte-regexp (string->bytes/utf-8 (format "~a\n" v))))
(get-output-bytes p))))]) (get-output-bytes p))))])
(try two/no-protect three/nabbed (if fail-prot? #rx#"unexported .* unexp" #rx#"one .5.") fail-three?) (try two/no-protect three/nabbed (if (and fail-prot? (not early-ok?)) #rx#"unexported" #rx#"one .5.") fail-three?)
(try two/no-protect three/nfnabbed (if (and fail-prot? (not np-ok?)) #rx#"unexported .* unexp" #rx#"two .5.") fail-three?) (try two/no-protect three/nfnabbed (if (and fail-prot? (not np-ok?) (not unprot-ok?)) #rx#"unexported .* unexp" #rx#"two .5.") fail-three?)
(try two/no-protect three/pnabbed (if fail-pnab? #rx#"protected .* prot" #rx#"zero .8.") fail-three?) (try two/no-protect three/pnabbed (if (and fail-pnab? (not early-ok?)) #rx#"protected" #rx#"zero .8.") fail-three?)
(try two/no-protect three/nfpnabbed (if (and fail-pnab? (not np-ok?)) #rx#"protected .* prot" #rx#"two .8.") (or fail-three? fail-three-comp?)) (try two/no-protect three/nfpnabbed (if (and fail-pnab? (not np-ok?) (not unprot-ok?)) #rx#"protected .* prot" #rx#"two .8.") (or fail-three? fail-three-comp?))
(try two/no-protect three/snabbed (if (and fail-prot? np-ok?) #rx#"unexported .* stx" #rx#"one .13.") fail-three?) (try two/no-protect three/snabbed (if (and fail-prot? (not np-ok?) (not via-2-ok?) (not early-ok?)) #rx#"unexported .* stx" #rx#"one .13.") fail-three?)
(try two/no-protect three/nfsnabbed #rx#"two .13." fail-three?) (try two/no-protect three/nfsnabbed #rx#"two .13." fail-three?)
(try two/no-protect three/normal #rx#"two .10." fail-three?) (try two/no-protect three/normal #rx#"two .10." fail-three?)
(try two/protect three/nabbed (if fail-prot? #rx#"unexported .* unexp" #rx#"one .5.") fail-three?) (try two/protect three/nabbed (if fail-prot? #rx#"unexported" #rx#"one .5.") fail-three?)
(try two/protect three/pnabbed (if fail-pnab? #rx#"protected .* prot" #rx#"zero .8.") fail-three?) (try two/protect three/pnabbed (if fail-pnab? #rx#"protected" #rx#"zero .8.") fail-three?)
(try two/protect three/snabbed (if (and fail-prot? np-ok?) #rx#"unexported .* stx" #rx#"one .13.") fail-three?) (try two/protect three/snabbed (if (and fail-prot? (not np-ok?) (not via-2-ok?)) #rx#"unexported .* stx" #rx#"one .13.") fail-three?)
(try two/protect three/normal (if fail-prot? #rx#"protected .* normal" #rx#"two .10.") fail-three?))) (try two/protect three/normal (if fail-prot? #rx#"protected" #rx#"two .10.") fail-three?)))
(define (unsafe-try unsafe get-inspector unsafe-fail? unsafe-ref-fail? read-fail?) (define (unsafe-try unsafe get-inspector unsafe-fail? unsafe-ref-fail? read-fail?)
(let ([ns (make-base-namespace)] (let ([ns (make-base-namespace)]
@ -408,26 +376,26 @@
three/normal-zo three/normal-zo
make-inspector current-code-inspector #t #f #f #f #t) make-inspector current-code-inspector #t #f #f #f #t)
(unsafe-try unsafe-zo make-inspector #f #f #t) (unsafe-try unsafe-zo make-inspector #f #f #t)
(unsafe-try unsafe-synth-zo make-inspector #f #t #f)
(displayln "zo and source, second:") (displayln "source and zo, change inspector:")
(mp-try-all zero one two/no-protect two/protect (mp-try-all zero one two/no-protect two/protect
three/nabbed three/pnabbed three/snabbed-zo three/nfnabbed three/nfpnabbed three/nfsnabbed-zo three/nabbed three/pnabbed three/snabbed-zo three/nfnabbed three/nfpnabbed three/nfsnabbed-zo
three/normal three/normal
make-inspector current-code-inspector #t #f #t #f #t) current-code-inspector make-inspector #t #t #t #t #t
#:early-ok? #t)
(unsafe-try unsafe make-inspector #t #t #f) (unsafe-try unsafe make-inspector #t #t #f)
(displayln "zo and source, third:") (displayln "zo, change inspector:")
(mp-try-all zero-zo one-zo two/no-protect-zo two/protect-zo (mp-try-all zero-zo one-zo two/no-protect-zo two/protect-zo
three/nabbed-zo three/pnabbed-zo three/snabbed-zo three/nfnabbed-zo three/nfpnabbed-zo three/nfsnabbed-zo three/nabbed-zo three/pnabbed-zo three/snabbed-zo three/nfnabbed-zo three/nfpnabbed-zo three/nfsnabbed-zo
three/normal-zo three/normal-zo
current-code-inspector make-inspector #t #t #f #f #f) make-inspector make-inspector #t #t #f #f #f #:via-2-ok? #t)
(displayln "just source, weaken inspector:") (displayln "just source, weaken inspector:")
(mp-try-all zero one two/no-protect two/protect (mp-try-all zero one two/no-protect two/protect
three/nabbed three/pnabbed three/snabbed three/nfnabbed three/nfpnabbed three/nfsnabbed three/nabbed three/pnabbed three/snabbed three/nfnabbed three/nfpnabbed three/nfsnabbed
three/normal three/normal
current-code-inspector make-inspector #t #t #t #t #f) current-code-inspector make-inspector #t #t #t #f #f #:unprot-ok? #t #:early-ok? #t)
;; ---------------------------------------- ;; ----------------------------------------
@ -450,4 +418,13 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(parameterize ([current-namespace (make-base-namespace)]
[current-code-inspector (make-inspector)])
(eval
;; This compilation is intended to inline a call to `gen-for-each`,
;; and the test is meant to ensure that the reference is allowed
(compile '(lambda (f) (for-each f '(1 2 3 4 5))))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(report-errs) (report-errs)

251
pkgs/racket-test-core/tests/racket/module.rktl
View File

@ -118,14 +118,14 @@
(syntax-test #'(module m racket/base (#%require (all-except n . n)))) (syntax-test #'(module m racket/base (#%require (all-except n . n))))
(syntax-test #'(module m racket/base (#%require (rename)))) (syntax-test #'(module m racket/base (#%require (rename))))
(syntax-test #'(module m racket/base (#%require (rename . n)))) (syntax-test #'(module m racket/base (#%require (rename . n))))
(syntax-test #'(module m racket/base (#%require (rename n)))) (syntax-test #'(module m racket/base (#%require (rename 'n))))
(syntax-test #'(module m racket/base (#%require (rename n . n)))) (syntax-test #'(module m racket/base (#%require (rename 'n . n))))
(syntax-test #'(module m racket/base (#%require (rename n n)))) (syntax-test #'(module m racket/base (#%require (rename 'n n))))
(syntax-test #'(module m racket/base (#%require (rename n n . m)))) (syntax-test #'(module m racket/base (#%require (rename 'n n . m))))
(syntax-test #'(module m racket/base (#%require (rename n 1 m)))) (syntax-test #'(module m racket/base (#%require (rename 'n 1 m))))
(syntax-test #'(module m racket/base (#%require (rename n n 1)))) (syntax-test #'(module m racket/base (#%require (rename 'n n 1))))
(syntax-test #'(module m racket/base (#%require (rename n n not-there)))) (syntax-test #'(module m racket/base (#%require (rename 'n n not-there))))
(syntax-test #'(module m racket/base (#%require (rename n n m extra)))) (syntax-test #'(module m racket/base (#%require (rename 'n n m extra))))
(syntax-test #'(module m racket/base (define x 6) (define x 5))) (syntax-test #'(module m racket/base (define x 6) (define x 5)))
(syntax-test #'(module m racket/base (define x 10) (define-syntax x 10))) (syntax-test #'(module m racket/base (define x 10) (define-syntax x 10)))
@ -971,7 +971,7 @@
(define b-s (compile-m b-expr (list a-s))) (define b-s (compile-m b-expr (list a-s)))
(define temp-dir (find-system-path 'temp-dir)) (define temp-dir (find-system-path 'temp-dir))
(define dir (build-path temp-dir "compiled")) (define dir (build-path temp-dir (car (use-compiled-file-paths))))
(define dir-existed? (directory-exists? dir)) (define dir-existed? (directory-exists? dir))
(unless dir-existed? (make-directory dir)) (unless dir-existed? (make-directory dir))
@ -1132,7 +1132,7 @@
'(rename-out [z x]) '(rename-out [z x])
"x" "x"
;; slow: ;; slow:
"exp\nexp\nrun\nexp\nexp\n"))]) "exp\nexp\nrun\nexp\n"))])
(define ns (make-base-namespace)) (define ns (make-base-namespace))
(define o (open-output-string)) (define o (open-output-string))
(parameterize ([current-output-port o]) (parameterize ([current-output-port o])
@ -1279,7 +1279,7 @@ case of module-leve bindings; it doesn't cover local bindings.
(define vlen (bytes-ref s (+ start 2))) (define vlen (bytes-ref s (+ start 2)))
(define mode (integer->char (bytes-ref s (+ start 3 vlen)))) (define mode (integer->char (bytes-ref s (+ start 3 vlen))))
(case mode (case mode
[(#\T) [(#\B)
(define h (make-bytes 20 (+ 42 c))) (define h (make-bytes 20 (+ 42 c)))
(bytes-copy! s (+ start 4 vlen) h)] (bytes-copy! s (+ start 4 vlen) h)]
[(#\D) [(#\D)
@ -1303,8 +1303,8 @@ case of module-leve bindings; it doesn't cover local bindings.
(module s racket/base (module s racket/base
(provide x) (provide x)
(define x 1))))) (define x 1)))))
(make-directory* (build-path dir "compiled")) (make-directory* (build-path dir (car (use-compiled-file-paths))))
(define zo-path (build-path dir "compiled" "tmx_rkt.zo")) (define zo-path (build-path dir (car (use-compiled-file-paths)) "tmx_rkt.zo"))
(define bstr (define bstr
(let ([b (open-output-bytes)]) (let ([b (open-output-bytes)])
@ -1335,8 +1335,8 @@ case of module-leve bindings; it doesn't cover local bindings.
(define e (compile '(module tmx2 racket/kernel (define e (compile '(module tmx2 racket/kernel
(#%provide x) (#%provide x)
(define-values (x) 1)))) (define-values (x) 1))))
(make-directory* (build-path dir "compiled")) (make-directory* (build-path dir (car (use-compiled-file-paths))))
(define zo-path (build-path dir "compiled" "tmx2_rkt.zo")) (define zo-path (build-path dir (car (use-compiled-file-paths)) "tmx2_rkt.zo"))
(define bstr (define bstr
(let ([b (open-output-bytes)]) (let ([b (open-output-bytes)])
@ -1478,6 +1478,46 @@ case of module-leve bindings; it doesn't cover local bindings.
(test 11 dynamic-require ''module-lift-example-3 'out) (test 11 dynamic-require ''module-lift-example-3 'out)
(module module-lift-example-4 racket/base
(require (for-syntax racket/base))
(define-syntax (main stx)
(syntax-case stx ()
[(_ body ...)
(syntax-local-lift-module #`(module* main #f (main-method)))
#'(define (main-method)
body ...)]))
(provide out)
(define out #f)
(main (set! out 12)))
(test (void) dynamic-require '(submod 'module-lift-example-4 main) #f)
(test 12 dynamic-require ''module-lift-example-4 'out)
(module module-lift-example-5 racket/base
(module a racket/base
(require (for-syntax racket/base))
(provide main)
(define-syntax (main stx)
(syntax-case stx ()
[(_ body ...)
(syntax-local-lift-module #`(module* main #f (main-method)))
#'(define (main-method)
body ...)])))
(module b racket/base
(require (submod ".." a))
(provide out)
(define out #f)
(main (set! out 13))))
(test (void) dynamic-require '(submod 'module-lift-example-5 b main) #f)
(test 13 dynamic-require '(submod 'module-lift-example-5 b) 'out)
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Check addition of 'disappeared-use by `provide` ;; Check addition of 'disappeared-use by `provide`
@ -1677,23 +1717,23 @@ case of module-leve bindings; it doesn't cover local bindings.
(define tmp (make-temporary-file "~a-module-test" 'directory)) (define tmp (make-temporary-file "~a-module-test" 'directory))
(parameterize ([current-directory tmp] (parameterize ([current-directory tmp]
[current-load-relative-directory tmp]) [current-load-relative-directory tmp])
(make-directory "compiled") (make-directory* (car (use-compiled-file-paths)))
(call-with-output-file* (call-with-output-file*
"compiled/a_rkt.zo" (build-path (car (use-compiled-file-paths)) "a_rkt.zo")
(lambda (o) (write (compile '(module a racket/base (lambda (o) (write (compile '(module a racket/base
(provide (all-defined-out)) (provide (all-defined-out))
(define a 1) (define a 1)
(define b 2) (define b 2)
(define c 3))) (define c 3)))
o))) o)))
(call-with-output-file* (call-with-output-file*
"compiled/b_rkt.zo" (build-path (car (use-compiled-file-paths)) "b_rkt.zo")
(lambda (o) (write (compile '(module b racket/base (lambda (o) (write (compile '(module b racket/base
(require "a.rkt" (require "a.rkt"
;; Force saving of context, instead of ;; Force saving of context, instead of
;; reconstruction: ;; reconstruction:
(only-in racket/base [car extra-car])))) (only-in racket/base [car extra-car]))))
o)))) o))))
(dynamic-require (build-path tmp "b.rkt") #f) (dynamic-require (build-path tmp "b.rkt") #f)
(define ns (module->namespace (build-path tmp "b.rkt"))) (define ns (module->namespace (build-path tmp "b.rkt")))
(test #t (test #t
@ -1905,6 +1945,42 @@ case of module-leve bindings; it doesn't cover local bindings.
(namespace-syntax-introduce (namespace-syntax-introduce
(dynamic-require ''provide-the-x-identifier 'x-id)))))) (dynamic-require ''provide-the-x-identifier 'x-id))))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Check that `all-defined` exports at only the right phase
(module module-that-exports-at-phase-0-only racket/kernel
(#%require (for-syntax racket/kernel))
(#%provide (all-defined))
(define-values (x) 1)
(begin-for-syntax
(define-values (x) 2)))
(module module-that-imports-at-multiple-phases racket/kernel
(#%require 'module-that-exports-at-phase-0-only
;; Causes a collsion if the module exports too much
(for-syntax 'module-that-exports-at-phase-0-only)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Check that a top-level binding doesn't interefere
;; with reference
(define very-confused-x 1)
(module m-that-defines-very-confused-x racket
;; this line is necessary, but you can require anything
;;(require (only-in racket/base))
(define very-confused-x 10))
(require 'm-that-defines-very-confused-x)
(test 10
'very-confused-x
(parameterize ([current-namespace (module->namespace ''m-that-defines-very-confused-x)])
;; Note: #'very-confused-x will have top-level context
;; as well as the module context
(eval #'very-confused-x)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Make sure that re-expansion of a simple (in the sense of `require` ;; Make sure that re-expansion of a simple (in the sense of `require`
;; information kept for `module->namspace`) module body is ok ;; information kept for `module->namspace`) module body is ok
@ -2067,6 +2143,125 @@ case of module-leve bindings; it doesn't cover local bindings.
(eval '(f m) ns) (eval '(f m) ns)
(eval '(m) ns))) (eval '(m) ns)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Make sure a module can exports syntax bound to a rename transformer
;; to an unbound identifier
(let ([decl
'(module provides-rename-transformer-to-nowhere '#%kernel
(#%require (for-syntax '#%kernel))
(#%provide x)
(define-syntaxes (x) (make-rename-transformer (quote-syntax y))))])
(define o (open-output-bytes))
(write (compile decl) o)
(eval (parameterize ([read-accept-compiled #t])
(read (open-input-bytes (get-output-bytes o))))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Make sure `variable-reference->namespace` at phase 1
;; doesn't interfere with re-expansion when trigged
;; by a submodule
;;
;; This test is by William Bowman, Michael Ballantyne, and
;; Leif Andersen.
(let ([m '(module namespace-mismatch racket/base
(#%plain-module-begin
(#%require (for-syntax racket/base))
(begin-for-syntax
(let ([ns (variable-reference->namespace (#%variable-reference))])
;; The top level at phase 1 ...
(eval #'(define-syntax-rule (m) (begin (define x 2) x)) ns)
;; The expander will have to find the right macro-introduced `x`:
(eval #'(m) ns))
(#%plain-lambda () foo))
(begin-for-syntax
(define-values (foo) #f))
(module* f #f
(#%plain-module-begin))))])
(expand (expand m)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Make sure that prefixing a submodule require doesn't
;; run into trouble related to the expand-time submodule
;; instance not being registered in the bulk-binding
;; provides table
(module check-prefixed-bulk-provides-from-submodules racket/base
(module a racket/base
(provide a1 a2 a3)
(define a1 'a1)
(define a2 'a2)
(define a3 'a3))
(require (prefix-in a: 'a))
(define another 'x))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Allow a reference to a never-defined variable in a `local-expand`
;; or `syntax-local-bind-syntaxes` on the grounds that the result is
;; not necessarily in the module's expansion. But keep track of
;; missing variables encountered during
;; `syntax-local-expand-expression`, since the opqaue result can be
;; included without further inspection.
(module im-ok-and-your-ok-local-expand racket/base
(require (for-syntax racket/base)
(for-meta 2 racket/base))
(begin-for-syntax
(define-syntax (m stx)
(local-expand #'(lambda () nonesuch) 'expression '())
#''ok)
(m)))
(module im-ok-and-your-ok-syntax-local-bind-syntaxes racket/base
(require (for-syntax racket/base))
(define-syntax (m stx)
(syntax-local-bind-syntaxes (list #'x)
#'(lambda () nonesuch)
(syntax-local-make-definition-context))
#''ok)
(m))
(syntax-test #'(module im-ok-and-your-ok-local-expand racket/base
(require (for-syntax racket/base)
(for-meta 2 racket/base))
(begin-for-syntax
(define-syntax (m stx)
(syntax-local-expand-expression #'(lambda () nonesuch))
#''ok)
(m))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Make sure that shadowing in phase 1 doesn't
;; prevent `all-from-out` from providing the same
;; binding unshadowed at phase 0
(module check-shadowing-in-other-phase-d racket/base
(provide b)
(define b 'd))
(module check-shadowing-in-other-phase-c racket/base
(require (for-syntax racket/base))
(provide b (all-from-out racket/base)
(for-syntax b))
(define b 'c)
(define-for-syntax b 'c1))
(module check-shadowing-in-other-phase-b 'check-shadowing-in-other-phase-c
(require (for-syntax 'check-shadowing-in-other-phase-d))
(provide (all-from-out 'check-shadowing-in-other-phase-c)
(for-syntax (all-from-out 'check-shadowing-in-other-phase-d))))
(module check-shadowing-in-other-phase-a racket/base
(require 'check-shadowing-in-other-phase-b)
b)
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(report-errs) (report-errs)

4
pkgs/racket-test-core/tests/racket/namespac.rktl
View File

@ -109,7 +109,7 @@
(arity-test namespace-mapped-symbols 0 1) (arity-test namespace-mapped-symbols 0 1)
(arity-test namespace-variable-value 1 4) (arity-test namespace-variable-value 1 4)
(arity-test namespace-set-variable-value! 2 4) (arity-test namespace-set-variable-value! 2 5)
(arity-test namespace-undefine-variable! 1 2) (arity-test namespace-undefine-variable! 1 2)
(define n (make-base-namespace)) (define n (make-base-namespace))
@ -147,7 +147,7 @@
(test #f (test #f
variable-reference->module-path-index (#%variable-reference test)) variable-reference->module-path-index (#%variable-reference test))
(test (module-path-index-join ''#%kernel #f) (test (module-path-index-join ''#%runtime #f)
variable-reference->module-path-index (#%variable-reference +)) variable-reference->module-path-index (#%variable-reference +))
(require (only-in racket/unsafe/ops (require (only-in racket/unsafe/ops
[unsafe-fx+ $$unsafe-fx+])) [unsafe-fx+ $$unsafe-fx+]))

28
pkgs/racket-test-core/tests/racket/numstrs.rktl
View File

@ -6,6 +6,7 @@
(define number-table (define number-table
`((,(+ 1/2 +i) "1/2+i") `((,(+ 1/2 +i) "1/2+i")
(1.2+1i "1.2+i")
(100 "100") (100 "100")
(100 "#d100") (100 "#d100")
(0.1 ".1") (0.1 ".1")
@ -28,6 +29,8 @@
(0.0 "0e13") (0.0 "0e13")
(0.0 "#i0") (0.0 "#i0")
(-0.0 "#i-0") (-0.0 "#i-0")
(0.0 "0#")
(-0.0 "-0#")
(+inf.0 ".3e2666666666") (+inf.0 ".3e2666666666")
(+inf.0 "+INF.0") (+inf.0 "+INF.0")
(+nan.0 "+NaN.0") (+nan.0 "+NaN.0")
@ -78,6 +81,10 @@
(1/20 "#e0.5e-1") (1/20 "#e0.5e-1")
(1/20 "#e0.005e1") (1/20 "#e0.005e1")
(1.0+0.5i "1+0.5i") (1.0+0.5i "1+0.5i")
(0+1i "+i")
(0-1i "-i")
(1.0-0.0i "#i1-0i")
(1 "1-0i")
(1/2 "1/2@0") (1/2 "1/2@0")
(-1/2 "-1/2@0") (-1/2 "-1/2@0")
(1/2 "1/2@-0") (1/2 "1/2@-0")
@ -111,6 +118,8 @@
(X "#d1#/#3") (X "#d1#/#3")
(+inf.0 "1/0#") (+inf.0 "1/0#")
(-inf.0 "-1/0#") (-inf.0 "-1/0#")
(DBZ "1#/0")
(DBZ "-1#/0")
(NOE "#e+inf.0") (NOE "#e+inf.0")
(NOE "#e-inf.0") (NOE "#e-inf.0")
(NOE "#e+nan.0") (NOE "#e+nan.0")
@ -176,6 +185,10 @@
(#f "-+1") (#f "-+1")
(#f "-1+3-4") (#f "-1+3-4")
(#f "1\0002") (#f "1\0002")
(#f "1/2+3")
(#f "1.2+3")
(#f "2+1/2")
(#f "3+1.2")
(X "#xg") (X "#xg")
(X "#x") (X "#x")
(X "#xa#a") (X "#xa#a")
@ -251,4 +264,17 @@
(DBZ "1/0@+inf.0") (DBZ "1/0@+inf.0")
(DBZ "+inf.0@1/0") (DBZ "+inf.0@1/0")
(#f "1e1/0") (#f "1e1/0")
(#f "011111122222222223333333333444444x"))) (#f "011111122222222223333333333444444x")
(#f "t")
(#f "s2")
(#f "2e")
(#f ".e1")
(#f "+.e1")
(#f "+#e1")
(#f "1e#")
(#f "1e+")
(#f "1e+-")
(#f ".#e1")
(#f "/2")
(#f "-#/2")
(X "#/2")))

121
pkgs/racket-test-core/tests/racket/optimize.rktl
View File

@ -530,13 +530,13 @@
(test-comp '(lambda (w z) (pair? (list w (random) w))) (test-comp '(lambda (w z) (pair? (list w (random) w)))
'(lambda (w z) (random) #t)) '(lambda (w z) (random) #t))
(test-comp '(lambda (w z) (pair? (list (read) (random) w))) (test-comp '(lambda (w z) (pair? (list (read) (random) w)))
'(lambda (w z) (read) (random) #t)) '(lambda (w z) (values (read)) (random) #t))
(test-comp '(lambda (w z) (pair? (list z (random) (read)))) (test-comp '(lambda (w z) (pair? (list z (random) (read))))
'(lambda (w z) (random) (read) #t)) '(lambda (w z) (random) (values (read)) #t))
(test-comp '(lambda (w z) (pair? (list (if z (random) (error 'e)) (read)))) (test-comp '(lambda (w z) (pair? (list (if z (random) (error 'e)) (read))))
'(lambda (w z) (if z (random) (error 'e)) (read) #t)) '(lambda (w z) (if z (random) (error 'e)) (values (read)) #t))
(test-comp '(lambda (w z) (pair? (list (with-continuation-mark 'k 'v (read)) (random)))) (test-comp '(lambda (w z) (pair? (list (with-continuation-mark 'k 'v (read)) (random))))
'(lambda (w z) (with-continuation-mark 'k 'v (read)) (random) #t)) '(lambda (w z) (values (with-continuation-mark 'k 'v (read))) (random) #t))
(test-comp '(lambda (w z) (vector? (vector w z))) (test-comp '(lambda (w z) (vector? (vector w z)))
'(lambda (w z) #t)) '(lambda (w z) #t))
(test-comp '(lambda (w z) (vector? (vector-immutable w z))) (test-comp '(lambda (w z) (vector? (vector-immutable w z)))
@ -713,8 +713,11 @@
;The optimizer is not capable of figuring out that the result of map is a list? ;The optimizer is not capable of figuring out that the result of map is a list?
(test-arg-types '(k:map procedure? list?) 'list?) (test-arg-types '(k:map procedure? list?) 'list?)
(test-arg-types '(k:map procedure? list? list?) 'list?) (test-arg-types '(k:map procedure? list? list?) 'list?)
(test-arg-types '(map procedure? list?) #f) ;should be list?
(test-arg-types '(map procedure? list? list?) #f) ;should be list? ;Non-inlined slow-path means that the optimizer cannot infer for
;non-built-in `map`:
;(test-arg-types '(map procedure? list?) #f) ;should be list?
;(test-arg-types '(map procedure? list? list?) #f) ;should be list?
(test-comp '(lambda (w z) (test-comp '(lambda (w z)
(let ([x (list* w z)] (let ([x (list* w z)]
@ -1186,6 +1189,9 @@
(begin (quote-syntax foo) 3))]) (begin (quote-syntax foo) 3))])
x) x)
'3) '3)
;; The compiler doens't currently recognize the expansion of `quote-syntax`
#;
(test-comp '(if (lambda () 10) (test-comp '(if (lambda () 10)
'ok 'ok
(quote-syntax no!)) (quote-syntax no!))
@ -2140,6 +2146,8 @@
(void 10)) (void 10))
'(module m racket/base)) '(module m racket/base))
;; The compiler doens't currently recognize the expansion of `quote-syntax`
#;
(test-comp '(module m racket/base (test-comp '(module m racket/base
(void (quote-syntax unused!))) (void (quote-syntax unused!)))
'(module m racket/base)) '(module m racket/base))
@ -3003,6 +3011,7 @@
(require (submod ".." a)) (require (submod ".." a))
(list b c (c))))) (list b c (c)))))
(test-comp `(module m racket/base (test-comp `(module m racket/base
(module a racket/base (module a racket/base
(provide b c) (provide b c)
@ -3032,6 +3041,36 @@
(require (submod ".." a)) (require (submod ".." a))
(list b c (c 1))))) (list b c (c 1)))))
;; Use of `c` added to `a` via `b`
(test-comp `(module m racket/base
(module c racket/base
(provide c)
(define c 'c)
(set! c c))
(module b racket/base
(require (submod ".." c))
(provide b)
(define (b) c))
(module a racket/base
(require (submod ".." b)
(submod ".." c))
c
(b)))
`(module m racket/base
(module c racket/base
(provide c)
(define c 'c)
(set! c c))
(module b racket/base
(require (submod ".." c))
(provide b)
(define (b) c))
(module a racket/base
(require (submod ".." b)
(submod ".." c))
c
c)))
(module check-inline-request racket/base (module check-inline-request racket/base
(require racket/performance-hint) (require racket/performance-hint)
(provide loop) (provide loop)
@ -4053,19 +4092,19 @@
(test-comp '(letrec-values ([(x y) (error "oops")]) 11) (test-comp '(letrec-values ([(x y) (error "oops")]) 11)
'(error "oops")) '(error "oops"))
(test-comp '(let-values (((y) (read)) (() (error "oops"))) 11) (test-comp '(let-values (((y) (read)) (() (error "oops"))) 11)
'(let () (begin (read) (error "oops")))) '(let () (begin (values (read)) (error "oops"))))
(test-comp '(let-values (((y) (read)) (() (error "oops"))) 11) (test-comp '(let-values (((y) (read)) (() (error "oops"))) 11)
'(let () (begin (read) (error "oops")))) '(let () (begin (values (read)) (error "oops"))))
(test-comp '(let-values ((() (error "oops")) ((x) 9)) 11) (test-comp '(let-values ((() (error "oops")) ((x) 9)) 11)
'(error "oops")) '(error "oops"))
(test-comp '(let-values ((() (error "oops")) (() (values))) 11) (test-comp '(let-values ((() (error "oops")) (() (values))) 11)
'(error "oops")) '(error "oops"))
(test-comp '(let-values (((y) (read)) (() (error "oops")) ((x) 9)) 11) (test-comp '(let-values (((y) (read)) (() (error "oops")) ((x) 9)) 11)
'(let () (begin (read) (error "oops")))) '(let () (begin (values (read)) (error "oops"))))
(test-comp '(let-values (((y) (read)) (() (error "oops")) (() (values))) 11) (test-comp '(let-values (((y) (read)) (() (error "oops")) (() (values))) 11)
'(let () (begin (read) (error "oops")))) '(let () (begin (values (read)) (error "oops"))))
(test-comp '(error "oops") (test-comp '(error "oops")
'(let () (begin (read) (error "oops"))) '(let () (begin (values (read)) (error "oops")))
#f) #f)
(test-comp '(with-continuation-mark (test-comp '(with-continuation-mark
@ -5013,24 +5052,28 @@
(write-bytes (write-bytes
(zo-marshal (zo-marshal
(match m (match m
[(compilation-top max-let-depth binding-namess prefix code) [(linkl-bundle t)
(compilation-top max-let-depth binding-namess prefix (linkl-bundle
(let ([body (mod-body code)]) (hash-set t
(struct-copy mod code [body 0
(match body (let* ([l (hash-ref t 0)]
[(list a b) [body (linkl-body l)])
(list (match a (struct-copy linkl l [body
[(application rator (list rand)) (match body
(application [(list a b c)
rator (list (match a
(list [(application rator (list rand))
(struct-copy (application
lam rand rator
[body (list
(match (lam-body rand) (struct-copy
[(toplevel depth pos const? ready?) lam rand
(toplevel depth pos #t #t)])])))]) [body
b)])])))])) (match (lam-body rand)
[(toplevel depth pos const? ready?)
(toplevel depth pos #t #t)])])))])
b
c)])]))))]))
o2)) o2))
;; validator should reject this at read or eval time (depending on how lazy validation is): ;; validator should reject this at read or eval time (depending on how lazy validation is):
@ -5058,7 +5101,8 @@
; extract the content of the begin0 expression ; extract the content of the begin0 expression
(define (analyze-beg0 m) (define (analyze-beg0 m)
(define def-z (car (mod-body (compilation-top-code m)))) (define lb (hash-ref (linkl-directory-table m)'()))
(define def-z (car (linkl-body (hash-ref (linkl-bundle-table lb) 0))))
(define body-z (let-one-body (def-values-rhs def-z))) (define body-z (let-one-body (def-values-rhs def-z)))
(define expr-z (car (beg0-seq body-z))) (define expr-z (car (beg0-seq body-z)))
(cond (cond
@ -5272,8 +5316,9 @@
(write (compile l) o) (write (compile l) o)
(parameterize ([read-accept-compiled #t]) (parameterize ([read-accept-compiled #t])
(zo-parse (open-input-bytes (get-output-bytes o)))))) (zo-parse (open-input-bytes (get-output-bytes o))))))
(let* ([m (compilation-top-code b)] (let* ([lb (hash-ref (linkl-directory-table b) '())]
[d (car (mod-body m))] [m (hash-ref (linkl-bundle-table lb) 0)]
[d (car (linkl-body m))]
[b (closure-code (def-values-rhs d))] [b (closure-code (def-values-rhs d))]
[c (application-rator (lam-body b))] [c (application-rator (lam-body b))]
[l (closure-code c)] [l (closure-code c)]
@ -5294,8 +5339,9 @@
(write (compile l) o) (write (compile l) o)
(parameterize ([read-accept-compiled #t]) (parameterize ([read-accept-compiled #t])
(zo-parse (open-input-bytes (get-output-bytes o)))))) (zo-parse (open-input-bytes (get-output-bytes o))))))
(let* ([m (compilation-top-code b)] (let* ([lb (hash-ref (linkl-directory-table b) '())]
[d (car (mod-body m))] [m (hash-ref (linkl-bundle-table lb) 0)]
[d (car (linkl-body m))]
[rhs (def-values-rhs d)] [rhs (def-values-rhs d)]
[b (inline-variant-direct rhs)] [b (inline-variant-direct rhs)]
[v (application-rator (lam-body b))]) [v (application-rator (lam-body b))])
@ -5313,8 +5359,9 @@
(write (compile l) o) (write (compile l) o)
(parameterize ([read-accept-compiled #t]) (parameterize ([read-accept-compiled #t])
(zo-parse (open-input-bytes (get-output-bytes o)))))) (zo-parse (open-input-bytes (get-output-bytes o))))))
(let* ([m (compilation-top-code b)] (let* ([lb (hash-ref (linkl-directory-table b) '())]
[d (cadr (mod-body m))] [m (hash-ref (linkl-bundle-table lb) 0)]
[d (cadr (linkl-body m))]
[rhs (def-values-rhs d)] [rhs (def-values-rhs d)]
[b (inline-variant-direct rhs)] [b (inline-variant-direct rhs)]
[v (application-rator (lam-body b))]) [v (application-rator (lam-body b))])
@ -5409,7 +5456,7 @@
(lambda () (lambda ()
(with-handlers ([exn:fail:out-of-memory? void]) (with-handlers ([exn:fail:out-of-memory? void])
(arithmetic-shift 1 30070458541082))))))) (arithmetic-shift 1 30070458541082)))))))
(when (eq? '3m (system-type 'gc)) (unless (eq? 'cgc (system-type 'gc))
(void (dynamic-require ''uses-too-much-memory-for-shift #f))) (void (dynamic-require ''uses-too-much-memory-for-shift #f)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

6
pkgs/racket-test-core/tests/racket/param.rktl
View File

@ -35,7 +35,7 @@
(if erroring-set? (if erroring-set?
(begin (begin
(set! erroring-set? #f) (set! erroring-set? #f)
(error 'output)) (error 'output "~s" s))
(display (subbytes s start end) orig)) (display (subbytes s start end) orig))
(- end start))) (- end start)))
void)) void))
@ -267,7 +267,7 @@
(list current-output-port (list current-output-port
(list (current-output-port) (list (current-output-port)
erroring-port) erroring-port)
'(begin '(let ()
(set! erroring-set? #t) (set! erroring-set? #t)
(display 5) (display 5)
(set! erroring-set? #f)) (set! erroring-set? #f))
@ -420,7 +420,7 @@
[expr (caddr d)] [expr (caddr d)]
[exn? (cadddr d)]) [exn? (cadddr d)])
(parameterize ([param alt1]) (parameterize ([param alt1])
(test (void) void (teval expr))) (test (void) void (eval expr)))
(parameterize ([param alt2]) (parameterize ([param alt2])
(error-test (datum->syntax #f expr #f) exn?)))) (error-test (datum->syntax #f expr #f) exn?))))
params) params)

28
pkgs/racket-test-core/tests/racket/port.rktl
View File

@ -150,6 +150,7 @@
;; This port produces 0, 1, 2, 0, 1, 2, etc, ;; This port produces 0, 1, 2, 0, 1, 2, etc,
;; but it is not thread-safe, because multiple ;; but it is not thread-safe, because multiple
;; threads might read and change n ;; threads might read and change n
(define mod3-peeked? #f)
(define mod3-cycle/one-thread (define mod3-cycle/one-thread
(let* ([n 2] (let* ([n 2]
[mod! (lambda (s delta) [mod! (lambda (s delta)
@ -157,14 +158,16 @@
1)]) 1)])
(make-input-port (make-input-port
'mod3-cycle/not-thread-safe 'mod3-cycle/not-thread-safe
(lambda (s) (lambda (s)
(set! n (modulo (add1 n) 3)) (set! n (modulo (add1 n) 3))
(mod! s 0)) (mod! s 0))
(lambda (s skip progress-evt) (lambda (s skip progress-evt)
(mod! s skip)) (set! mod3-peeked? #t)
(mod! s (add1 skip)))
void))) void)))
(test "01201" read-string 5 mod3-cycle/one-thread) (test "01201" read-string 5 mod3-cycle/one-thread)
(test "20120" peek-string 5 (expt 2 5000) mod3-cycle/one-thread) (test #f values mod3-peeked?)
(test "20120" peek-string 5 (sub1 (expt 2 5000)) mod3-cycle/one-thread)
;; Same thing, but thread-safe and kill-safe, and with progress ;; Same thing, but thread-safe and kill-safe, and with progress
;; events. Only the server thread touches the stateful part ;; events. Only the server thread touches the stateful part
@ -520,7 +523,12 @@
(let ([s (make-bytes 6 (char->integer #\-))]) (let ([s (make-bytes 6 (char->integer #\-))])
(test 5 read-bytes-avail! s in) (test 5 read-bytes-avail! s in)
(test #"12311-" values s)) (test #"12311-" values s))
(test 3 write-bytes-avail #"1234" out)) (test 3 values
(let loop ([n 0])
(define v (write-bytes-avail* #"1234" out))
(if (zero? v)
n
(loop (+ n v))))))
;; Further test of peeking in a limited pipe (shouldn't get stuck): ;; Further test of peeking in a limited pipe (shouldn't get stuck):
(let-values ([(i o) (make-pipe 50)] (let-values ([(i o) (make-pipe 50)]
@ -633,11 +641,13 @@
(peek-byte r) (peek-byte r)
(let ([t (thread (lambda () (let ([t (thread (lambda ()
(port-commit-peeked 1 (port-progress-evt r) ch r)))]) (port-commit-peeked 1 (port-progress-evt r) ch r)))])
(sleep 0.01) (sync (system-idle-evt))
(let ([t2 (let ([t2
(thread (lambda () (thread (lambda ()
(port-commit-peeked 1 (port-progress-evt r) ch r)))]) (port-commit-peeked 1 (port-progress-evt r) ch r)))])
(sleep 0.01) (sync (system-idle-evt))
(test #t thread-running? t)
(test #t thread-running? t2)
(thread-suspend t2) (thread-suspend t2)
(break-thread t2) (break-thread t2)
(kill-thread t) (kill-thread t)
@ -657,9 +667,9 @@
void)]) void)])
(let ([t (thread (lambda () (with-handlers ([exn:break? void]) (let ([t (thread (lambda () (with-handlers ([exn:break? void])
(read-char p))))]) (read-char p))))])
(sleep 0.1) (sync (system-idle-evt))
(break-thread t) (break-thread t)
(sleep 0.1) (sync (system-idle-evt))
(test #f thread-running? t))))]) (test #f thread-running? t))))])
(try sync) (try sync)
(try sync/enable-break) (try sync/enable-break)

2
pkgs/racket-test-core/tests/racket/procs.rktl
View File

@ -288,7 +288,7 @@
(list allowed))) (list allowed)))
(begin (begin
(when (procedure-arity-includes? p 1 #t) (when (procedure-arity-includes? p 1 #t)
(err/rt-test (procedure-reduce-arity p 1) #rx"has required keyword arguments")) (err/rt-test (procedure-reduce-arity p 1) exn:fail? #rx"has required keyword arguments"))
(list (procedure-reduce-arity p '()) '() '() '() method? p)))))) (list (procedure-reduce-arity p '()) '() '() '() method? p))))))
procs) procs)
;; reduce to arity 0 or nothing --- no keywords: ;; reduce to arity 0 or nothing --- no keywords:

3
pkgs/racket-test-core/tests/racket/prompt-tests.rktl
View File

@ -798,7 +798,6 @@
p2)) p2))
(lambda () (out 'post1)))) (lambda () (out 'post1))))
p1)) p1))
(printf "here ~a\n" count)
(set! count (add1 count)) (set! count (add1 count))
(unless (= count 3) (unless (= count 3)
(call-with-continuation-prompt (call-with-continuation-prompt
@ -1989,7 +1988,7 @@
;; the C stack. Eventually, the relevant segment wraps around, ;; the C stack. Eventually, the relevant segment wraps around,
;; with an overflow. Push a little deeper and then capture ;; with an overflow. Push a little deeper and then capture
;; that. ;; that.
(let loop ([n 0][fuel #f]) (let loop ([n 0] [fuel (if (eq? (system-type 'vm) 'chez-scheme) 500 #f)])
(vector-set-performance-stats! v) (vector-set-performance-stats! v)
(cond (cond
[(and (not fuel) [(and (not fuel)

2
pkgs/racket-test-core/tests/racket/prompt.rktl
View File

@ -450,7 +450,7 @@
;; Check that a continuation doesn't retain the arguments ;; Check that a continuation doesn't retain the arguments
;; to the call to `call/cc` that created the continuation. ;; to the call to `call/cc` that created the continuation.
(when (eq? '3m (system-type 'gc)) (unless (eq? 'cgc (system-type 'gc))
(let ([ht (make-weak-hasheq)]) (let ([ht (make-weak-hasheq)])
(define l (define l
(for/list ([i 100]) (for/list ([i 100])

7
pkgs/racket-test-core/tests/racket/read.rktl
View File

@ -483,7 +483,7 @@
(test 0 syntax->datum (vector-ref (syntax-e (read-syntax #f (open-input-string "#2()"))) 1)) (test 0 syntax->datum (vector-ref (syntax-e (read-syntax #f (open-input-string "#2()"))) 1))
(err/rt-test (readstr "#2(1 2 3)") exn:fail:read?) (err/rt-test (readstr "#2(1 2 3)") exn:fail:read?)
(err/rt-test (readstr "#200000000000(1 2 3)") (readerrtype exn:fail:out-of-memory?)) (err/rt-test (readstr "#2000000000000000(1 2 3)") (readerrtype exn:fail:out-of-memory?))
(err/rt-test (readstr "#111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111x1(1 2 3)") exn:fail:read?) (err/rt-test (readstr "#111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111x1(1 2 3)") exn:fail:read?)
(test #t (lambda (x) (eq? (car x) (cdr x))) (readstr "(#1=(1 2) . #0001#)")) (test #t (lambda (x) (eq? (car x) (cdr x))) (readstr "(#1=(1 2) . #0001#)"))
@ -574,6 +574,7 @@
;; Test mid-stream EOF ;; Test mid-stream EOF
(define (test-mid-stream-eof use-peek?) (define (test-mid-stream-eof use-peek?)
(define no-peek? #f)
(define chars (map (lambda (x) (define chars (map (lambda (x)
(if (char? x) (char->integer x) x)) (if (char? x) (char->integer x) x))
(append (append
@ -1181,7 +1182,7 @@
(test (void) read-language (open-input-string ";;\n;\n#xa") void) (test (void) read-language (open-input-string ";;\n;\n#xa") void)
;; Check error-message formatting: ;; Check error-message formatting:
(err/rt-test (read (open-input-string "#l")) (err/rt-test (read (open-input-string "#l"))
(lambda (exn) (regexp-match? #rx"`#l'" (exn-message exn)))) (lambda (exn) (regexp-match? #rx"`#l`" (exn-message exn))))
;; Make sure read-language error here is this can comes from read-language ;; Make sure read-language error here is this can comes from read-language
;; and not from an ill-formed srcloc construction: ;; and not from an ill-formed srcloc construction:
(let () (let ()
@ -1190,6 +1191,8 @@
(err/rt-test (read-language p) (err/rt-test (read-language p)
(lambda (exn) (regexp-match? #rx"read-language" (exn-message exn))))) (lambda (exn) (regexp-match? #rx"read-language" (exn-message exn)))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(require racket/flonum (require racket/flonum
racket/fixnum) racket/fixnum)
(test #t flvector? (readstr "#fl(1.5 0.33 0.3)")) (test #t flvector? (readstr "#fl(1.5 0.33 0.3)"))

2
pkgs/racket-test-core/tests/racket/readtable.rktl
View File

@ -157,7 +157,7 @@
(let ([s1 (format "a~ab" ch)] (let ([s1 (format "a~ab" ch)]
[s2 (format "~aab~a" ch ch)]) [s2 (format "~aab~a" ch ch)])
(test-read s1 (list (string->symbol s1))) (test-read s1 (list (string->symbol s1)))
(test-read s2 (list (string->symbol s2)) #f) (test-read s2 (list (string->symbol s2)) #f)
(let ([blank (if (char=? ch #\space) (let ([blank (if (char=? ch #\space)
#\newline #\newline
#\space)]) #\space)])

12
pkgs/racket-test-core/tests/racket/rx.rktl
View File

@ -1787,10 +1787,12 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Test failure handlers ;; Test failure handlers
(test "`+' follows nothing in pattern" regexp "+" (λ (s) s)) (define (requote s) (regexp-replace* #rx"'" s "`"))
(test "`+' follows nothing in pattern" pregexp "+" (λ (s) s))
(test "`+' follows nothing in pattern" byte-regexp #"+" (λ (s) s)) (test "`+` follows nothing in pattern" regexp "+" requote)
(test "`+' follows nothing in pattern" byte-pregexp #"+" (λ (s) s)) (test "`+` follows nothing in pattern" pregexp "+" requote)
(test "`+` follows nothing in pattern" byte-regexp #"+" requote)
(test "`+` follows nothing in pattern" byte-pregexp #"+" requote)
(test 3 regexp "+" (λ (s) (+ 1 2))) (test 3 regexp "+" (λ (s) (+ 1 2)))
(test 3 pregexp "+" (λ (s) (+ 1 2))) (test 3 pregexp "+" (λ (s) (+ 1 2)))
(test 3 byte-regexp #"+" (λ (s) (+ 1 2))) (test 3 byte-regexp #"+" (λ (s) (+ 1 2)))
@ -1798,7 +1800,7 @@
(test-values '(1 2 3) (lambda () (byte-pregexp #"+" (λ (s) (values 1 2 3))))) (test-values '(1 2 3) (lambda () (byte-pregexp #"+" (λ (s) (values 1 2 3)))))
(err/rt-test (regexp "+" #f) (lambda (exn) (regexp-match? "`[+]' follows nothing in pattern" (exn-message exn)))) (err/rt-test (regexp "+" #f) (lambda (exn) (regexp-match? "`[+]. follows nothing in pattern" (exn-message exn))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Make sure that negated patterns as literal strings are not recorded ;; Make sure that negated patterns as literal strings are not recorded

6
pkgs/racket-test-core/tests/racket/sandbox.rktl
View File

@ -459,7 +459,9 @@
(copy-file ,test-zo ,list-zo) =err> "access denied" (copy-file ,test-zo ,list-zo) =err> "access denied"
;; timestamp .zo file (needed under Windows): ;; timestamp .zo file (needed under Windows):
(file-or-directory-modify-seconds ,test-zo (current-seconds)) (file-or-directory-modify-seconds ,test-zo (current-seconds))
;; loading test gets 'list module declaration via ".zo": ;; loading test gets 'list module declaration via ".zo", thanks
;; to delayed parsing of the bytecode (so this test doesn't work
;; if delay-loading is disabled):
(load/use-compiled ,test-lib) => (void) (load/use-compiled ,test-lib) => (void)
;; but the module declaration can't execute due to the inspector: ;; but the module declaration can't execute due to the inspector:
(require 'list) =err> "access disallowed by code inspector" (require 'list) =err> "access disallowed by code inspector"
@ -671,7 +673,7 @@
(define r1 (try 'racket/base)) (define r1 (try 'racket/base))
(define r2 (try '(begin))) (define r2 (try '(begin)))
(test #t regexp-match? (test #t regexp-match?
#rx"access disallowed by code inspector to protected variable" #rx"access disallowed by code inspector to protected"
r1) r1)
(test #t equal? r1 r2)) (test #t equal? r1 r2))

39
pkgs/racket-test-core/tests/racket/stx.rktl
View File

@ -39,6 +39,16 @@
(syntax-test #'(quote-syntax)) (syntax-test #'(quote-syntax))
(syntax-test #'(quote-syntax . 7)) (syntax-test #'(quote-syntax . 7))
;; Property is attached only to immediate syntax object:
(test #f
syntax-property
(car (syntax-e (datum->syntax #f '(a) #f (syntax-property #'x 'ok 'value))))
'ok)
(test 'value
syntax-property
(datum->syntax #f '(a) #f (syntax-property #'x 'ok 'value))
'ok)
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; some syntax-case patterns ;; some syntax-case patterns
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -542,14 +552,14 @@
(define base-lib (caddr (identifier-binding* #'lambda))) (define base-lib (caddr (identifier-binding* #'lambda)))
(test `('#%kernel case-lambda ,base-lib case-lambda 0 0 0) (test `('#%core case-lambda ,base-lib case-lambda 0 0 0)
identifier-binding* #'case-lambda) identifier-binding* #'case-lambda)
(test `("private/promise.rkt" delay* ,base-lib delay 0 0 0) (test `("private/promise.rkt" delay* ,base-lib delay 0 0 0)
identifier-binding* #'delay) identifier-binding* #'delay)
(test `('#%kernel #%module-begin ,base-lib #%plain-module-begin 0 0 0) (test `('#%core #%module-begin ,base-lib #%plain-module-begin 0 0 0)
identifier-binding* #'#%plain-module-begin) identifier-binding* #'#%plain-module-begin)
(require (only-in racket/base [#%plain-module-begin #%pmb])) (require (only-in racket/base [#%plain-module-begin #%pmb]))
(test '('#%kernel #%module-begin racket/base #%plain-module-begin 0 0 0) (test '('#%core #%module-begin racket/base #%plain-module-begin 0 0 0)
identifier-binding* #'#%pmb) identifier-binding* #'#%pmb)
(let ([b (identifier-binding (let ([b (identifier-binding
@ -1535,7 +1545,7 @@
(test '(10 20 #t) '@!$get @!$get) (test '(10 20 #t) '@!$get @!$get)
|# |#
(test '(12) (test '(1) ; old expander produced 12
eval eval
(expand (expand
#'(let ([b 12]) #'(let ([b 12])
@ -1858,6 +1868,21 @@
(syntax-arm #'(begin (define-values (x y z) (values 1 2 3))) (syntax-arm #'(begin (define-values (x y z) (values 1 2 3)))
#f #t))))))) #f #t)))))))
(let ()
(define i1 (make-inspector))
(define i2 (make-inspector))
(define x (syntax-arm #'(x) i1))
(test #f syntax-tainted? (car (syntax-e (syntax-disarm x i1))))
(test #t syntax-tainted? (car (syntax-e (syntax-disarm x i2))))
(define y (syntax-rearm (syntax-arm #'(y) i2) x))
(test #t syntax-tainted? (car (syntax-e (syntax-disarm y i1))))
(test #t syntax-tainted? (car (syntax-e (syntax-disarm y i2))))
(test #f syntax-tainted? (car (syntax-e (syntax-disarm (syntax-disarm y i1) i2)))))
(let ([round-trip (let ([round-trip
(lambda (stx) (lambda (stx)
(parameterize ([current-namespace (make-base-namespace)]) (parameterize ([current-namespace (make-base-namespace)])
@ -1969,7 +1994,7 @@
(require (for-syntax racket/base)) (require (for-syntax racket/base))
(begin-for-syntax (begin-for-syntax
(displayln (syntax-transforming-module-expression?)))))) (displayln (syntax-transforming-module-expression?))))))
(test "#t\n#f\n" get-output-string o)) (test "#t\n#t\n" get-output-string o))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Check that a common wraps encoding that is detected only ;; Check that a common wraps encoding that is detected only
@ -2477,7 +2502,7 @@
(err/rt-test (syntax-property #'+ 1 #'+ #t) (err/rt-test (syntax-property #'+ 1 #'+ #t)
(lambda (exn) (lambda (exn)
(regexp-match (regexp-match
#rx"expected an interned symbol key for a preserved property" #rx"key for a perserved property must be an interned symbol"
(exn-message exn)))) (exn-message exn))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -2495,7 +2520,7 @@
(write (compile (read-syntax path p)) out) (write (compile (read-syntax path p)) out)
(eval (read in)) (eval (read in))
(define src (syntax-source ((dynamic-require path 'f)))) (define src (syntax-source ((dynamic-require path 'f))))
(test (path->string path) values src))) (test path values src)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

4
pkgs/racket-test-core/tests/racket/submodule.rktl
View File

@ -147,8 +147,8 @@
(write also-c s) (write also-c s)
(parameterize ([read-accept-compiled #t]) (parameterize ([read-accept-compiled #t])
(read (open-input-bytes (get-output-bytes s)))))) (read (open-input-bytes (get-output-bytes s))))))
;; Marshaling flips the order, which is ok: ;; Marshaling preserves the order:
(test '(subm-example-0 b) values (module-compiled-name (car (module-compiled-submodules re-c #f))))) (test '(subm-example-0 a) values (module-compiled-name (car (module-compiled-submodules re-c #f)))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

13
pkgs/racket-test-core/tests/racket/sync.rktl
View File

@ -200,7 +200,7 @@
(semaphore-post s3) (semaphore-post s3)
(test s3 sync/timeout SYNC-SLEEP-DELAY set) (test s3 sync/timeout SYNC-SLEEP-DELAY set)
(test #f sync/timeout SYNC-SLEEP-DELAY set)) (test #f sync/timeout SYNC-SLEEP-DELAY set))
(let* ([c (make-channel)] (let* ([c (make-channel)]
[set (choice-evt s1 s2 c)]) [set (choice-evt s1 s2 c)])
(test #f sync/timeout SYNC-SLEEP-DELAY set) (test #f sync/timeout SYNC-SLEEP-DELAY set)
@ -1191,21 +1191,17 @@
(break-enabled #f)) (break-enabled #f))
(init ;; init function gets to decide whether to do the normal body: (init ;; init function gets to decide whether to do the normal body:
(lambda () (lambda ()
(printf "here ~s\n" (procedure? capture-pre))
(dynamic-wind (dynamic-wind
(lambda () (lambda ()
(printf "here3 ~s\n" (procedure? capture-pre))
(capture-pre (capture-pre
reset reset
(lambda () (lambda ()
(printf "here4\n")
(set! did-pre1 #t) (set! did-pre1 #t)
(semaphore-post p) (semaphore-post p)
(pre-thunk) (pre-thunk)
(pre-semaphore-wait s) (pre-semaphore-wait s)
(set! did-pre2 #t)))) (set! did-pre2 #t))))
(lambda () (lambda ()
(printf "here2\n")
(capture-act (capture-act
reset reset
(lambda () (lambda ()
@ -1340,9 +1336,6 @@
(body))]) (body))])
;; Grab a continuation for the dyn-wind's pre/act/post ;; Grab a continuation for the dyn-wind's pre/act/post
(go (lambda args (go (lambda args
(printf "here???\n")
(printf "??? ~s\n" k+reset)
(printf "??? ~s\n" capture)
(apply mk-t (apply mk-t
(lambda (f) (f)) (lambda (f) (f))
(if (eq? which 'pre) capture no-capture) (if (eq? which 'pre) capture no-capture)
@ -1372,9 +1365,9 @@
'test 'test
(lambda (bstr) never-evt) (lambda (bstr) never-evt)
(lambda (bstr skip-count progress-evt) (lambda (bstr skip-count progress-evt)
(wrap-evt always-evt (lambda (_) 17))) (wrap-evt always-evt (lambda (_) 1)))
void)]) void)])
;; Make sure we don't get 17 ;; Make sure we don't get 1
(test p sync p)) (test p sync p))
;; ---------------------------------------- ;; ----------------------------------------

29
pkgs/racket-test-core/tests/racket/syntax.rktl
View File

@ -868,7 +868,20 @@
(test 5 'implicit-begin (let () (begin) 10 5)) (test 5 'implicit-begin (let () (begin) 10 5))
(error-test #'(begin (define foo (let/cc k k)) (foo 10)) exn:application:type?) ; not exn:application:continuation? ;; Weird test: check that `eval` does not wrap its last argument
;; in a prompt, which means that `(foo 10)` replaces the continuation
;; that would check for an error
(error-test #'(begin (define foo (let/cc k k)) (foo 10)) (lambda (x) #f))
;; Check that `eval` does wrap a prompt around non-tail expressions
(test 10
(lambda (e) (call-with-continuation-prompt (lambda () (eval e))))
#'(begin (define foo (let/cc k k)) (foo 10) foo))
;; Check that `eval` doesn't add a prompt around definitions:
(eval #'(define foo (let/cc k k)))
(eval #'(define never-gets-defined (eval #'(foo 9))))
(err/rt-test (eval #'never-gets-defined) exn:fail:contract:variable?)
(define f-check #t) (define f-check #t)
(define f (delay (begin (set! f-check #f) 5))) (define f (delay (begin (set! f-check #f) 5)))
@ -1845,7 +1858,7 @@
free-identifier=? free-identifier=?
f-id f-id
(eval '(extract (f #:x 8) (eval '(extract (f #:x 8)
(lv ([(proc) f2] . _) (if const? (app f3 . _) . _)) (lv _ (if const? (app f3 . _) . _))
f3 f3
#f))) #f)))
(test (test
@ -1853,17 +1866,17 @@
free-identifier=? free-identifier=?
f-id f-id
(eval '(extract (f #:x 8) (eval '(extract (f #:x 8)
(lv ([(proc) f2] . _) (if const? (app f3 . _) . _)) (lv _ (if const? (app f3 . _) (app2 (app3 check&extract _ f2 . _) . _)))
f2 f2
#t))) #t)))
(test (test
#t #t
free-identifier=? free-identifier=?
f-id f-id
(eval '(extract (f #:y 9) (eval '(extract (f #:y 9)
(lv ([(proc) f2] . _) . _) (lv _ (app2 (app3 check&extract _ f2 . _) . _))
f2 f2
#t))) #t)))
(test (test
#t #t
free-identifier=? free-identifier=?

12
pkgs/racket-test-core/tests/racket/thread.rktl
View File

@ -557,6 +557,9 @@
(sleep) (sleep)
'not-void))) 'not-void)))
(err/rt-test (call-with-continuation-barrier
(lambda ()
(let/cc k (call-in-nested-thread (lambda () (k)))) exn:fail:contract:continuation?)))
(test 1 call-with-continuation-prompt (lambda () (test 1 call-with-continuation-prompt (lambda ()
(let/cc k (call-in-nested-thread (lambda () (k 1)))))) (let/cc k (call-in-nested-thread (lambda () (k 1))))))
(err/rt-test (let/ec k (call-in-nested-thread (lambda () (k)))) exn:fail:contract:continuation?) (err/rt-test (let/ec k (call-in-nested-thread (lambda () (k)))) exn:fail:contract:continuation?)
@ -999,9 +1002,10 @@
[loop (lambda () [loop (lambda ()
(let loop () (let loop ()
(set! v (add1 v)) (set! v (add1 v))
(sync (car all-ticks)) (unless (null? all-ticks)
(set! all-ticks (cdr all-ticks)) (sync (car all-ticks))
(loop)))] (set! all-ticks (cdr all-ticks))
(loop))))]
[c0 (make-custodian)]) [c0 (make-custodian)])
(let ([try (let ([try
(lambda (resumable?) (lambda (resumable?)
@ -1254,7 +1258,7 @@
(collect-garbage) (collect-garbage)
(plumber-flush-all c) (plumber-flush-all c)
(test 6 values done) (test 6 values done)
(set! h #f) (test #t plumber-flush-handle? h)
(collect-garbage) (collect-garbage)
(plumber-flush-all c) (plumber-flush-all c)
(test 6 values done)))) (test 6 values done))))

51
pkgs/racket-test-core/tests/racket/will.rktl
View File

@ -16,6 +16,9 @@
(define we (make-will-executor)) (define we (make-will-executor))
(test #f will-try-execute we)
(test 'no will-try-execute we 'no)
;; Never GC this one: ;; Never GC this one:
(test (void) will-register we test (lambda (x) (error 'bad-will-call))) (test (void) will-register we test (lambda (x) (error 'bad-will-call)))
@ -61,7 +64,7 @@
(arity-test will-executor? 1 1) (arity-test will-executor? 1 1)
(arity-test will-register 3 3) (arity-test will-register 3 3)
(arity-test will-execute 1 1) (arity-test will-execute 1 1)
(arity-test will-try-execute 1 1) (arity-test will-try-execute 1 2)
;; ---------------------------------------- ;; ----------------------------------------
;; Test custodian boxes ;; Test custodian boxes
@ -192,7 +195,7 @@
;; ---------------------------------------- ;; ----------------------------------------
;; Phantom bytes: ;; Phantom bytes:
(when (eq? '3m (system-type 'gc)) (unless (eq? 'cgc (system-type 'gc))
(define s (make-semaphore)) (define s (make-semaphore))
(define c (make-custodian)) (define c (make-custodian))
(define t (parameterize ([current-custodian c]) (define t (parameterize ([current-custodian c])
@ -238,7 +241,7 @@
;; Check that local variables are cleared for space safety ;; Check that local variables are cleared for space safety
;; before a tail `sync' or `thread-wait': ;; before a tail `sync' or `thread-wait':
(when (eq? '3m (system-type 'gc)) (unless (eq? 'cgc (system-type 'gc))
(define weak-syms (make-weak-hash)) (define weak-syms (make-weak-hash))
(define thds (define thds
@ -267,7 +270,7 @@
;; a reference can be important to the expansion to a call to a keyword-accepting ;; a reference can be important to the expansion to a call to a keyword-accepting
;; function. ;; function.
(when (eq? '3m (system-type 'gc)) (unless (eq? 'cgc (system-type 'gc))
(define (mk) (define (mk)
(parameterize ([current-namespace (make-base-namespace)]) (parameterize ([current-namespace (make-base-namespace)])
(eval '(module module-with-unoptimized-varref-constant racket/base (eval '(module module-with-unoptimized-varref-constant racket/base
@ -356,11 +359,47 @@
(kill-thread watcher-t) (kill-thread watcher-t)
(test #t 'many-vectors-in-reasonable-space? done?)) (test #t 'many-vectors-in-reasonable-space? done?))
;; ----------------------------------------
;; Check that a thread that has a reference to
;; module-level variables doesn't retain the
;; namespace strongly
(unless (eq? 'cgc (system-type 'gc))
(define-values (f w)
(parameterize ([current-namespace (make-base-namespace)])
(define g (gensym 'gensym-via-namespace))
(eval `(module n racket/base
;; If the namespace is retained strongly, then
;; the symbol is reachable through this definition:
(define anchor (quote ,g))))
(eval `(module m racket/base
(require 'n)
(provide f sema)
(define sema (make-semaphore))
(define (f)
(thread
(lambda ()
;; Ideally, this loop retains only `loop`
;; and `sema`. If it retains everything refereneced
;; or defined in the module, though, at least make
;; sure it doesn't retain the whole namespace
(let loop () (sync sema) (loop)))))))
(namespace-require ''m)
(values (dynamic-require ''m 'f)
(make-weak-box g))))
(define t (f))
(sync (system-idle-evt))
(collect-garbage)
(test #f weak-box-value w)
(kill-thread t))
;; ---------------------------------------- ;; ----------------------------------------
;; Check that ephemeron chains do not lead ;; Check that ephemeron chains do not lead
;; to O(N^2) behavior with 3m ;; to O(N^2) behavior with 3m
(when (eq? '3m (system-type 'gc)) (unless (eq? 'cgc (system-type 'gc))
(define (wrapper v) (list 1 2 3 4 5 v)) (define (wrapper v) (list 1 2 3 4 5 v))
;; Create a chain of ephemerons where we have all ;; Create a chain of ephemerons where we have all
@ -423,7 +462,7 @@
;; ---------------------------------------- ;; ----------------------------------------
;; Check that `apply` doesn't retain its argument ;; Check that `apply` doesn't retain its argument
(when (eq? '3m (system-type 'gc)) (unless (eq? 'cgc (system-type 'gc))
(define retained 0) (define retained 0)

1176
pkgs/zo-lib/compiler/zo-marshal.rkt
View File

File diff suppressed because it is too large Load Diff

1253
pkgs/zo-lib/compiler/zo-parse.rkt
View File

File diff suppressed because it is too large Load Diff

203
pkgs/zo-lib/compiler/zo-structs.rkt
View File

@ -4,19 +4,6 @@
racket/list racket/list
racket/set) racket/set)
#| Unresolved issues
what are the booleans in lexical-rename?
contracts that are probably too generous:
prefix-stxs
provided-nom-src
lam-num-params
lexical-rename-alist
all-from-module
|#
;; ---------------------------------------- ;; ----------------------------------------
;; Structures to represent bytecode ;; Structures to represent bytecode
@ -42,94 +29,51 @@
(define-form-struct struct-shape ()) (define-form-struct struct-shape ())
(define-form-struct (constructor-shape struct-shape) ([arity exact-nonnegative-integer?])) (define-form-struct (constructor-shape struct-shape) ([arity exact-nonnegative-integer?]))
(define-form-struct (predicate-shape struct-shape) ()) (define-form-struct (predicate-shape struct-shape) ([authentic? boolean?]))
(define-form-struct (accessor-shape struct-shape) ([field-count exact-nonnegative-integer?])) (define-form-struct (accessor-shape struct-shape) ([field-count exact-nonnegative-integer?]
(define-form-struct (mutator-shape struct-shape) ([field-count exact-nonnegative-integer?])) [authentic? boolean?]))
(define-form-struct (struct-type-shape struct-shape) ([field-count exact-nonnegative-integer?])) (define-form-struct (mutator-shape struct-shape) ([field-count exact-nonnegative-integer?]
[authentic? boolean?]))
(define-form-struct (struct-type-shape struct-shape) ([field-count exact-nonnegative-integer?]
[authentic? boolean?]))
(define-form-struct (struct-type-property-shape struct-shape) ([has-guard? boolean?])) (define-form-struct (struct-type-property-shape struct-shape) ([has-guard? boolean?]))
(define-form-struct (property-predicate-shape struct-shape) ()) (define-form-struct (property-predicate-shape struct-shape) ())
(define-form-struct (property-accessor-shape struct-shape) ()) (define-form-struct (property-accessor-shape struct-shape) ())
(define-form-struct (struct-other-shape struct-shape) ()) (define-form-struct (struct-other-shape struct-shape) ())
;; In toplevels of resove prefix:
(define-form-struct global-bucket ([name symbol?])) ; top-level binding
(define-form-struct module-variable ([modidx module-path-index?]
[sym symbol?]
[pos exact-integer?]
[phase exact-nonnegative-integer?]
[constantness (or/c #f 'constant 'fixed
function-shape?
struct-shape?)]))
(define-form-struct prefix ([num-lifts exact-nonnegative-integer?]
[toplevels (listof (or/c #f symbol? global-bucket? module-variable?))]
[stxs (listof (or/c #f stx?))] ; #f is unusual, but it can happen when one is optimized away at the last moment
[src-inspector-desc symbol?]))
(define-form-struct form ()) (define-form-struct form ())
(define-form-struct (expr form) ()) (define-form-struct (expr form) ())
(define-form-struct compilation-top ([max-let-depth exact-nonnegative-integer?]
[binding-namess (hash/c exact-nonnegative-integer?
(hash/c symbol? stx?))]
[prefix prefix?]
[code (or/c form? any/c)])) ; compiled code always wrapped with this
;; A provided identifier
(define-form-struct provided ([name symbol?]
[src (or/c module-path-index? #f)]
[src-name symbol?]
[nom-src any/c] ; should be (or/c module-path-index? #f)
[src-phase exact-nonnegative-integer?]
[protected? boolean?]))
(define-form-struct (toplevel expr) ([depth exact-nonnegative-integer?] (define-form-struct (toplevel expr) ([depth exact-nonnegative-integer?]
[pos exact-nonnegative-integer?] [pos exact-nonnegative-integer?]
[const? boolean?] [const? boolean?]
[ready? boolean?])) ; access binding via prefix array (which is on stack) [ready? boolean?])) ; access binding via prefix array (which is on stack)
(define-form-struct (seq form) ([forms (listof (or/c form? any/c))])) ; `begin' (define-form-struct (seq expr) ([forms (listof (or/c expr? any/c))])) ; `begin'
(define-form-struct (seq-for-syntax form) ([forms (listof (or/c form? any/c))] ; `begin-for-syntax'
[prefix prefix?]
[max-let-depth exact-nonnegative-integer?]
[dummy (or/c toplevel? #f)]))
(define-form-struct (inline-variant form) ([direct expr?] (define-form-struct (inline-variant zo) ([direct expr?]
[inline expr?])) [inline expr?]))
;; Definitions (top level or within module): ;; Definitions (top level or within module):
(define-form-struct (def-values form) ([ids (listof (or/c toplevel? symbol?))] (define-form-struct (def-values form) ([ids (listof (or/c toplevel? symbol?))]
[rhs (or/c expr? seq? inline-variant? any/c)])) [rhs (or/c expr? seq? inline-variant? any/c)]))
(define-form-struct (def-syntaxes form) ([ids (listof (or/c toplevel? symbol?))]
[rhs (or/c expr? seq? any/c)]
[prefix prefix?]
[max-let-depth exact-nonnegative-integer?]
[dummy (or/c toplevel? #f)]))
(define-form-struct (mod form) ([name (or/c symbol? (listof symbol?))] (define-form-struct (linkl zo) ([name symbol?]
[srcname symbol?] [importss (listof (listof symbol?))]
[self-modidx module-path-index?] [import-shapess (listof (listof (or/c #f 'constant 'fixed
[prefix prefix?] function-shape?
[provides (listof (list/c (or/c exact-integer? #f) struct-shape?)))]
(listof provided?) [exports (listof symbol?)]
(listof provided?)))] [internals (listof (or/c symbol? #f))]
[requires (listof (cons/c (or/c exact-integer? #f) [lifts (listof symbol?)]
(listof module-path-index?)))] [source-names (hash/c symbol? symbol?)]
[body (listof (or/c form? any/c))] [body (listof (or/c form? any/c))]
[syntax-bodies (listof (cons/c exact-positive-integer?
(listof (or/c def-syntaxes? seq-for-syntax?))))]
[unexported (listof (list/c exact-nonnegative-integer?
(listof symbol?)
(listof symbol?)))]
[max-let-depth exact-nonnegative-integer?] [max-let-depth exact-nonnegative-integer?]
[dummy toplevel?] [need-instance-access? boolean?]))
[lang-info (or/c #f (vector/c module-path? symbol? any/c))]
[internal-context (or/c #f #t stx? (vectorof stx?))] (define-form-struct (linkl-directory zo) ([table (hash/c (listof symbol?) linkl-bundle?)]))
[binding-names (hash/c exact-integer? (define-form-struct (linkl-bundle zo) ([table (hash/c (or/c symbol? fixnum?)
(hash/c symbol? (or/c #t stx?)))] any/c)])) ; can be anythingv, but especially a linklet
[flags (listof (or/c 'cross-phase))]
[pre-submodules (listof mod?)]
[post-submodules (listof mod?)]))
(define-form-struct (lam expr) ([name (or/c symbol? vector? empty?)] (define-form-struct (lam expr) ([name (or/c symbol? vector? empty?)]
[flags (listof (or/c 'preserves-marks 'is-method 'single-result [flags (listof (or/c 'preserves-marks 'is-method 'single-result
@ -165,16 +109,16 @@
[type (or/c #f 'flonum 'fixnum 'extflonum)])) ; access local via stack [type (or/c #f 'flonum 'fixnum 'extflonum)])) ; access local via stack
(define-form-struct (topsyntax expr) ([depth exact-nonnegative-integer?] [pos exact-nonnegative-integer?] [midpt exact-nonnegative-integer?])) ; access syntax object via prefix array (which is on stack)
(define-form-struct (application expr) ([rator (or/c expr? seq? any/c)] [rands (listof (or/c expr? seq? any/c))])) ; function call (define-form-struct (application expr) ([rator (or/c expr? seq? any/c)] [rands (listof (or/c expr? seq? any/c))])) ; function call
(define-form-struct (branch expr) ([test (or/c expr? seq? any/c)] [then (or/c expr? seq? any/c)] [else (or/c expr? seq? any/c)])) ; `if' (define-form-struct (branch expr) ([test (or/c expr? seq? any/c)] [then (or/c expr? seq? any/c)] [else (or/c expr? seq? any/c)])) ; `if'
(define-form-struct (with-cont-mark expr) ([key (or/c expr? seq? any/c)] (define-form-struct (with-cont-mark expr) ([key (or/c expr? seq? any/c)]
[val (or/c expr? seq? any/c)] [val (or/c expr? seq? any/c)]
[body (or/c expr? seq? any/c)])) ; `with-continuation-mark' [body (or/c expr? seq? any/c)])) ; `with-continuation-mark'
(define-form-struct (beg0 expr) ([seq (listof (or/c expr? seq? any/c))])) ; `begin0' (define-form-struct (beg0 expr) ([seq (listof (or/c expr? seq? any/c))])) ; `begin0'
(define-form-struct (splice form) ([forms (listof (or/c form? any/c))])) ; top-level `begin' (define-form-struct (varref expr) ([toplevel (or/c toplevel? #f #t symbol?)]
(define-form-struct (varref expr) ([toplevel (or/c toplevel? #t)] [dummy (or/c toplevel? #f)])) ; `#%variable-reference' [dummy (or/c toplevel? #f)]
[constant? boolean?]
[from-unsafe? boolean?]))
(define-form-struct (assign expr) ([id toplevel?] [rhs (or/c expr? seq? any/c)] [undef-ok? boolean?])) ; top-level or module-level set! (define-form-struct (assign expr) ([id toplevel?] [rhs (or/c expr? seq? any/c)] [undef-ok? boolean?])) ; top-level or module-level set!
(define-form-struct (apply-values expr) ([proc (or/c expr? seq? any/c)] [args-expr (or/c expr? seq? any/c)])) ; `(call-with-values (lambda () ,args-expr) ,proc) (define-form-struct (apply-values expr) ([proc (or/c expr? seq? any/c)] [args-expr (or/c expr? seq? any/c)])) ; `(call-with-values (lambda () ,args-expr) ,proc)
(define-form-struct (with-immed-mark expr) ([key (or/c expr? seq? any/c)] (define-form-struct (with-immed-mark expr) ([key (or/c expr? seq? any/c)]
@ -182,58 +126,37 @@
[body (or/c expr? seq? any/c)])) [body (or/c expr? seq? any/c)]))
(define-form-struct (primval expr) ([id exact-nonnegative-integer?])) ; direct preference to a kernel primitive (define-form-struct (primval expr) ([id exact-nonnegative-integer?])) ; direct preference to a kernel primitive
;; Top-level `require' ;; For backward compatibility, provide limited matching support as `compilation-top`:
(define-form-struct (req form) ([reqs stx?] [dummy toplevel?])) (provide compilation-top)
(require (for-syntax racket/base))
(define-match-expander compilation-top
;; Syntax objects (lambda (stx)
(syntax-case stx ()
(define-form-struct stx ([content stx-obj?])) [(_ max-let-depth binding-namess prefix code)
#'(linkl-directory (hash-table ('() (linkl-bundle
(define-form-struct stx-obj ([datum any/c] ; S-expression with `wrapped` components (hash-table (0 (linkl _ ; name
[wrap any/c] ; should be `wrap?`, but encoded form appears initially _ ; imports
[srcloc any/c] ; should be `(or/c #f srcloc?)`, but encoded form appears initially _ ; import shapes
[props (hash/c symbol? any/c)] _ ; exports
[tamper-status (or/c 'clean 'armed 'tainted)])) _ ; internals
_ ; lifts
(define-form-struct wrap ([shifts (listof module-shift?)] _ ; source-names
[simple-scopes (listof scope?)] (list code) ; body
[multi-scopes (listof (list/c multi-scope? (or/c #f exact-integer? (box/c exact-integer?))))])) max-let-depth
_))
(define-form-struct module-shift ([from (or/c #f module-path-index?)] _ (... ...))))
[to (or/c #f module-path-index?)] _ (... ...)))]))
[from-inspector-desc (or/c #f symbol?)] (lambda (stx)
[to-inspector-desc (or/c #f symbol?)])) (syntax-case stx ()
[(_ max-let-depth binding-namess prefix code)
(define-form-struct scope ([name (or/c 'root exact-nonnegative-integer?)] ; 'root is special; otherwise, just for printing #'(linkl-directory (hash '() (linkl-bundle
[kind symbol?] (hasheq 0 (linkl 'top
[bindings (listof (list/c symbol? (listof scope?) binding?)) #:mutable] '()
[bulk-bindings (listof (list/c (listof scope?) all-from-module?)) #:mutable] '()
[multi-owner (or/c #f multi-scope?) #:mutable])) '()
(define-form-struct multi-scope ([name exact-nonnegative-integer?] '()
[src-name any/c] ; debugging info, such as module name '()
[scopes (listof (list/c (or/c #f exact-integer?) scope?)) #:mutable])) #hasheq()
(list code)
(define-form-struct binding ()) (add1 max-let-depth)
(define-form-struct (free-id=?-binding binding) ([base (and/c binding? #f)))))])))
(not/c free-id=?-binding?))]
[id stx-obj?]
[phase (or/c #f exact-integer?)]))
(define-form-struct (local-binding binding) ([name symbol?]))
(define-form-struct (module-binding binding) ([encoded any/c]))
;; Convert `module-binding` to `decoded-module-binding` with `decode-module-binding`:
(define-form-struct (decoded-module-binding binding) ([path (or/c #f module-path-index?)]
[name symbol?]
[phase exact-integer?]
[nominal-path (or/c #f module-path-index?)]
[nominal-export-name symbol?]
[nominal-phase (or/c #f exact-integer?)]
[import-phase (or/c #f exact-integer?)]
[inspector-desc (or/c #f symbol?)]))
(define-form-struct all-from-module ([path module-path-index?]
[phase (or/c exact-integer? #f)]
[src-phase (or/c exact-integer? #f)]
[inspector-desc symbol?]
[exceptions (listof symbol?)]
[prefix (or/c symbol? #f)]))

759
racket/collects/compiler/cm.rkt
View File

@ -1,92 +1,27 @@
#lang racket/base #lang racket/base
(require syntax/modcode (require "private/cm-minimal.rkt"
syntax/modresolve (submod "private/cm-minimal.rkt" cm-internal)
syntax/modread racket/contract/base
setup/dirs
racket/file
racket/list
racket/path
racket/promise
openssl/sha1
racket/place racket/place
setup/collects racket/path
compiler/compilation-path racket/promise)
compiler/private/dep
racket/contract/base) (provide (except-out (all-from-out "private/cm-minimal.rkt")
current-path->mode)
(provide make-compilation-manager-load/use-compiled-handler
managed-compile-zo
make-caching-managed-compile-zo
trust-existing-zos
manager-compile-notify-handler
manager-skip-file-handler
file-stamp-in-collection file-stamp-in-collection
file-stamp-in-paths file-stamp-in-paths
manager-trace-handler
get-file-sha1
get-compiled-file-sha1
with-compile-output
managed-compiled-context-key
make-compilation-context-error-display-handler
parallel-lock-client
make-compile-lock make-compile-lock
compile-lock->parallel-lock-client compile-lock->parallel-lock-client
install-module-hashes!
(contract-out (contract-out
[current-path->mode [current-path->mode
(parameter/c (or/c #f (-> path? (and/c path? relative-path?))))])) (parameter/c (or/c #f (-> path? (and/c path? relative-path?))))]))
(define current-path->mode (make-parameter #f))
(define cm-logger (make-logger 'compiler/cm (current-logger)))
(define (default-manager-trace-handler str)
(when (log-level? cm-logger 'debug)
(log-message cm-logger 'debug str (current-inexact-milliseconds))))
(struct compile-event (timestamp path action) #:prefab)
(define (log-compile-event path action)
(when (log-level? cm-logger 'info 'compiler/cm)
(log-message cm-logger 'info (format "~a~a: ~a" (get-indent-string) action path)
(compile-event (current-inexact-milliseconds) path action))))
(define manager-compile-notify-handler (make-parameter void))
(define manager-trace-handler (make-parameter default-manager-trace-handler))
(define indent (make-parameter 0))
(define trust-existing-zos (make-parameter #f))
(define manager-skip-file-handler (make-parameter (λ (x) #f)))
(define depth (make-parameter 0))
(define parallel-lock-client (make-parameter #f))
(define managed-compiled-context-key (gensym))
(define (make-compilation-context-error-display-handler orig)
(lambda (str exn)
(define l (continuation-mark-set->list
(exn-continuation-marks exn)
managed-compiled-context-key))
(orig (if (null? l)
str
(apply
string-append
str
"\n compilation context...:"
(for/list ([i (in-list l)])
(format "\n ~a" i))))
exn)))
(define (file-stamp-in-collection p) (define (file-stamp-in-collection p)
(file-stamp-in-paths p (current-library-collection-paths))) (file-stamp-in-paths p (current-library-collection-paths)))
(define (try-file-time p)
(let ([s (file-or-directory-modify-seconds p #f (lambda () #f))])
(and s
(if (eq? (use-compiled-file-check) 'modify-seconds)
s
0))))
(define (file-stamp-in-paths p paths) (define (file-stamp-in-paths p paths)
(let ([p-eles (explode-path (simple-form-path p))]) (let ([p-eles (explode-path (simple-form-path p))])
(let c-loop ([paths paths]) (let c-loop ([paths paths])
@ -163,19 +98,6 @@
[else [else
(c-loop (cdr paths))])]))])))) (c-loop (cdr paths))])]))]))))
(define (path*->collects-relative p)
(if (bytes? p)
(let ([q (path->collects-relative (bytes->path p))])
(if (path? q)
(path->bytes q)
q))
(path->collects-relative p)))
(define (collects-relative*->path p cache)
(if (bytes? p)
(bytes->path p)
(hash-ref! cache p (lambda () (collects-relative->path p)))))
(define (reroot-path* base root) (define (reroot-path* base root)
(cond (cond
[(eq? root 'same) base] [(eq? root 'same) base]
@ -184,668 +106,7 @@
[else [else
(reroot-path base root)])) (reroot-path base root)]))
(define (trace-printf fmt . args) ;; ----------------------------------------
(let ([t (manager-trace-handler)])
(unless (or (eq? t void)
(and (equal? t default-manager-trace-handler)
(not (log-level? cm-logger 'debug))))
(t (string-append (get-indent-string)
(apply format fmt args))))))
(define (get-indent-string)
(build-string (indent)
(λ (x)
(if (and (= 2 (modulo x 3))
(not (= x (- (indent) 1))))
#\|
#\space))))
(define (get-deps code path)
(define ht
(let loop ([code code] [ht (hash)])
(define new-ht
(for*/fold ([ht ht]) ([imports (in-list (module-compiled-imports code))]
[x (in-list (cdr imports))])
(let* ([r (resolve-module-path-index x path)]
[r (if (pair? r) (cadr r) r)])
(if (and (path? r)
(not (equal? path r))
(not (equal? path r))
(not (equal? path (rkt->ss r))))
(hash-set ht (path->bytes r) #t)
ht))))
(for*/fold ([ht new-ht]) ([non-star? (in-list '(#f #t))]
[subcode (in-list (module-compiled-submodules code non-star?))])
(loop subcode ht))))
(for/list ([k (in-hash-keys ht)]) k))
(define (get-compilation-path path->mode roots path)
(let-values ([(dir name) (get-compilation-dir+name path #:modes (list (path->mode path)) #:roots roots)])
(build-path dir name)))
(define (touch path)
(when (eq? 'modify-seconds (use-compiled-file-check))
(with-compiler-security-guard
(file-or-directory-modify-seconds
path
(current-seconds)
(lambda ()
(close-output-port (open-output-file path #:exists 'append)))))))
(define (try-delete-file path [noisy? #t])
;; Attempt to delete, but give up if it doesn't work:
(with-handlers ([exn:fail:filesystem? void])
(when noisy? (trace-printf "deleting ~a" path))
(with-compiler-security-guard (delete-file path))))
(define (compilation-failure path->mode roots path zo-name date-path reason)
(try-delete-file zo-name)
(trace-printf "failure"))
;; with-compile-output : path (output-port path -> alpha) -> alpha
(define (with-compile-output path proc)
(call-with-atomic-output-file
path
#:security-guard (pick-security-guard)
proc))
(define-syntax-rule
(with-compiler-security-guard expr)
(parameterize ([current-security-guard (pick-security-guard)])
expr))
(define compiler-security-guard (make-parameter #f))
(define (pick-security-guard)
(or (compiler-security-guard)
(current-security-guard)))
(define (get-source-sha1 p)
(with-handlers ([exn:fail:filesystem? (lambda (exn)
(and (path-has-extension? p #".rkt")
(get-source-sha1 (path-replace-extension p #".ss"))))])
(call-with-input-file* p sha1)))
(define (get-dep-sha1s deps up-to-date collection-cache read-src-syntax path->mode roots must-exist? seen)
(let ([l (for/fold ([l null]) ([dep (in-list deps)])
(and l
(let* ([ext? (external-dep? dep)]
[p (collects-relative*->path (dep->encoded-path dep) collection-cache)])
(cond
[ext? (let ([v (get-source-sha1 p)])
(cond
[v (cons (cons (delay v) dep) l)]
[must-exist? (error 'cm "cannot find external-dependency file: ~v" p)]
[else #f]))]
[(or (hash-ref up-to-date (simple-form-path p) #f)
;; Use `compile-root' with `sha1-only?' as #t:
(compile-root path->mode roots p up-to-date collection-cache read-src-syntax #t seen))
=> (lambda (sh)
(cons (cons (cdr sh) dep) l))]
[must-exist?
;; apparently, we're forced to use the source of the module,
;; so compute a sha1 from it instead of the bytecode
(cons (cons (get-source-sha1 p) dep) l)]
[else #f]))))])
(and l
(let ([p (open-output-string)]
[l (map (lambda (v)
(let ([sha1 (force (car v))]
[dep (cdr v)])
(unless sha1
(error 'cm "no SHA-1 for dependency: ~s" dep))
(cons sha1 dep)))
l)])
;; sort by sha1s so that order doesn't matter
(write (sort l string<? #:key car) p)
;; compute one hash from all hashes
(sha1 (open-input-bytes (get-output-bytes p)))))))
(define (write-deps code path->mode roots path src-sha1
external-deps external-module-deps reader-deps
up-to-date collection-cache read-src-syntax)
(let ([dep-path (path-add-extension (get-compilation-path path->mode roots path) #".dep")]
[deps (remove-duplicates (append (get-deps code path)
external-module-deps ; can create cycles if misused!
reader-deps))]
[external-deps (remove-duplicates external-deps)])
(define (path*->collects-relative/maybe-indirect dep)
(if (and (pair? dep) (eq? 'indirect (car dep)))
(cons 'indirect (path*->collects-relative (cdr dep)))
(path*->collects-relative dep)))
(with-compile-output dep-path
(lambda (op tmp-path)
(let ([deps (append
(map path*->collects-relative/maybe-indirect deps)
(map (lambda (x)
(define d (path*->collects-relative/maybe-indirect x))
(if (and (pair? d) (eq? 'indirect d))
(cons 'indirect (cons 'ext (cdr d)))
(cons 'ext d)))
external-deps))])
(write (list* (version)
(cons (or src-sha1 (get-source-sha1 path))
(get-dep-sha1s deps up-to-date collection-cache read-src-syntax path->mode roots #t #hash()))
(sort deps s-exp<?))
op)
(newline op))))))
(define (s-exp<? a b)
(string<? (format "~s" a) (format "~s" b)))
(define (format-time sec)
(let ([d (seconds->date sec)])
(format "~a-~a-~a ~a:~a:~a"
(date-year d) (date-month d) (date-day d)
(date-hour d) (date-minute d) (date-second d))))
(define (verify-times ss-name zo-name)
(when (eq? 'modify-seconds (use-compiled-file-check))
(define ss-sec (file-or-directory-modify-seconds ss-name))
(define zo-sec (try-file-time zo-name))
(cond [(not ss-sec) (error 'compile-zo "internal error")]
[(not zo-sec) (error 'compile-zo "failed to create .zo file (~a) for ~a"
zo-name ss-name)]
[(< zo-sec ss-sec) (error 'compile-zo
"date for newly created .zo file (~a @ ~a) ~
is before source-file date (~a @ ~a)~a"
zo-name (format-time zo-sec)
ss-name (format-time ss-sec)
(if (> ss-sec (current-seconds))
", which appears to be in the future"
""))])))
(define-struct ext-reader-guard (proc top)
#:property prop:procedure (struct-field-index proc))
(define-struct file-dependency (path module?) #:prefab)
(define-struct (file-dependency/options file-dependency) (table) #:prefab)
(define (compile-zo* path->mode roots path src-sha1 read-src-syntax zo-name up-to-date collection-cache)
;; The `path' argument has been converted to .rkt or .ss form,
;; as appropriate.
;; External dependencies registered through reader guard and
;; accomplice-logged events:
(define external-deps null)
(define external-module-deps null)
(define reader-deps null)
(define deps-sema (make-semaphore 1))
(define done-key (gensym))
(define (external-dep! p module? indirect?)
(define bstr (path->bytes p))
(define dep (if indirect?
(cons 'indirect bstr)
bstr))
(if module?
(set! external-module-deps (cons dep external-module-deps))
(set! external-deps (cons dep external-deps))))
(define (reader-dep! p)
(call-with-semaphore
deps-sema
(lambda ()
(set! reader-deps (cons (path->bytes p) reader-deps)))))
;; Set up a logger to receive and filter accomplice events:
(define accomplice-logger (make-logger #f (current-logger)
;; Don't propoagate 'cm-accomplice events, so that
;; enclosing compilations don't see events intended
;; for this one:
'none 'cm-accomplice
;; Propagate everything else:
'debug))
(define receiver (make-log-receiver accomplice-logger 'info 'cm-accomplice))
;; Compile the code:
(define code
(parameterize ([current-reader-guard
(let* ([rg (current-reader-guard)]
[rg (if (ext-reader-guard? rg)
(ext-reader-guard-top rg)
rg)])
(make-ext-reader-guard
(lambda (d)
;; Start by calling the top installed guard to
;; transform the module path, avoiding redundant
;; dependencies by avoiding accumulation of these
;; guards.
(let ([d (rg d)])
(when (module-path? d)
(let* ([p (resolved-module-path-name
(module-path-index-resolve
(module-path-index-join d #f)))]
[p (if (pair? p)
;; Create a dependency only if
;; the corresponding submodule is
;; declared:
(if (module-declared? d #t)
(car p)
#f)
p)])
(when (path? p) (reader-dep! p))))
d))
rg))]
[current-logger accomplice-logger])
(with-continuation-mark
managed-compiled-context-key
path
(get-module-code path (path->mode path) compile
(lambda (a b) #f) ; extension handler
#:source-reader read-src-syntax))))
(define dest-roots (list (car roots)))
(define code-dir (get-compilation-dir path #:modes (list (path->mode path)) #:roots dest-roots))
;; Get all accomplice data:
(let loop ()
(let ([l (sync/timeout 0 receiver)])
(when l
(when (and (eq? (vector-ref l 0) 'info)
(file-dependency? (vector-ref l 2))
(path? (file-dependency-path (vector-ref l 2))))
(external-dep! (file-dependency-path (vector-ref l 2))
(file-dependency-module? (vector-ref l 2))
(and (file-dependency/options? (vector-ref l 2))
(hash-ref (file-dependency/options-table (vector-ref l 2))
'indirect
#f))))
(loop))))
;; Write the code and dependencies:
(when code
(with-compiler-security-guard (make-directory* code-dir))
(with-compile-output zo-name
(lambda (out tmp-name)
(with-handlers ([exn:fail?
(lambda (ex)
(close-output-port out)
(compilation-failure path->mode dest-roots path zo-name #f
(exn-message ex))
(raise ex))])
(parameterize ([current-write-relative-directory
(let* ([dir
(let-values ([(base name dir?) (split-path path)])
(if (eq? base 'relative)
(current-directory)
(path->complete-path base (current-directory))))]
[collects-dir (find-collects-dir)]
[e-dir (explode-path dir)]
[e-collects-dir (explode-path collects-dir)])
(if (and ((length e-dir) . > . (length e-collects-dir))
(for/and ([a (in-list e-dir)]
[b (in-list e-collects-dir)])
(equal? a b)))
;; `dir' extends `collects-dir':
(cons dir collects-dir)
;; `dir' doesn't extend `collects-dir':
dir))])
(let ([b (open-output-bytes)])
;; Write bytecode into string
(write code b)
;; Compute SHA1 over modules within bytecode
(let* ([s (get-output-bytes b)])
(install-module-hashes! s)
;; Write out the bytecode with module hash
(write-bytes s out)))))
;; redundant, but close as early as possible:
(close-output-port out)
;; Note that we check time and write .deps before returning from
;; with-compile-output...
(verify-times path tmp-name)
(write-deps code path->mode dest-roots path src-sha1
external-deps external-module-deps reader-deps
up-to-date collection-cache read-src-syntax)))
(trace-printf "wrote zo file: ~a" zo-name)))
(define (install-module-hashes! s [start 0] [len (bytes-length s)])
(define vlen (bytes-ref s (+ start 2)))
(define mode (integer->char (bytes-ref s (+ start 3 vlen))))
(case mode
[(#\T)
;; A single module:
(define h (sha1-bytes (open-input-bytes (if (and (zero? start)
(= len (bytes-length s)))
s
(subbytes s start (+ start len))))))
;; Write sha1 for module hash:
(bytes-copy! s (+ start 4 vlen) h)]
[(#\D)
;; A directory form modules and submodules. The format starts with <count>,
;; and then it's <count> records of the format:
;; <name-len> <name-bytes> <mod-pos> <mod-len> <left-pos> <right-pos>
(define (read-num rel-pos)
(define pos (+ start rel-pos))
(integer-bytes->integer s #t #f pos (+ pos 4)))
(define count (read-num (+ 4 vlen)))
(for/fold ([pos (+ 8 vlen)]) ([i (in-range count)])
(define pos-pos (+ pos 4 (read-num pos)))
(define mod-start (read-num pos-pos))
(define mod-len (read-num (+ pos-pos 4)))
(install-module-hashes! s (+ start mod-start) mod-len)
(+ pos-pos 16))
(void)]
[else
;; ?? unknown mode
(void)]))
(define (actual-source-path path)
(if (file-exists? path)
path
(let ([alt-path (rkt->ss path)])
(if (file-exists? alt-path)
alt-path
path))))
(define (maybe-compile-zo sha1-only? deps path->mode roots path orig-path read-src-syntax up-to-date collection-cache seen)
(let ([actual-path (actual-source-path orig-path)])
(unless sha1-only?
((manager-compile-notify-handler) actual-path)
(trace-printf "maybe-compile-zo starting ~a" actual-path))
(begin0
(parameterize ([indent (+ 2 (indent))])
(let* ([zo-name (path-add-extension (get-compilation-path path->mode roots path) #".zo")]
[zo-exists? (file-exists? zo-name)])
(if (and zo-exists? (trust-existing-zos))
(begin
(trace-printf "trusting: ~a" zo-name)
(touch zo-name)
#f)
(let ([src-sha1 (and zo-exists?
deps
(cadr deps)
(get-source-sha1 path))])
(if (and zo-exists?
src-sha1
(equal? src-sha1 (and (pair? (cadr deps))
(caadr deps)))
(equal? (get-dep-sha1s (cddr deps) up-to-date collection-cache read-src-syntax path->mode roots #f seen)
(cdadr deps)))
(begin
(trace-printf "hash-equivalent: ~a" zo-name)
(touch zo-name)
#f)
((if sha1-only? values (lambda (build) (build) #f))
(lambda ()
(let* ([lc (parallel-lock-client)]
[_ (when lc (log-compile-event path 'locking))]
[locked? (and lc (lc 'lock zo-name))]
[ok-to-compile? (or (not lc) locked?)])
(dynamic-wind
(lambda () (void))
(lambda ()
(when ok-to-compile?
(log-compile-event path 'start-compile)
(when zo-exists? (try-delete-file zo-name #f))
(trace-printf "compiling ~a" actual-path)
(parameterize ([depth (+ (depth) 1)])
(with-handlers
([exn:get-module-code?
(lambda (ex)
(compilation-failure path->mode roots path zo-name
(exn:get-module-code-path ex)
(exn-message ex))
(raise ex))])
(compile-zo* path->mode roots path src-sha1 read-src-syntax zo-name up-to-date collection-cache)))
(trace-printf "compiled ~a" actual-path)))
(lambda ()
(when lc
(log-compile-event path (if locked? 'finish-compile 'already-done)))
(when locked?
(lc 'unlock zo-name))))))))))))
(unless sha1-only?
(trace-printf "maybe-compile-zo finished ~a" actual-path)))))
(define (get-compiled-time path->mode roots path)
(define-values (dir name) (get-compilation-dir+name path #:modes (list (path->mode path)) #:roots roots))
(or (try-file-time (build-path dir "native" (system-library-subpath)
(path-add-extension name (system-type
'so-suffix))))
(try-file-time (build-path dir (path-add-extension name #".zo")))))
(define (try-file-sha1 path dep-path)
(with-module-reading-parameterization
(lambda ()
(with-handlers ([exn:fail:filesystem? (lambda (exn) #f)])
(string-append
(call-with-input-file* path sha1)
(with-handlers ([exn:fail:filesystem? (lambda (exn) "")])
(call-with-input-file* dep-path (lambda (p) (cdadr (read p))))))))))
(define (get-compiled-sha1 path->mode roots path)
(define-values (dir name) (get-compilation-dir+name path #:modes (list (path->mode path)) #:roots roots))
(let ([dep-path (build-path dir (path-add-extension name #".dep"))])
(or (try-file-sha1 (build-path dir "native" (system-library-subpath)
(path-add-extension name (system-type
'so-suffix)))
dep-path)
(try-file-sha1 (build-path dir (path-add-extension name #".zo"))
dep-path)
"")))
(define (different-source-sha1-and-dep-recorded path deps)
(define src-hash (get-source-sha1 path))
(define recorded-hash (and (pair? (cadr deps))
(caadr deps)))
(if (equal? src-hash recorded-hash)
#f
(list src-hash recorded-hash)))
(define (rkt->ss p)
(if (path-has-extension? p #".rkt")
(path-replace-extension p #".ss")
p))
(define (compile-root path->mode roots path0 up-to-date collection-cache read-src-syntax sha1-only? seen)
(define orig-path (simple-form-path path0))
(define (read-deps path)
(with-handlers ([exn:fail:filesystem? (lambda (ex) (list (version) '#f))])
(with-module-reading-parameterization
(lambda ()
(call-with-input-file*
(path-add-extension (get-compilation-path path->mode roots path) #".dep")
read)))))
(define (do-check)
(let* ([main-path orig-path]
[alt-path (rkt->ss orig-path)]
[main-path-time (try-file-time main-path)]
[alt-path-time (and (not main-path-time)
(not (eq? alt-path main-path))
(try-file-time alt-path))]
[path (if alt-path-time alt-path main-path)]
[path-time (or main-path-time alt-path-time)]
[path-zo-time (get-compiled-time path->mode roots path)])
(cond
[(hash-ref seen path #f)
(error 'compile-zo
"dependency cycle\n involves module: ~a"
path)
#f]
[(not path-time)
(trace-printf "~a does not exist" orig-path)
(or (hash-ref up-to-date orig-path #f)
(let ([stamp (cons (or path-zo-time +inf.0)
(delay (get-compiled-sha1 path->mode roots path)))])
(hash-set! up-to-date main-path stamp)
(unless (eq? main-path alt-path)
(hash-set! up-to-date alt-path stamp))
stamp))]
[else
(let ([deps (read-deps path)]
[new-seen (hash-set seen path #t)])
(define build
(cond
[(not (and (pair? deps) (equal? (version) (car deps))))
(lambda ()
(trace-printf "newer version...")
(maybe-compile-zo #f #f path->mode roots path orig-path read-src-syntax up-to-date collection-cache new-seen))]
[(> path-time (or path-zo-time -inf.0))
(trace-printf "newer src... ~a > ~a" path-time path-zo-time)
;; If `sha1-only?', then `maybe-compile-zo' returns a #f or thunk:
(maybe-compile-zo sha1-only? deps path->mode roots path orig-path read-src-syntax up-to-date collection-cache new-seen)]
[(different-source-sha1-and-dep-recorded path deps)
=> (lambda (difference)
(trace-printf "different src hash... ~a" difference)
;; If `sha1-only?', then `maybe-compile-zo' returns a #f or thunk:
(maybe-compile-zo sha1-only? deps path->mode roots path orig-path read-src-syntax up-to-date collection-cache new-seen))]
[(ormap-strict
(lambda (p)
(define ext? (external-dep? p))
(define d (collects-relative*->path (dep->encoded-path p) collection-cache))
(define t
(if ext?
(cons (or (try-file-time d) +inf.0) #f)
(compile-root path->mode roots d up-to-date collection-cache read-src-syntax #f new-seen)))
(and t
(car t)
(> (car t) (or path-zo-time -inf.0))
(begin (trace-printf "newer: ~a (~a > ~a)..."
d (car t) path-zo-time)
#t)))
(cddr deps))
;; If `sha1-only?', then `maybe-compile-zo' returns a #f or thunk:
(maybe-compile-zo sha1-only? deps path->mode roots path orig-path read-src-syntax up-to-date collection-cache new-seen)]
[else #f]))
(cond
[(and build sha1-only?) #f]
[else
(when build (build))
(let ([stamp (cons (or (get-compiled-time path->mode roots path) +inf.0)
(delay (get-compiled-sha1 path->mode roots path)))])
(hash-set! up-to-date main-path stamp)
(unless (eq? main-path alt-path)
(hash-set! up-to-date alt-path stamp))
stamp)]))])))
(or (hash-ref up-to-date orig-path #f)
(let ([v ((manager-skip-file-handler) orig-path)])
(and v
(hash-set! up-to-date orig-path v)
v))
(begin (trace-printf "checking: ~a" orig-path)
(do-check))))
(define (ormap-strict f l)
(cond
[(null? l) #f]
[else
(define a (f (car l)))
(define b (ormap-strict f (cdr l)))
(or a b)]))
(define (managed-compile-zo zo [read-src-syntax read-syntax] #:security-guard [security-guard #f])
((make-caching-managed-compile-zo read-src-syntax #:security-guard security-guard) zo))
(define (make-caching-managed-compile-zo [read-src-syntax read-syntax] #:security-guard [security-guard #f])
(let ([cache (make-hash)]
[collection-cache (make-hash)])
(lambda (src)
(parameterize ([current-load/use-compiled
(make-compilation-manager-load/use-compiled-handler/table
cache
collection-cache
#f
#:security-guard security-guard)]
[error-display-handler
(make-compilation-context-error-display-handler
(error-display-handler))])
(compile-root (or (current-path->mode)
(let ([mode (car (use-compiled-file-paths))])
(λ (pth) mode)))
(current-compiled-file-roots)
(path->complete-path src)
cache
collection-cache
read-src-syntax
#f
#hash())
(void)))))
(define (make-compilation-manager-load/use-compiled-handler [delete-zos-when-rkt-file-does-not-exist? #f]
#:security-guard
[security-guard #f])
(make-compilation-manager-load/use-compiled-handler/table (make-hash) (make-hash)
delete-zos-when-rkt-file-does-not-exist?
#:security-guard security-guard))
(define (make-compilation-manager-load/use-compiled-handler/table cache collection-cache
delete-zos-when-rkt-file-does-not-exist?
#:security-guard [security-guard #f])
(define cp->m (current-path->mode))
(define modes (use-compiled-file-paths))
(when (and (not cp->m) (null? modes))
(raise-mismatch-error 'make-compilation-manager-...
"use-compiled-file-paths is '() and current-path->mode is #f"))
(define path->mode (or cp->m (λ (p) (car modes))))
(let ([orig-eval (current-eval)]
[orig-load (current-load)]
[orig-registry (namespace-module-registry (current-namespace))]
[default-handler (current-load/use-compiled)]
[roots (current-compiled-file-roots)])
(define (compilation-manager-load-handler path mod-name)
(cond [(or (not mod-name)
;; Don't trigger compilation if we're not supposed to work with source:
(and (pair? mod-name)
(not (car mod-name))))
(trace-printf "skipping: ~a mod-name ~s" path mod-name)]
[(not (or (file-exists? path)
(let ([p2 (rkt->ss path)])
(and (not (eq? path p2))
(file-exists? p2)))))
(trace-printf "skipping: ~a file does not exist" path)
(when delete-zos-when-rkt-file-does-not-exist?
(define to-delete (path-add-extension (get-compilation-path path->mode roots path) #".zo"))
(when (file-exists? to-delete)
(trace-printf "deleting: ~s" to-delete)
(with-compiler-security-guard (delete-file to-delete))))]
[(if cp->m
(not (equal? (current-path->mode) cp->m))
(let ([current-cfp (use-compiled-file-paths)])
(or (null? current-cfp)
(not (equal? (car current-cfp) (car modes))))))
(if cp->m
(trace-printf "skipping: ~a current-path->mode changed; current value ~s, original value was ~s"
path (current-path->mode) cp->m)
(trace-printf "skipping: ~a use-compiled-file-paths's first element changed; current value ~s, first element was ~s"
path
(use-compiled-file-paths)
(car modes)))]
[(not (equal? roots (current-compiled-file-roots)))
(trace-printf "skipping: ~a current-compiled-file-roots changed; current value ~s, original was ~s"
path
(current-compiled-file-roots)
roots)]
[(not (eq? compilation-manager-load-handler
(current-load/use-compiled)))
(trace-printf "skipping: ~a current-load/use-compiled changed ~s"
path (current-load/use-compiled))]
[(not (eq? orig-eval (current-eval)))
(trace-printf "skipping: ~a orig-eval ~s current-eval ~s"
path orig-eval (current-eval))]
[(not (eq? orig-load (current-load)))
(trace-printf "skipping: ~a orig-load ~s current-load ~s"
path orig-load (current-load))]
[(not (eq? orig-registry
(namespace-module-registry (current-namespace))))
(trace-printf "skipping: ~a orig-registry ~s current-registry ~s"
path orig-registry
(namespace-module-registry (current-namespace)))]
[else
(trace-printf "processing: ~a" path)
(parameterize ([compiler-security-guard security-guard])
(compile-root path->mode roots path cache collection-cache read-syntax #f #hash()))
(trace-printf "done: ~a" path)])
(default-handler path mod-name))
(when (null? roots)
(raise-mismatch-error 'make-compilation-manager-...
"empty current-compiled-file-roots list: "
roots))
compilation-manager-load-handler))
;; Exported:
(define (get-compiled-file-sha1 path)
(try-file-sha1 path (path-replace-extension path #".dep")))
(define (get-file-sha1 path)
(get-source-sha1 path))
(define (make-compile-lock) (define (make-compile-lock)
(define-values (manager-side-chan build-side-chan) (place-channel)) (define-values (manager-side-chan build-side-chan) (place-channel))

37
racket/collects/compiler/depend.rkt Normal file
View File

@ -0,0 +1,37 @@
#lang racket/base
(require compiler/compilation-path
compiler/private/dep
setup/collects)
(provide module-recorded-dependencies)
(define (module-recorded-dependencies path)
(define collection-cache (make-hash))
(define (module-dependencies path all-deps)
(define dep-path (path-add-extension (get-compilation-path path) #".dep"))
(define deps (with-handlers ([exn:fail:filesystem? (lambda (exn) #f)]
[exn:fail:read? (lambda (exn) #f)])
(call-with-input-file* dep-path read)))
(for/fold ([all-deps all-deps]) ([dep (in-list (if (and (list? deps)
(pair? deps)
(pair? (cdr deps)))
(cddr deps)
'()))])
(define p (collects-relative*->path (dep->encoded-path dep) collection-cache))
(cond
[(hash-ref all-deps p #f) all-deps]
[else
(define new-deps (hash-set all-deps p #t))
(cond
[(external-dep? dep) new-deps]
[else (module-dependencies p new-deps)])])))
(hash-keys (module-dependencies (simplify-path path) #hash())))
(define (get-compilation-path path)
(define-values (dir name) (get-compilation-dir+name path))
(build-path dir name))
(define (collects-relative*->path p cache)
(if (bytes? p)
(bytes->path p)
(hash-ref! cache p (lambda () (collects-relative->path p)))))

67
racket/collects/compiler/distribute.rkt
View File

@ -32,7 +32,7 @@
(case (cross-system-type) (case (cross-system-type)
[(windows) #f] [(windows) #f]
[(unix) "bin"] [(unix) "bin"]
[(macosx) (if (memq type '(gracketcgc gracket3m)) [(macosx) (if (memq type '(gracketcgc gracket3m gracketcs))
#f #f
"bin")]))) "bin")])))
orig-binaries orig-binaries
@ -48,7 +48,7 @@
(make-directory dest-dir)) (make-directory dest-dir))
(let-values ([(base name dir?) (split-path b)]) (let-values ([(base name dir?) (split-path b)])
(let ([dest (build-path dest-dir name)]) (let ([dest (build-path dest-dir name)])
(if (and (memq type '(gracketcgc gracket3m)) (if (and (memq type '(gracketcgc gracket3m gracketcs))
(eq? 'macosx (cross-system-type))) (eq? 'macosx (cross-system-type)))
(begin (begin
(copy-app b dest) (copy-app b dest)
@ -67,7 +67,7 @@
[single-mac-app? (and executables? [single-mac-app? (and executables?
(eq? 'macosx (cross-system-type)) (eq? 'macosx (cross-system-type))
(= 1 (length types)) (= 1 (length types))
(memq (car types) '(gracketcgc gracket3m)))]) (memq (car types) '(gracketcgc gracket3m gracketcs)))])
;; Create directories for libs, collects, and extensions: ;; Create directories for libs, collects, and extensions:
(let-values ([(lib-dir collects-dir relative-collects-dir exts-dir relative-exts-dir) (let-values ([(lib-dir collects-dir relative-collects-dir exts-dir relative-exts-dir)
(if single-mac-app? (if single-mac-app?
@ -131,7 +131,7 @@
[sub-dir [sub-dir
(build-path 'up relative-dir)] (build-path 'up relative-dir)]
[(and (eq? 'macosx (cross-system-type)) [(and (eq? 'macosx (cross-system-type))
(memq type '(gracketcgc gracket3m)) (memq type '(gracketcgc gracket3m gracketcs))
(not single-mac-app?)) (not single-mac-app?))
(build-path 'up 'up 'up relative-dir)] (build-path 'up 'up 'up relative-dir)]
[else [else
@ -187,15 +187,23 @@
(memq 'gracket3m types)) (memq 'gracket3m types))
(map copy-dll (map copy-dll
(list (list
(versionize "libracket3m~a.dll"))))))] (versionize "libracket3m~a.dll"))))
(when (or (memq 'racketcs types)
(memq 'gracketcs types))
(map copy-dll
(list
(versionize "libracketcs~a.dll"))))))]
[(macosx) [(macosx)
(unless extras-only? (unless extras-only?
(when (or (memq 'racketcgc types) (when (or (memq 'racketcgc types)
(memq 'gracketcgc types)) (memq 'gracketcgc types))
(copy-framework "Racket" #f lib-dir)) (copy-framework "Racket" 'cgc lib-dir))
(when (or (memq 'racket3m types) (when (or (memq 'racket3m types)
(memq 'gracket3m types)) (memq 'gracket3m types))
(copy-framework "Racket" #t lib-dir)))] (copy-framework "Racket" '3m lib-dir))
(when (or (memq 'racketcs types)
(memq 'gracketcs types))
(copy-framework "Racket" 'cs lib-dir)))]
[(unix) [(unix)
(unless extras-only? (unless extras-only?
(let ([lib-plt-dir (build-path lib-dir "plt")]) (let ([lib-plt-dir (build-path lib-dir "plt")])
@ -213,10 +221,14 @@
(copy-bin "racket" 'cgc #f)) (copy-bin "racket" 'cgc #f))
(when (memq 'racket3m types) (when (memq 'racket3m types)
(copy-bin "racket" '3m #f)) (copy-bin "racket" '3m #f))
(when (memq 'racketcs types)
(copy-bin "racket" 'cs #f))
(when (memq 'gracketcgc types) (when (memq 'gracketcgc types)
(copy-bin "gracket" 'cgc #t)) (copy-bin "gracket" 'cgc #t))
(when (memq 'gracket3m types) (when (memq 'gracket3m types)
(copy-bin "gracket" '3m #t))) (copy-bin "gracket" '3m #t))
(when (memq 'gracketcs types)
(copy-bin "gracket" 'cs #t)))
(when (shared-libraries?) (when (shared-libraries?)
(when (or (memq 'racketcgc types) (when (or (memq 'racketcgc types)
(memq 'gracketcgc types)) (memq 'gracketcgc types))
@ -224,7 +236,10 @@
(copy-shared-lib "mzgc" lib-dir)) (copy-shared-lib "mzgc" lib-dir))
(when (or (memq 'racket3m types) (when (or (memq 'racket3m types)
(memq 'gracket3m types)) (memq 'gracket3m types))
(copy-shared-lib "racket3m" lib-dir)))))])) (copy-shared-lib "racket3m" lib-dir))
(when (or (memq 'racketcs types)
(memq 'gracketcs types))
(copy-shared-lib "racketcs" lib-dir)))))]))
(define (search-dll dll-dir dll) (define (search-dll dll-dir dll)
(if dll-dir (if dll-dir
@ -248,12 +263,13 @@
;; Can't find it, so just use executable's dir: ;; Can't find it, so just use executable's dir:
(build-path exe-dir dll))))) (build-path exe-dir dll)))))
(define (copy-framework name 3m? lib-dir) (define (copy-framework name variant lib-dir)
(let* ([fw-name (format "~a.framework" name)] (let* ([fw-name (format "~a.framework" name)]
[sub-dir (build-path fw-name "Versions" [sub-dir (build-path fw-name "Versions"
(if 3m? (case variant
(format "~a_3m" (version)) [(3m) (format "~a_3m" (version))]
(version)))]) [(cs) (format "~a_CS" (version))]
[else (version)]))])
(make-directory* (build-path lib-dir sub-dir)) (make-directory* (build-path lib-dir sub-dir))
(let* ([fw-name (build-path sub-dir (format "~a" name))] (let* ([fw-name (build-path sub-dir (format "~a" name))]
[dll-dir (find-framework fw-name)]) [dll-dir (find-framework fw-name)])
@ -308,18 +324,18 @@
binaries)] binaries)]
[(macosx) [(macosx)
(if (and (= 1 (length types)) (if (and (= 1 (length types))
(memq (car types) '(gracketcgc gracket3m))) (memq (car types) '(gracketcgc gracket3m gracketcs)))
;; Special case for single GRacket app: ;; Special case for single GRacket app:
(update-framework-path "@executable_path/../Frameworks/" (update-framework-path "@executable_path/../Frameworks/"
(car binaries) (car binaries)
#t) #t)
;; General case: ;; General case:
(for-each (lambda (b type) (for-each (lambda (b type)
(update-framework-path (if (memq type '(racketcgc racket3m)) (update-framework-path (if (memq type '(racketcgc racket3m racketcs))
"@executable_path/../lib/" "@executable_path/../lib/"
"@executable_path/../../../lib/" ) "@executable_path/../../../lib/" )
b b
(memq type '(gracketcgc gracket3m)))) (memq type '(gracketcgc gracket3m gracketcs))))
binaries types))] binaries types))]
[(unix) [(unix)
(for-each (lambda (b type) (for-each (lambda (b type)
@ -645,14 +661,19 @@
(error 'assemble-distribution (error 'assemble-distribution
"file is an original PLT executable, not a stub binary: ~e" "file is an original PLT executable, not a stub binary: ~e"
b))) b)))
(let ([3m? (equal? (list-ref m 4) #"3")]) (let ([variant (case (list-ref m 4)
[(#"3") '3m]
[(#"s") 'cs]
[else 'cgc])])
(if (equal? (caddr m) #"r") (if (equal? (caddr m) #"r")
(if 3m? (case variant
'gracket3m [(3m) 'gracket3m]
'gracketcgc) [(cs) 'gracketcs]
(if 3m? [else 'gracketcgc])
'racket3m (case variant
'racketcgc)))) [(3m) 'racket3m]
[(cs) 'racketcs]
[else 'racketcgc]))))
(error 'assemble-distribution (error 'assemble-distribution
"file is not a PLT executable: ~e" "file is not a PLT executable: ~e"
b)))))) b))))))

8
racket/collects/compiler/embed.rkt
View File

@ -60,7 +60,7 @@
#:cmdline (listof string?) #:cmdline (listof string?)
#:gracket? any/c #:gracket? any/c
#:mred? any/c #:mred? any/c
#:variant (or/c '3m 'cgc) #:variant (or/c '3m 'cgc 'cs)
#:aux (listof (cons/c symbol? any/c)) #:aux (listof (cons/c symbol? any/c))
#:collects-path (or/c #f #:collects-path (or/c #f
path-string? path-string?
@ -1720,7 +1720,8 @@
(lambda () (find-cmdline (lambda () (find-cmdline
"configuration" "configuration"
#"cOnFiG:")))] #"cOnFiG:")))]
[typepos (and (or mred? (eq? variant '3m)) [typepos (and (or mred? (or (eq? variant '3m)
(eq? variant 'cs)))
(with-input-from-file dest-exe (with-input-from-file dest-exe
(lambda () (find-cmdline (lambda () (find-cmdline
"exeuctable type" "exeuctable type"
@ -1743,6 +1744,9 @@
(when (eq? variant '3m) (when (eq? variant '3m)
(file-position out (+ typepos 15)) (file-position out (+ typepos 15))
(write-bytes #"3" out)) (write-bytes #"3" out))
(when (eq? variant 'cs)
(file-position out (+ typepos 15))
(write-bytes #"s" out))
(flush-output out)) (flush-output out))
(file-position out (+ numpos 7)) (file-position out (+ numpos 7))
(write-bytes #"!" out) (write-bytes #"!" out)

763
racket/collects/compiler/private/cm-minimal.rkt Normal file
View File

@ -0,0 +1,763 @@
#lang racket/base
(require syntax/private/modcode-noctc
syntax/private/modresolve-noctc
syntax/modread
setup/private/dirs
racket/file
racket/list
racket/path
racket/promise
openssl/sha1
setup/collects
compiler/compilation-path
compiler/private/dep)
(provide make-compilation-manager-load/use-compiled-handler
managed-compile-zo
make-caching-managed-compile-zo
trust-existing-zos
manager-compile-notify-handler
manager-skip-file-handler
manager-trace-handler
get-file-sha1
get-compiled-file-sha1
with-compile-output
managed-compiled-context-key
make-compilation-context-error-display-handler
parallel-lock-client
install-module-hashes!
current-path->mode)
(module+ cm-internal
(provide try-file-time
rkt->ss
get-source-sha1))
(define current-path->mode (make-parameter #f))
(define cm-logger (make-logger 'compiler/cm (current-logger)))
(define (default-manager-trace-handler str)
(when (log-level? cm-logger 'debug)
(log-message cm-logger 'debug str (current-inexact-milliseconds))))
(struct compile-event (timestamp path action) #:prefab)
(define (log-compile-event path action)
(when (log-level? cm-logger 'info 'compiler/cm)
(log-message cm-logger 'info (format "~a~a: ~a" (get-indent-string) action path)
(compile-event (current-inexact-milliseconds) path action))))
(define manager-compile-notify-handler (make-parameter void))
(define manager-trace-handler (make-parameter default-manager-trace-handler))
(define indent (make-parameter 0))
(define trust-existing-zos (make-parameter #f))
(define manager-skip-file-handler (make-parameter (λ (x) #f)))
(define depth (make-parameter 0))
(define parallel-lock-client (make-parameter #f))
(define managed-compiled-context-key (gensym))
(define (make-compilation-context-error-display-handler orig)
(lambda (str exn)
(define l (continuation-mark-set->list
(exn-continuation-marks exn)
managed-compiled-context-key))
(orig (if (null? l)
str
(apply
string-append
str
"\n compilation context...:"
(for/list ([i (in-list l)])
(format "\n ~a" i))))
exn)))
(define (try-file-time p)
(let ([s (file-or-directory-modify-seconds p #f (lambda () #f))])
(and s
(if (eq? (use-compiled-file-check) 'modify-seconds)
s
0))))
(define (path*->collects-relative p)
(if (bytes? p)
(let ([q (path->collects-relative (bytes->path p))])
(if (path? q)
(path->bytes q)
q))
(path->collects-relative p)))
(define (collects-relative*->path p cache)
(if (bytes? p)
(bytes->path p)
(hash-ref! cache p (lambda () (collects-relative->path p)))))
(define (trace-printf fmt . args)
(let ([t (manager-trace-handler)])
(unless (or (eq? t void)
(and (equal? t default-manager-trace-handler)
(not (log-level? cm-logger 'debug))))
(t (string-append (get-indent-string)
(apply format fmt args))))))
(define (get-indent-string)
(build-string (indent)
(λ (x)
(if (and (= 2 (modulo x 3))
(not (= x (- (indent) 1))))
#\|
#\space))))
(define (get-deps code path)
(define ht
(let loop ([code code] [ht (hash)])
(define new-ht
(for*/fold ([ht ht]) ([imports (in-list (module-compiled-imports code))]
[x (in-list (cdr imports))])
(let* ([r (resolve-module-path-index x path)]
[r (if (pair? r) (cadr r) r)])
(if (and (path? r)
(not (equal? path r))
(not (equal? path r))
(not (equal? path (rkt->ss r))))
(hash-set ht (path->bytes r) #t)
ht))))
(for*/fold ([ht new-ht]) ([non-star? (in-list '(#f #t))]
[subcode (in-list (module-compiled-submodules code non-star?))])
(loop subcode ht))))
(for/list ([k (in-hash-keys ht)]) k))
(define (get-compilation-path path->mode roots path)
(let-values ([(dir name) (get-compilation-dir+name path #:modes (list (path->mode path)) #:roots roots)])
(build-path dir name)))
(define (touch path)
(when (eq? 'modify-seconds (use-compiled-file-check))
(with-compiler-security-guard
(file-or-directory-modify-seconds
path
(current-seconds)
(lambda ()
(close-output-port (open-output-file path #:exists 'append)))))))
(define (try-delete-file path [noisy? #t])
;; Attempt to delete, but give up if it doesn't work:
(with-handlers ([exn:fail:filesystem? void])
(when noisy? (trace-printf "deleting ~a" path))
(with-compiler-security-guard (delete-file path))))
(define (compilation-failure path->mode roots path zo-name date-path reason)
(try-delete-file zo-name)
(trace-printf "failure"))
;; with-compile-output : path (output-port path -> alpha) -> alpha
(define (with-compile-output path proc)
(call-with-atomic-output-file
path
#:security-guard (pick-security-guard)
proc))
(define-syntax-rule
(with-compiler-security-guard expr)
(parameterize ([current-security-guard (pick-security-guard)])
expr))
(define compiler-security-guard (make-parameter #f))
(define (pick-security-guard)
(or (compiler-security-guard)
(current-security-guard)))
(define (get-source-sha1 p)
(with-handlers ([exn:fail:filesystem? (lambda (exn)
(and (path-has-extension? p #".rkt")
(get-source-sha1 (path-replace-extension p #".ss"))))])
(call-with-input-file* p sha1)))
(define (get-dep-sha1s deps up-to-date collection-cache read-src-syntax path->mode roots must-exist? seen)
(let ([l (for/fold ([l null]) ([dep (in-list deps)])
(and l
(let* ([ext? (external-dep? dep)]
[p (collects-relative*->path (dep->encoded-path dep) collection-cache)])
(cond
[ext? (let ([v (get-source-sha1 p)])
(cond
[v (cons (cons (delay v) dep) l)]
[must-exist? (error 'cm "cannot find external-dependency file: ~v" p)]
[else #f]))]
[(or (hash-ref up-to-date (simple-form-path p) #f)
;; Use `compile-root' with `sha1-only?' as #t:
(compile-root path->mode roots p up-to-date collection-cache read-src-syntax #t seen))
=> (lambda (sh)
(cons (cons (cdr sh) dep) l))]
[must-exist?
;; apparently, we're forced to use the source of the module,
;; so compute a sha1 from it instead of the bytecode
(cons (cons (get-source-sha1 p) dep) l)]
[else #f]))))])
(and l
(let ([p (open-output-string)]
[l (map (lambda (v)
(let ([sha1 (force (car v))]
[dep (cdr v)])
(unless sha1
(error 'cm "no SHA-1 for dependency: ~s" dep))
(cons sha1 dep)))
l)])
;; sort by sha1s so that order doesn't matter
(write (sort l string<? #:key car) p)
;; compute one hash from all hashes
(sha1 (open-input-bytes (get-output-bytes p)))))))
(define (write-deps code path->mode roots path src-sha1
external-deps external-module-deps reader-deps
up-to-date collection-cache read-src-syntax)
(let ([dep-path (path-add-extension (get-compilation-path path->mode roots path) #".dep")]
[deps (remove-duplicates (append (get-deps code path)
external-module-deps ; can create cycles if misused!
reader-deps))]
[external-deps (remove-duplicates external-deps)])
(define (path*->collects-relative/maybe-indirect dep)
(if (and (pair? dep) (eq? 'indirect (car dep)))
(cons 'indirect (path*->collects-relative (cdr dep)))
(path*->collects-relative dep)))
(with-compile-output dep-path
(lambda (op tmp-path)
(let ([deps (append
(map path*->collects-relative/maybe-indirect deps)
(map (lambda (x)
(define d (path*->collects-relative/maybe-indirect x))
(if (and (pair? d) (eq? 'indirect d))
(cons 'indirect (cons 'ext (cdr d)))
(cons 'ext d)))
external-deps))])
(write (list* (version)
(cons (or src-sha1 (get-source-sha1 path))
(get-dep-sha1s deps up-to-date collection-cache read-src-syntax path->mode roots #t #hash()))
(sort deps s-exp<?))
op)
(newline op))))))
(define (s-exp<? a b)
(string<? (format "~s" a) (format "~s" b)))
(define (format-time sec)
(let ([d (seconds->date sec)])
(format "~a-~a-~a ~a:~a:~a"
(date-year d) (date-month d) (date-day d)
(date-hour d) (date-minute d) (date-second d))))
(define (verify-times ss-name zo-name)
(when (eq? 'modify-seconds (use-compiled-file-check))
(define ss-sec (file-or-directory-modify-seconds ss-name))
(define zo-sec (try-file-time zo-name))
(cond [(not ss-sec) (error 'compile-zo "internal error")]
[(not zo-sec) (error 'compile-zo "failed to create .zo file (~a) for ~a"
zo-name ss-name)]
[(< zo-sec ss-sec) (error 'compile-zo
"date for newly created .zo file (~a @ ~a) ~
is before source-file date (~a @ ~a)~a"
zo-name (format-time zo-sec)
ss-name (format-time ss-sec)
(if (> ss-sec (current-seconds))
", which appears to be in the future"
""))])))
(define-struct ext-reader-guard (proc top)
#:property prop:procedure (struct-field-index proc))
(define-struct file-dependency (path module?) #:prefab)
(define-struct (file-dependency/options file-dependency) (table) #:prefab)
(define (compile-zo* path->mode roots path src-sha1 read-src-syntax orig-zo-name up-to-date collection-cache)
;; The `path' argument has been converted to .rkt or .ss form,
;; as appropriate.
;; External dependencies registered through reader guard and
;; accomplice-logged events:
(define external-deps null)
(define external-module-deps null)
(define reader-deps null)
(define deps-sema (make-semaphore 1))
(define done-key (gensym))
(define (external-dep! p module? indirect?)
(define bstr (path->bytes p))
(define dep (if indirect?
(cons 'indirect bstr)
bstr))
(if module?
(set! external-module-deps (cons dep external-module-deps))
(set! external-deps (cons dep external-deps))))
(define (reader-dep! p)
(call-with-semaphore
deps-sema
(lambda ()
(set! reader-deps (cons (path->bytes p) reader-deps)))))
;; Set up a logger to receive and filter accomplice events:
(define accomplice-logger (make-logger #f (current-logger)
;; Don't propoagate 'cm-accomplice events, so that
;; enclosing compilations don't see events intended
;; for this one:
'none 'cm-accomplice
;; Propagate everything else:
'debug))
(define receiver (make-log-receiver accomplice-logger 'info 'cm-accomplice))
;; Compile the code:
(define code
(parameterize ([current-reader-guard
(let* ([rg (current-reader-guard)]
[rg (if (ext-reader-guard? rg)
(ext-reader-guard-top rg)
rg)])
(make-ext-reader-guard
(lambda (d)
;; Start by calling the top installed guard to
;; transform the module path, avoiding redundant
;; dependencies by avoiding accumulation of these
;; guards.
(let ([d (rg d)])
(when (module-path? d)
(let* ([p (resolved-module-path-name
(module-path-index-resolve
(module-path-index-join d #f)))]
[p (if (pair? p)
;; Create a dependency only if
;; the corresponding submodule is
;; declared:
(if (module-declared? d #t)
(car p)
#f)
p)])
(when (path? p) (reader-dep! p))))
d))
rg))]
[current-logger accomplice-logger])
(with-continuation-mark
managed-compiled-context-key
path
(get-module-code path (path->mode path) compile
(lambda (a b) #f) ; extension handler
#:source-reader read-src-syntax))))
(define dest-roots (list (car roots)))
(define-values (code-dir code-name)
(get-compilation-dir+name path #:modes (list (path->mode path)) #:roots dest-roots))
(define zo-name
;; If we have multiple roots, make sure that compilation uses the first one
(if (pair? (cdr roots))
(build-path code-dir (path-add-suffix code-name #".zo"))
orig-zo-name))
;; Get all accomplice data:
(let loop ()
(let ([l (sync/timeout 0 receiver)])
(when l
(when (and (eq? (vector-ref l 0) 'info)
(file-dependency? (vector-ref l 2))
(path? (file-dependency-path (vector-ref l 2))))
(external-dep! (file-dependency-path (vector-ref l 2))
(file-dependency-module? (vector-ref l 2))
(and (file-dependency/options? (vector-ref l 2))
(hash-ref (file-dependency/options-table (vector-ref l 2))
'indirect
#f))))
(loop))))
;; Write the code and dependencies:
(when code
(with-compiler-security-guard (make-directory* code-dir))
(with-compile-output zo-name
(lambda (out tmp-name)
(with-handlers ([exn:fail?
(lambda (ex)
(close-output-port out)
(compilation-failure path->mode dest-roots path zo-name #f
(exn-message ex))
(raise ex))])
(parameterize ([current-write-relative-directory
(let* ([dir
(let-values ([(base name dir?) (split-path path)])
(if (eq? base 'relative)
(current-directory)
(path->complete-path base (current-directory))))]
[collects-dir (find-collects-dir)]
[e-dir (explode-path dir)]
[e-collects-dir (explode-path collects-dir)])
(if (and ((length e-dir) . > . (length e-collects-dir))
(for/and ([a (in-list e-dir)]
[b (in-list e-collects-dir)])
(equal? a b)))
;; `dir' extends `collects-dir':
(cons dir collects-dir)
;; `dir' doesn't extend `collects-dir':
dir))])
(let ([b (open-output-bytes)])
;; Write bytecode into string
(write code b)
;; Compute SHA1 over modules within bytecode
(let* ([s (get-output-bytes b)])
(install-module-hashes! s)
;; Write out the bytecode with module hash
(write-bytes s out)))))
;; redundant, but close as early as possible:
(close-output-port out)
;; Note that we check time and write .deps before returning from
;; with-compile-output...
(verify-times path tmp-name)
(write-deps code path->mode dest-roots path src-sha1
external-deps external-module-deps reader-deps
up-to-date collection-cache read-src-syntax)))
(trace-printf "wrote zo file: ~a" zo-name)))
(define (install-module-hashes! s [start 0] [len (bytes-length s)])
(define vlen (bytes-ref s (+ start 2)))
(define mode (integer->char (bytes-ref s (+ start 3 vlen))))
(case mode
[(#\B)
;; A linklet bundle:
(define h (sha1-bytes (open-input-bytes (if (and (zero? start)
(= len (bytes-length s)))
s
(subbytes s start (+ start len))))))
;; Write sha1 for bundle hash:
(bytes-copy! s (+ start 4 vlen) h)]
[(#\D)
;; A linklet directory. The format starts with <count>,
;; and then it's <count> records of the format:
;; <name-len> <name-bytes> <bund-pos> <bund-len> <left-pos> <right-pos>
(define (read-num rel-pos)
(define pos (+ start rel-pos))
(integer-bytes->integer s #t #f pos (+ pos 4)))
(define count (read-num (+ 4 vlen)))
(for/fold ([pos (+ 8 vlen)]) ([i (in-range count)])
(define pos-pos (+ pos 4 (read-num pos)))
(define bund-start (read-num pos-pos))
(define bund-len (read-num (+ pos-pos 4)))
(install-module-hashes! s (+ start bund-start) bund-len)
(+ pos-pos 16))
(void)]
[else
;; ?? unknown mode
(void)]))
(define (actual-source-path path)
(if (file-exists? path)
path
(let ([alt-path (rkt->ss path)])
(if (file-exists? alt-path)
alt-path
path))))
(define (maybe-compile-zo sha1-only? deps path->mode roots path orig-path read-src-syntax up-to-date collection-cache seen)
(let ([actual-path (actual-source-path orig-path)])
(unless sha1-only?
((manager-compile-notify-handler) actual-path)
(trace-printf "maybe-compile-zo starting ~a" actual-path))
(begin0
(parameterize ([indent (+ 2 (indent))])
(let* ([zo-name (path-add-extension (get-compilation-path path->mode roots path) #".zo")]
[zo-exists? (file-exists? zo-name)])
(if (and zo-exists? (trust-existing-zos))
(begin
(trace-printf "trusting: ~a" zo-name)
(touch zo-name)
#f)
(let ([src-sha1 (and zo-exists?
deps
(cadr deps)
(get-source-sha1 path))])
(if (and zo-exists?
src-sha1
(equal? src-sha1 (and (pair? (cadr deps))
(caadr deps)))
(equal? (get-dep-sha1s (cddr deps) up-to-date collection-cache read-src-syntax path->mode roots #f seen)
(cdadr deps)))
(begin
(trace-printf "hash-equivalent: ~a" zo-name)
(touch zo-name)
#f)
((if sha1-only? values (lambda (build) (build) #f))
(lambda ()
(let* ([lc (parallel-lock-client)]
[_ (when lc (log-compile-event path 'locking))]
[locked? (and lc (lc 'lock zo-name))]
[ok-to-compile? (or (not lc) locked?)])
(dynamic-wind
(lambda () (void))
(lambda ()
(when ok-to-compile?
(log-compile-event path 'start-compile)
(when zo-exists? (try-delete-file zo-name #f))
(trace-printf "compiling ~a" actual-path)
(parameterize ([depth (+ (depth) 1)])
(with-handlers
([exn:get-module-code?
(lambda (ex)
(compilation-failure path->mode roots path zo-name
(exn:get-module-code-path ex)
(exn-message ex))
(raise ex))])
(compile-zo* path->mode roots path src-sha1 read-src-syntax zo-name up-to-date collection-cache)))
(trace-printf "compiled ~a" actual-path)))
(lambda ()
(log-compile-event path (if (or (not lc) locked?) 'finish-compile 'already-done))
(when locked?
(lc 'unlock zo-name))))))))))))
(unless sha1-only?
(trace-printf "maybe-compile-zo finished ~a" actual-path)))))
(define (get-compiled-time path->mode roots path)
(define-values (dir name) (get-compilation-dir+name path #:modes (list (path->mode path)) #:roots roots))
(or (try-file-time (build-path dir "native" (system-library-subpath)
(path-add-extension name (system-type
'so-suffix))))
(try-file-time (build-path dir (path-add-extension name #".zo")))))
(define (try-file-sha1 path dep-path)
(with-module-reading-parameterization
(lambda ()
(with-handlers ([exn:fail:filesystem? (lambda (exn) #f)])
(string-append
(call-with-input-file* path sha1)
(with-handlers ([exn:fail:filesystem? (lambda (exn) "")])
(call-with-input-file* dep-path (lambda (p) (cdadr (read p))))))))))
(define (get-compiled-sha1 path->mode roots path)
(define-values (dir name) (get-compilation-dir+name path #:modes (list (path->mode path)) #:roots roots))
(let ([dep-path (build-path dir (path-add-extension name #".dep"))])
(or (try-file-sha1 (build-path dir "native" (system-library-subpath)
(path-add-extension name (system-type
'so-suffix)))
dep-path)
(try-file-sha1 (build-path dir (path-add-extension name #".zo"))
dep-path)
"")))
(define (different-source-sha1-and-dep-recorded path deps)
(define src-hash (get-source-sha1 path))
(define recorded-hash (and (pair? (cadr deps))
(caadr deps)))
(if (equal? src-hash recorded-hash)
#f
(list src-hash recorded-hash)))
(define (rkt->ss p)
(if (path-has-extension? p #".rkt")
(path-replace-extension p #".ss")
p))
(define (compile-root path->mode roots path0 up-to-date collection-cache read-src-syntax sha1-only? seen)
(define orig-path (simple-form-path path0))
(define (read-deps path)
(with-handlers ([exn:fail:filesystem? (lambda (ex) (list (version) '#f))])
(with-module-reading-parameterization
(lambda ()
(call-with-input-file*
(path-add-extension (get-compilation-path path->mode roots path) #".dep")
read)))))
(define (do-check)
(let* ([main-path orig-path]
[alt-path (rkt->ss orig-path)]
[main-path-time (try-file-time main-path)]
[alt-path-time (and (not main-path-time)
(not (eq? alt-path main-path))
(try-file-time alt-path))]
[path (if alt-path-time alt-path main-path)]
[path-time (or main-path-time alt-path-time)]
[path-zo-time (get-compiled-time path->mode roots path)])
(cond
[(hash-ref seen path #f)
(error 'compile-zo
"dependency cycle\n involves module: ~a"
path)
#f]
[(not path-time)
(trace-printf "~a does not exist" orig-path)
(or (hash-ref up-to-date orig-path #f)
(let ([stamp (cons (or path-zo-time +inf.0)
(delay (get-compiled-sha1 path->mode roots path)))])
(hash-set! up-to-date main-path stamp)
(unless (eq? main-path alt-path)
(hash-set! up-to-date alt-path stamp))
stamp))]
[else
(let ([deps (read-deps path)]
[new-seen (hash-set seen path #t)])
(define build
(cond
[(not (and (pair? deps) (equal? (version) (car deps))))
(lambda ()
(trace-printf "newer version...")
(maybe-compile-zo #f #f path->mode roots path orig-path read-src-syntax up-to-date collection-cache new-seen))]
[(> path-time (or path-zo-time -inf.0))
(trace-printf "newer src... ~a > ~a" path-time path-zo-time)
;; If `sha1-only?', then `maybe-compile-zo' returns a #f or thunk:
(maybe-compile-zo sha1-only? deps path->mode roots path orig-path read-src-syntax up-to-date collection-cache new-seen)]
[(different-source-sha1-and-dep-recorded path deps)
=> (lambda (difference)
(trace-printf "different src hash... ~a" difference)
;; If `sha1-only?', then `maybe-compile-zo' returns a #f or thunk:
(maybe-compile-zo sha1-only? deps path->mode roots path orig-path read-src-syntax up-to-date collection-cache new-seen))]
[(ormap-strict
(lambda (p)
(define ext? (external-dep? p))
(define d (collects-relative*->path (dep->encoded-path p) collection-cache))
(define t
(if ext?
(cons (or (try-file-time d) +inf.0) #f)
(compile-root path->mode roots d up-to-date collection-cache read-src-syntax #f new-seen)))
(and t
(car t)
(> (car t) (or path-zo-time -inf.0))
(begin (trace-printf "newer: ~a (~a > ~a)..."
d (car t) path-zo-time)
#t)))
(cddr deps))
;; If `sha1-only?', then `maybe-compile-zo' returns a #f or thunk:
(maybe-compile-zo sha1-only? deps path->mode roots path orig-path read-src-syntax up-to-date collection-cache new-seen)]
[else #f]))
(cond
[(and build sha1-only?) #f]
[else
(when build (build))
(let ([stamp (cons (or (get-compiled-time path->mode roots path) +inf.0)
(delay (get-compiled-sha1 path->mode roots path)))])
(hash-set! up-to-date main-path stamp)
(unless (eq? main-path alt-path)
(hash-set! up-to-date alt-path stamp))
stamp)]))])))
(or (hash-ref up-to-date orig-path #f)
(let ([v ((manager-skip-file-handler) orig-path)])
(and v
(hash-set! up-to-date orig-path v)
v))
(begin (trace-printf "checking: ~a" orig-path)
(do-check))))
(define (ormap-strict f l)
(cond
[(null? l) #f]
[else
(define a (f (car l)))
(define b (ormap-strict f (cdr l)))
(or a b)]))
(define (managed-compile-zo zo [read-src-syntax read-syntax] #:security-guard [security-guard #f])
((make-caching-managed-compile-zo read-src-syntax #:security-guard security-guard) zo))
(define (make-caching-managed-compile-zo [read-src-syntax read-syntax] #:security-guard [security-guard #f])
(let ([cache (make-hash)]
[collection-cache (make-hash)])
(lambda (src)
(parameterize ([current-load/use-compiled
(make-compilation-manager-load/use-compiled-handler/table
cache
collection-cache
#f
#:security-guard security-guard)]
[error-display-handler
(make-compilation-context-error-display-handler
(error-display-handler))])
(compile-root (or (current-path->mode)
(let ([mode (car (use-compiled-file-paths))])
(λ (pth) mode)))
(current-compiled-file-roots)
(path->complete-path src)
cache
collection-cache
read-src-syntax
#f
#hash())
(void)))))
(define (make-compilation-manager-load/use-compiled-handler [delete-zos-when-rkt-file-does-not-exist? #f]
#:security-guard
[security-guard #f])
(make-compilation-manager-load/use-compiled-handler/table (make-hash) (make-hash)
delete-zos-when-rkt-file-does-not-exist?
#:security-guard security-guard))
(define (make-compilation-manager-load/use-compiled-handler/table cache collection-cache
delete-zos-when-rkt-file-does-not-exist?
#:security-guard [security-guard #f])
(define cp->m (current-path->mode))
(define modes (use-compiled-file-paths))
(when (and (not cp->m) (null? modes))
(raise-mismatch-error 'make-compilation-manager-...
"use-compiled-file-paths is '() and current-path->mode is #f"))
(define path->mode (or cp->m (λ (p) (car modes))))
(let ([orig-eval (current-eval)]
[orig-load (current-load)]
[orig-registry (namespace-module-registry (current-namespace))]
[default-handler (current-load/use-compiled)]
[roots (current-compiled-file-roots)])
(define (compilation-manager-load-handler path mod-name)
(cond [(or (not mod-name)
;; Don't trigger compilation if we're not supposed to work with source:
(and (pair? mod-name)
(not (car mod-name))))
(trace-printf "skipping: ~a mod-name ~s" path mod-name)]
[(not (or (file-exists? path)
(let ([p2 (rkt->ss path)])
(and (not (eq? path p2))
(file-exists? p2)))))
(trace-printf "skipping: ~a file does not exist" path)
(when delete-zos-when-rkt-file-does-not-exist?
(define to-delete (path-add-extension (get-compilation-path path->mode roots path) #".zo"))
(when (file-exists? to-delete)
(trace-printf "deleting: ~s" to-delete)
(with-compiler-security-guard (delete-file to-delete))))]
[(if cp->m
(not (equal? (current-path->mode) cp->m))
(let ([current-cfp (use-compiled-file-paths)])
(or (null? current-cfp)
(not (equal? (car current-cfp) (car modes))))))
(if cp->m
(trace-printf "skipping: ~a current-path->mode changed; current value ~s, original value was ~s"
path (current-path->mode) cp->m)
(trace-printf "skipping: ~a use-compiled-file-paths's first element changed; current value ~s, first element was ~s"
path
(use-compiled-file-paths)
(car modes)))]
[(not (equal? roots (current-compiled-file-roots)))
(trace-printf "skipping: ~a current-compiled-file-roots changed; current value ~s, original was ~s"
path
(current-compiled-file-roots)
roots)]
[(not (eq? compilation-manager-load-handler
(current-load/use-compiled)))
(trace-printf "skipping: ~a current-load/use-compiled changed ~s"
path (current-load/use-compiled))]
[(not (eq? orig-eval (current-eval)))
(trace-printf "skipping: ~a orig-eval ~s current-eval ~s"
path orig-eval (current-eval))]
[(not (eq? orig-load (current-load)))
(trace-printf "skipping: ~a orig-load ~s current-load ~s"
path orig-load (current-load))]
[(not (eq? orig-registry
(namespace-module-registry (current-namespace))))
(trace-printf "skipping: ~a orig-registry ~s current-registry ~s"
path orig-registry
(namespace-module-registry (current-namespace)))]
[else
(trace-printf "processing: ~a" path)
(parameterize ([compiler-security-guard security-guard])
(compile-root path->mode roots path cache collection-cache read-syntax #f #hash()))
(trace-printf "done: ~a" path)])
(default-handler path mod-name))
(when (null? roots)
(raise-mismatch-error 'make-compilation-manager-...
"empty current-compiled-file-roots list: "
roots))
compilation-manager-load-handler))
;; Exported:
(define (get-compiled-file-sha1 path)
(try-file-sha1 path (path-replace-extension path #".dep")))
(define (get-file-sha1 path)
(get-source-sha1 path))

10
racket/collects/compiler/private/elf.rkt
View File

@ -258,6 +258,14 @@
(section-size s))) (section-size s)))
s))) s)))
;; The `get-data` function takes an offset and must return
;; (values bytes any1 any2)
;; The result of `add-racket-section` is either
;; (values #f #f #f #f) ; => not an ELF file
;; or
;; (values start-pos end-pos any1 any2)
;; where `any1` and `any2` are return through
;; from `get-data`.
(define (add-racket-section src-file dest-file section-name get-data) (define (add-racket-section src-file dest-file section-name get-data)
(call-with-input-file* (call-with-input-file*
src-file src-file
@ -275,7 +283,7 @@
void))))))) void)))))))
(define (expand-elf in dest-file (define (expand-elf in dest-file
;; Current state parted from `in`: ;; Current state parsed from `in`:
elf sections programs str-section strs total-size elf sections programs str-section strs total-size
;; New state: ;; New state:
section-name ; #f or name of new section section-name ; #f or name of new section

11
racket/collects/compiler/private/macfw.rkt
View File

@ -23,16 +23,17 @@
dest)]) dest)])
(for-each (lambda (p) (for-each (lambda (p)
(let* ([orig (get-current-framework-path dest p)] (let* ([orig (get-current-framework-path dest p)]
[3m (if (and orig (regexp-match #rx"_3m" orig)) [variant (cond
"_3m" [(and orig (regexp-match #rx"_3m" orig)) "_3m"]
"")] [(and orig (regexp-match #rx"_CS" orig)) "_CS"]
[else ""])]
[old-path (or orig [old-path (or orig
(format "~a.framework/Versions/~a~a/~a" p (version) 3m p))] (format "~a.framework/Versions/~a~a/~a" p (version) variant p))]
[new-path (if as-given? [new-path (if as-given?
(format "~a" fw-path) (format "~a" fw-path)
(format "~a~a.framework/Versions/~a~a/~a" (format "~a~a.framework/Versions/~a~a/~a"
fw-path fw-path
p (version) 3m p))]) p (version) variant p))])
(get/set-dylib-path dest (get/set-dylib-path dest
(byte-regexp (byte-regexp
(bytes-append (bytes-append

11
racket/collects/compiler/private/mach-o.rkt
View File

@ -56,7 +56,8 @@
;; generally retain the location in a file of an offset that needs to ;; generally retain the location in a file of an offset that needs to
;; be updated. ;; be updated.
;; ;;
(define (add-plt-segment file segdata) (define (add-plt-segment file segdata
#:name [segment-name #"__PLTSCHEME"])
(let-values ([(p out) (open-input-output-file file #:exists 'update)]) (let-values ([(p out) (open-input-output-file file #:exists 'update)])
(dynamic-wind (dynamic-wind
void void
@ -136,7 +137,8 @@
[nreloc (read-ulong p)] [nreloc (read-ulong p)]
[flags (read-ulong p)]) [flags (read-ulong p)])
(when ((+ offset vmsz) . > . (+ cmdssz (if (equal? exe-id #xFeedFacf) 32 28))) (when ((+ offset vmsz) . > . (+ cmdssz (if (equal? exe-id #xFeedFacf) 32 28)))
(when (offset . < . min-used) (when (and (positive? offset)
(offset . < . min-used))
;; (printf " new min!\n") ;; (printf " new min!\n")
(set! min-used offset))) (set! min-used offset)))
;; (printf " ~s,~s 0x~x 0x~x\n" seg sect offset vmsz) ;; (printf " ~s,~s 0x~x 0x~x\n" seg sect offset vmsz)
@ -276,7 +278,7 @@
(file-position out link-edit-pos) (file-position out link-edit-pos)
(write-ulong (if link-edit-64? #x19 1) out) ; LC_SEGMENT[_64] (write-ulong (if link-edit-64? #x19 1) out) ; LC_SEGMENT[_64]
(write-ulong new-cmd-sz out) (write-ulong new-cmd-sz out)
(display #"__PLTSCHEME\0\0\0\0\0" out) (display (pad-segment-name segment-name) out)
((if link-edit-64? write-xulong write-ulong) out-addr out) ((if link-edit-64? write-xulong write-ulong) out-addr out)
((if link-edit-64? write-xulong write-ulong) outlen out) ((if link-edit-64? write-xulong write-ulong) outlen out)
((if link-edit-64? write-xulong write-ulong) out-offset out) ((if link-edit-64? write-xulong write-ulong) out-offset out)
@ -378,6 +380,9 @@
(close-input-port p) (close-input-port p)
(close-output-port out))))) (close-output-port out)))))
(define (pad-segment-name bs)
(bytes-append bs (make-bytes (- 16 (bytes-length bs)))))
(define (fix-offset p pos out d base delta) (define (fix-offset p pos out d base delta)
(when (and out (not (zero? delta))) (when (and out (not (zero? delta)))
(file-position p (+ pos d)) (file-position p (+ pos d))

7
racket/collects/compiler/private/windlldir.rkt
View File

@ -1,11 +1,12 @@
(module windlldir racket/base (module windlldir racket/base
(require racket/port (require racket/port
racket/promise
"winutf16.rkt") "winutf16.rkt")
(provide update-dll-dir (provide update-dll-dir
get-current-dll-dir) get-current-dll-dir)
(define label (byte-regexp (bytes->utf-16-bytes #"dLl dIRECTORy:"))) (define label (delay/sync (byte-regexp (bytes->utf-16-bytes #"dLl dIRECTORy:"))))
(define max-dir-len (* 512 2)) ; sizeof(wchar_t) is 2 (define max-dir-len (* 512 2)) ; sizeof(wchar_t) is 2
(define (update-dll-dir dest path) (define (update-dll-dir dest path)
@ -17,7 +18,7 @@
(error 'update-dll-dir "path too long: ~e" path)) (error 'update-dll-dir "path too long: ~e" path))
(let ([m (with-input-from-file dest (let ([m (with-input-from-file dest
(lambda () (lambda ()
(regexp-match-positions label (current-input-port))))]) (regexp-match-positions (force label) (current-input-port))))])
(unless m (unless m
(error 'update-ddl-dir "cannot find DLL path in file: ~e" dest)) (error 'update-ddl-dir "cannot find DLL path in file: ~e" dest))
(with-output-to-file dest (with-output-to-file dest
@ -30,7 +31,7 @@
(define (get-current-dll-dir dest) (define (get-current-dll-dir dest)
(with-input-from-file dest (with-input-from-file dest
(lambda () (lambda ()
(unless (regexp-match label (current-input-port)) (unless (regexp-match (force label) (current-input-port))
(error 'get-current-dll-dir "cannot find DLL path in file: ~e" dest)) (error 'get-current-dll-dir "cannot find DLL path in file: ~e" dest))
(let ([p (make-limited-input-port (current-input-port) max-dir-len)]) (let ([p (make-limited-input-port (current-input-port) max-dir-len)])
(let ([m (regexp-match #rx#"(?:[^\0].|.[^\0])*" p)]) (let ([m (regexp-match #rx#"(?:[^\0].|.[^\0])*" p)])

3
racket/collects/data/bit-vector.rkt
View File

@ -155,7 +155,8 @@
for/bit-vector for/bit-vector
for*/bit-vector for*/bit-vector
bit-vector-copy bit-vector-copy
#f) #f
check-bitvector)
;; A bit vector is represented as bytes. ;; A bit vector is represented as bytes.
(serializable-struct bit-vector (words size) (serializable-struct bit-vector (words size)

39
racket/collects/db/private/sqlite3/ffi.rkt
View File

@ -39,14 +39,14 @@
(define-sqlite sqlite3_open (define-sqlite sqlite3_open
(_fun (filename ignored-flags) :: (_fun (filename ignored-flags) ::
(filename : _bytes) ((bytes-append filename #"\0") : _bytes)
(db : (_ptr o _sqlite3_database)) (db : (_ptr o _sqlite3_database))
-> (result : _int) -> (result : _int)
-> (values db result))) -> (values db result)))
(define-sqlite sqlite3_open_v2 (define-sqlite sqlite3_open_v2
(_fun (filename flags) :: (_fun (filename flags) ::
(filename : _bytes) ((bytes-append filename #"\0") : _bytes)
(db : (_ptr o _sqlite3_database)) (db : (_ptr o _sqlite3_database))
(flags : _int) (flags : _int)
(vfs : _pointer = #f) (vfs : _pointer = #f)
@ -63,23 +63,28 @@
(define (trim-and-copy-buffer buffer) (define (trim-and-copy-buffer buffer)
(let* ([buffer (string->bytes/utf-8 (string-trim #:left? #f buffer))] (let* ([buffer (string->bytes/utf-8 (string-trim #:left? #f buffer))]
[n (bytes-length buffer)] [n (bytes-length buffer)]
[rawcopy (malloc (add1 n) 'atomic-interior)] [rawcopy (malloc (add1 n) 'atomic-interior)])
[copy (make-sized-byte-string rawcopy n)]) (memcpy rawcopy buffer n)
(memcpy copy buffer n)
(ptr-set! rawcopy _byte n 0) (ptr-set! rawcopy _byte n 0)
copy)) rawcopy))
(define (c-string-length p)
(let loop ([i 0])
(if (zero? (ptr-ref p _byte i))
i
(loop (add1 i)))))
(define (points-to-end? tail sql-buffer) (define (points-to-end? tail sql-buffer)
(ptr-equal? tail (ptr-equal? tail
(ptr-add sql-buffer (bytes-length sql-buffer)))) (ptr-add sql-buffer (c-string-length sql-buffer))))
(define-sqlite sqlite3_prepare (define-sqlite sqlite3_prepare
(_fun (db sql) :: (_fun (db sql) ::
(db : _sqlite3_database) (db : _sqlite3_database)
(sql-buffer : _bytes = (trim-and-copy-buffer sql)) (sql-buffer : _gcpointer = (trim-and-copy-buffer sql))
((bytes-length sql-buffer) : _int) ((c-string-length sql-buffer) : _int)
(statement : (_ptr o _sqlite3_statement/null)) (statement : (_ptr o _sqlite3_statement/null))
(tail : (_ptr o _gcpointer)) ;; points into sql-buffer (atomic-interior) (tail : (_ptr o _pointer)) ;; points into sql-buffer (atomic-interior)
-> (result : _int) -> (result : _int)
-> (values result statement (and tail -> (values result statement (and tail
(not (points-to-end? tail sql-buffer)))))) (not (points-to-end? tail sql-buffer))))))
@ -87,11 +92,11 @@
(define-sqlite sqlite3_prepare_v2 (define-sqlite sqlite3_prepare_v2
(_fun (db sql) :: (_fun (db sql) ::
(db : _sqlite3_database) (db : _sqlite3_database)
(sql-buffer : _bytes = (trim-and-copy-buffer sql)) (sql-buffer : _gcpointer = (trim-and-copy-buffer sql))
((bytes-length sql-buffer) : _int) ((c-string-length sql-buffer) : _int)
;; bad prepare statements set statement to NULL, with no error reported ;; bad prepare statements set statement to NULL, with no error reported
(statement : (_ptr o _sqlite3_statement/null)) (statement : (_ptr o _sqlite3_statement/null))
(tail : (_ptr o _gcpointer)) ;; points into sql-buffer (atomic-interior) (tail : (_ptr o _pointer)) ;; points into sql-buffer (atomic-interior)
-> (result : _int) -> (result : _int)
-> (values result statement (and tail -> (values result statement (and tail
(not (points-to-end? tail sql-buffer))))) (not (points-to-end? tail sql-buffer)))))
@ -190,9 +195,11 @@
(define-sqlite sqlite3_column_blob (define-sqlite sqlite3_column_blob
(_fun (stmt : _sqlite3_statement) (_fun (stmt : _sqlite3_statement)
(col : _int) (col : _int)
-> (blob : _bytes) -> (blob : _pointer)
-> (let ([len (sqlite3_column_bytes stmt col)]) -> (let* ([len (sqlite3_column_bytes stmt col)]
(bytes-copy (make-sized-byte-string blob len))))) [bstr (make-bytes len)])
(memcpy bstr blob len)
bstr)))
;; ---------------------------------------- ;; ----------------------------------------

Some files were not shown because too many files have changed in this diff Show More