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"
(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
the catalog server with `raco pkg'.
the catalog server with `raco pkg`.
* Installers --- create installers for a variety of platforms by
farming out work to machines that run those platforms. This is the
way that Racket snapshots and releases are created, and you can
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
==================================
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.
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
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.
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
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'
again, which includes a `raco pkg update' step.
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`
again, which includes a `raco pkg update` step.
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
======================================
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
in "<dir>/bin", packages in "<dir>/share/racket/pkgs", documentation
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",
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.
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
path). Then, copy the content of "<dest-dir>" to the target root
"<dir>".
@ -102,33 +110,33 @@ More Instructions: Building Racket
==================================
The "racket" directory contains minimal Racket, which is just enough
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
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
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
`CONFIGURE_ARGS_qq="..."' to `make in-place' or `make
unix-style'. (The `_qq' suffix on the variable name is a convention
`CONFIGURE_ARGS_qq="..."` to `make in-place` or `make
unix-style`. (The `_qq` suffix on the variable name is a convention
that indicates that single- and double-quote marks are allowed in the
value.)
The "pkgs" directory contains packages that are tied to the Racket
core implementation and are therefore kept in the same Git
repository. A `make in-place' links to the package in-place, while
`make unix-style' copies packages out of "pkgs" to install them.
repository. A `make in-place` links to the package in-place, while
`make unix-style` copies packages out of "pkgs" to install them.
To install a subset of the packages in "pkgs", supply `PKGS' value to
`make'. For example,
To install a subset of the packages in "pkgs", supply `PKGS` value to
`make`. For example,
make PKGS="gui-lib readline-lib"
links only the "gui-lib" and "readline-lib" packages and their
dependencies. The default value of `PKGS' is "main-distribution
main-distribution-test". If you run `make' a second time, all
dependencies. The default value of `PKGS` is "main-distribution
main-distribution-test". If you run `make` a second time, all
previously installed packages remain installed and are updated, while
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
(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
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
(i.e., unless the "racket/etc/config.rktd" file exists). The
installation name affects, for example, the directory where
user-specific documentation is installed. Using `make' also sets the
default package scope to `installation', which means that
user-specific documentation is installed. Using `make` also sets the
default package scope to `installation`, which means that
packages are installed by default into the installation's space instead
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
a build, but not for the `raco setup' part. To control both the
makefile and the `raco setup' part, use
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
makefile and the `raco setup` part, use
make CPUS=<n>
which recurs with `make -j <n> JOB_OPTIONS="-j <n>"'. Setting `CPUS'
also works with `make unix-style'.
which recurs with `make -j <n> JOB_OPTIONS="-j <n>"`. Setting `CPUS`
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
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
`raco setup' should suffice.)
`raco setup` should suffice.)
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
==============================================
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
together.
@ -181,25 +214,25 @@ and follow the "README" there, which gives you more configuration
options.
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.
Minimal Racket does not require additional native libraries to run,
but under Windows, encoding-conversion, extflonum, and SSL
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
makefile variable and `PLT_SETUP_OPTIONS' as an environment variable
are passed on to the `raco setup' that is used to build minimal-Racket
libraries. See the documentation for `raco setup' for information on
On all platforms, fom the top-level makefile, `JOB_OPTIONS` as a
makefile variable and `PLT_SETUP_OPTIONS` as an environment variable
are passed on to the `raco setup` that is used to build minimal-Racket
libraries. See the documentation for `raco setup` for information on
the options.
For cross compilation, add configuration options to
`CONFIGURE_ARGS_qq="..."' as described in the "README" of
"racket/src", but also add a `PLAIN_RACKET=...' argument for the
`CONFIGURE_ARGS_qq="..."` as described in the "README" of
"racket/src", but also add a `PLAIN_RACKET=...` argument for the
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
cross-compilation mode is used and that any foreign libraries needed
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".
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
to the packages in "pkgs". A Unix-style build works that way: it
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
before the default package catalogs, specify the catalog's URL as the
`SRC_CATALOG' makefile variable:
`SRC_CATALOG` makefile variable:
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
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
--static-link ...'.
--static-link ...`.
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
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
packages. The configuration adjustment is made only if no
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
the content of "racket/share/pkgs" is not meant to be edited. To
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
`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.
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,
naturally, to create an installer for the server's platform.
GNU `make' is required on the server machine, `nmake' is required on
Windows client machines, and any `make' should work on other client
GNU `make` is required on the server machine, `nmake` is required on
Windows client machines, and any `make` should work on other client
machines.
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
hosts specified via CONFIG, and start/stop VirtualBox virtual machines
that act as client machines.
See
pkgs/distro-build-pkgs/distro-build-client/doc.txt
for a description of the site-configuration module and requirements on
client hosts.
See the documentation of the "distro-build" package for a description
of the site-configuration module and requirements on client hosts.
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".
The default CONFIG path is "build/site.rkt", so you could put your
configuration file there and omit the `CONFIG' argument to
`make'. Supply `CONFIG_MODE=...' to pass a configuration mode on to
your site-configuration module (accessible via the `current-mode'
parameter). Supply `CLEAN_MODE=--clean' to make the default `#:clean?'
configuration file there and omit the `CONFIG` argument to `make`. A
default configuration file is created there automatically. Supply
`CONFIG_MODE=...` to pass a configuration mode on to your
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
`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
`#:source?' configuration #t, and supply `VERSIONLESS_MODE=--version`
to make the default `#:versionless?' configuration #t.
`#:source?` configuration #t, and supply `VERSIONLESS_MODE=--version`
to make the default `#:versionless?` configuration #t.
A configuration file can specify the packages to include, host address
of the server, distribution name, installer directory, and
documentation search URL, but defaults can be provided as `make'
arguments via `PKGS', `SERVER' plus `SERVER_PORT` plus `SERVER_HOSTS`,
`DIST_NAME', `DIST_BASE', and `DIST_DIR', `DOC_SEARCH',
documentation search URL, but defaults can be provided as `make`
arguments via `PKGS`, `SERVER` plus `SERVER_PORT` plus `SERVER_HOSTS`,
`DIST_NAME`, `DIST_BASE`, and `DIST_DIR`, `DOC_SEARCH`,
respectively. The site configuration's top-level options for packages
and documentation search URL are used to configure the set of packages
that are available to client machines to include in installers.
@ -320,9 +350,9 @@ is
<dist-base>-<version>-<platform>-<dist-suffix>.<ext>
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",
-<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
platform-specific: ".sh" for Unix (including Linux), ".dmg" or ".pkg"
for Mac OS, and ".exe" for Windows.
@ -330,58 +360,58 @@ for Mac OS, and ".exe" for Windows.
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,
packages, a package catalog, and log files into a directory that is
suitable for access via a web server.
Supply the same `CONFIG=...' and `CONFIG_MODE=...' arguments for
`site' as for `installers'. The configuration file should have a
`#:dist-base-url' entry for the URL where installers and packages will
be made available; the `installers' target uses `#:dist-base-url' to
Supply the same `CONFIG=...` and `CONFIG_MODE=...` arguments for
`site` as for `installers`. The configuration file should have a
`#:dist-base-url` entry for the URL where installers and packages will
be made available; the `installers` target uses `#:dist-base-url` to
embed suitable configuration into the installers. Specifically,
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
others URLs will be constructed as relative to `#:dist-base-url'.
Note that `#:dist-base-url` should almost always end with "/", since
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.
Use the `site-from-installers' makefile target to perform the part of
`site' that happens after `installers' (i.e., to generate a `site'
Use the `site-from-installers` makefile target to perform the part of
`site` that happens after `installers` (i.e., to generate a `site`
from an already-generated set of installers).
Managing Snapshot Web Sites
---------------------------
The `snapshot-site' makefile target uses `site' (so supply the same
`CONFIG=...' and `CONFIG_MODE=...' arguments), and then treats the
The `snapshot-site` makefile target uses `site` (so supply the same
`CONFIG=...` and `CONFIG_MODE=...` arguments), and then treats the
resulting site as a snapshot with additional snapshot-management
tasks.
For snapshot management, the destination of the files generated for
`site' (as specified by `#:site-dest') should be within a directory of
snapshots. The configuration file can use `(current-stamp)' to get a
`site` (as specified by `#:site-dest`) should be within a directory of
snapshots. The configuration file can use `(current-stamp)` to get a
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.
Snapshot management includes creating an "index.html" file in the
snapshots directory (essentially a copy of the snapshot's own
"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).
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
around an already-generated site).
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.
Roughly, the steps are
@ -389,50 +419,50 @@ Roughly, the steps are
1. On the server machine:
make server PKGS="..."
See 1b below for more information on variables other than `PKGS'
that you can provide with `make'.
See 1b below for more information on variables other than `PKGS`
that you can provide with `make`.
2. On each client machine:
make client SERVER=... PKGS="..."
or
nmake win32-client SERVER=... PKGS="..."
See 2b below for more information on variables other than `SERVER'
and `PKGS' that you can provide with `make'.
See 2b below for more information on variables other than `SERVER`
and `PKGS` that you can provide with `make`.
In more detail:
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,
currently.)
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
`server-from-base' (i.e., steps 1a and 1b).
Alternatively, use the `server` target, which combines `base` and
`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.
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
"localhost" which listens only on the loopback device (for
security). Supply the empty string to listen on all
interfaces. Supply multiple addresses by separating them with a
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.
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
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
"http://pkgs.racket-lang.org".
@ -442,8 +472,8 @@ In more detail:
"README.txt" by default).
If you stop the server and want to restart it, use the
`built-package-server' makefile target instead of starting over
with the `server' target.
`built-package-server` makefile target instead of starting over
with the `server` target.
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.
The `client' (or `win32-client') target of the makefile will do
The `client` (or `win32-client`) target of the makefile will do
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
avoids the need to specify `SERVER_HOSTS' when starting the
server in step 1b. Also, provide `SERVER_PORT' if an alternate
avoids the need to specify `SERVER_HOSTS` when starting the
server in step 1b. Also, provide `SERVER_PORT` if an alternate
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,
`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
installation.
Alternatively, use the `client' target, which combines `base' and
`client-from-base' (i.e., steps 2a and 2b).
Alternatively, use the `client` target, which combines `base` and
`client-from-base` (i.e., steps 2a and 2b).
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
"--release" to `make'. A release installer has slightly different
To create a release installer, provide `RELEASE_MODE` as
"--release" to `make`. A release installer has slightly different
defaults that are suitable for infrequently updated release
installations, as opposed to frequently updated snapshot
installations.
To create a source archive, provide `SOURCE_MODE' as "--source"
to `make'.
To create a source archive, provide `SOURCE_MODE` as "--source"
to `make`.
To create an archive that omits the version number and also omit
and version number in installer paths, provide `VERSIONLESS_MODE' as
"--versionless" to `make'.
and version number in installer paths, provide `VERSIONLESS_MODE` as
"--versionless" to `make`.
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
version number is automatically added for various contexts.
To change the base name of the installer file, provide `DIST_BASE'
to `make'. The default is "racket".
To change the base name of the installer file, provide `DIST_BASE`
to `make`. The default is "racket".
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
identifier for a variant of Linux, provide `DIST_SUFFIX' to
`make'. The default is "", which omits the prefix and its
identifier for a variant of Linux, provide `DIST_SUFFIX` to
`make`. The default is "", which omits the prefix and its
preceding hyphen.
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.
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
that the default catalogs should be used. The "_q" in the
variable name indicates that its value can include double quotes
(but not single quotes) --- which are needed to specify an empty
string, for example.
To select a "README" file for the client, provide `README' to
`make'. The `README' value is used as a file name to download
To select a "README" file for the client, provide `README` to
`make`. The `README` value is used as a file name to download
from the server.
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
which the signing certificate is associated. Set `MAC_PKG_MODE'
For a Mac OS installer, set `SIGN_IDENTITY` as the name to
which the signing certificate is associated. Set `MAC_PKG_MODE`
to "--mac-pkg" to create a ".pkg" installer instead of a ".dmg"
image.
For a Windows installer, set `OSSLSIGNCODE_ARGS_BASE64` as a
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
others.
The `SERVER_CATALOG_PATH' and `SERVER_COLLECTS_PATH' makefile
variables specify paths at `SERVER' plus `SERVER_PORT' to access
The `SERVER_CATALOG_PATH` and `SERVER_COLLECTS_PATH` makefile
variables specify paths at `SERVER` plus `SERVER_PORT` to access
the package catalog and pre-built "collects" tree needed for a
client, but those paths should be empty for a server started with
`make server', and they are used mainly by `make
client-from-site' (described below).
`make server`, and they are used mainly by `make
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
installer's name is added to the end of the URL, or leave as
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
its filename in "build/installers/table.rktd".
If you provide `JOB_OPTIONS=...' for either a client or server build,
the options are used both for `raco setup' and `raco pkg
install'. Normally, `JOB_OPTIONS' is used to control parallelism.
If you provide `JOB_OPTIONS=...` for either a client or server build,
the options are used both for `raco setup` and `raco pkg
install`. Normally, `JOB_OPTIONS` is used to control parallelism.
Creating a Client from an Installer Web Site
--------------------------------------------
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
from the site.
At a minimum, provide `SERVER', `SERVER_PORT' (usually 80), and
`SITE_PATH' (if not empty, include a trailing "/") makefile variables
At a minimum, provide `SERVER`, `SERVER_PORT` (usually 80), and
`SITE_PATH` (if not empty, include a trailing "/") makefile variables
to access a site at
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`,
`SERVER_CATALOG_PATH', and `SERVER_COLLECTS_PATH'. Supply any other
suitable variables, such as `DIST_NAME' or `RELEASE_MODE', the same as
for `make client'.
`SERVER_CATALOG_PATH`, and `SERVER_COLLECTS_PATH`. Supply any other
suitable variables, such as `DIST_NAME` or `RELEASE_MODE`, the same as
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)
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-minimal-in-place-after-base
plain-minimal-in-place-after-base:
$(MAKE) pkgs-catalog
$(RUN_RACO) pkg update $(UPDATE_PKGS_ARGS)
$(RUN_RACO) pkg install $(INSTALL_PKGS_ARGS)
$(RUN_RACO) setup --only-foreign-libs $(ALL_PLT_SETUP_OPTIONS)
in-place-setup:
$(RUN_RACO) setup $(ALL_PLT_SETUP_OPTIONS)
win32-in-place:
@ -91,7 +104,7 @@ cpus-as-is:
plain-as-is:
$(MAKE) base
$(RUN_RACO) setup $(ALL_PLT_SETUP_OPTIONS)
$(MAKE) in-place-setup
win32-as-is:
$(MAKE) win32-base
@ -148,7 +161,9 @@ set-src-catalog:
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:
if [ "$(CPUS)" = "" ] ; \
@ -159,13 +174,16 @@ cpus-base:
$(MAKE) -j $(CPUS) plain-base JOB_OPTIONS="-j $(CPUS)"
plain-base:
mkdir -p build/config
echo '#hash((links-search-files . ()))' > build/config/config.rktd
$(MAKE) base-config
mkdir -p racket/src/build
$(MAKE) racket/src/build/Makefile
cd racket/src/build; $(MAKE) reconfigure
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:
$(MAKE) win32-remove-setup-dlls
@ -195,6 +213,77 @@ native-for-cross:
racket/src/build/cross/Makefile: racket/src/configure racket/src/Makefile.in
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
@ -331,8 +420,8 @@ SVR_CAT = http://$(SVR_PRT)/$(SERVER_CATALOG_PATH)
# Helper macros:
USER_CONFIG = -G build/user/config -X racket/collects -A build/user
RACKET = $(PLAIN_RACKET) $(USER_CONFIG)
RACO = $(PLAIN_RACKET) $(USER_CONFIG) -N raco -l- raco
USER_RACKET = $(PLAIN_RACKET) $(USER_CONFIG)
USER_RACO = $(PLAIN_RACKET) $(USER_CONFIG) -N raco -l- raco
WIN32_RACKET = $(WIN32_PLAIN_RACKET) $(USER_CONFIG)
WIN32_RACO = $(WIN32_PLAIN_RACKET) $(USER_CONFIG) -N raco -l- raco
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)
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-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) racket/src/pkgs-check.rkt racket/share/pkgs-catalog
@ -409,47 +498,47 @@ stamp-from-date:
build-from-catalog:
rm -rf build/user
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
$(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
$(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
$(RACO) setup --avoid-main $(JOB_OPTIONS)
$(USER_RACKET) -l- distro-build/pkg-info -o build/pkgs.rktd build/catalog-copy
$(USER_RACKET) -l distro-build/install-pkgs $(CONFIG_MODE_q) "$(PKGS) $(TEST_PKGS)" $(SOURCE_USER_AUTO_q) --all-platforms
$(USER_RACO) setup --avoid-main $(JOB_OPTIONS)
server-cache-config:
$(RACO) pkg config -i --set download-cache-dir build/cache
$(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-dir build/cache
$(USER_RACO) pkg config -i --set download-cache-max-files 1023
$(USER_RACO) pkg config -i --set download-cache-max-bytes 671088640
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
# server's version to be used by each client, so that every client has
# exactly the same bytecode (which matters for SHA1-based dependency
# tracking):
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"
# versions of the packages from the installation into "build/user":
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
# as the copy of the server's "collects" tree:
built-catalog-server:
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,
# which involves creating package archives in "binary" mode
# instead of "built" mode:
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:
$(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):
@ -485,7 +574,7 @@ client:
$(MAKE) base $(COPY_ARGS)
$(MAKE) distro-build-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)
win32-client:
@ -499,7 +588,7 @@ win32-client:
# Install the "distro-build" package from the server into
# a local build:
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
# process things that should not be in an installer (such as the "src"
@ -511,13 +600,13 @@ distro-build-from-server:
bundle-from-server:
rm -rf bundle
mkdir -p bundle/racket
$(RACKET) -l setup/unixstyle-install bundle racket bundle/racket
$(RACKET) -l setup/winstrip bundle/racket
$(RACKET) -l setup/winvers-change bundle/racket
$(RACKET) -l distro-build/unpack-collects http://$(SVR_PRT)/$(SERVER_COLLECTS_PATH)
$(USER_RACKET) -l setup/unixstyle-install bundle racket bundle/racket
$(USER_RACKET) -l setup/winstrip bundle/racket
$(USER_RACKET) -l setup/winvers-change bundle/racket
$(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) $(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)"
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
# in "bundle/racket":
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_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)" \
$(SERVER) $(SERVER_PORT) "$(SERVER_HOSTS)" \
"$(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':
installers:
@ -615,8 +704,8 @@ DOC_CATALOGS = build/built/catalog build/native/catalog
site-from-installers:
rm -rf build/docs
$(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/install-for-docs build/docs $(CONFIG_MODE_q) "$(PKGS)" $(DOC_CATALOGS)
$(USER_RACKET) -l- distro-build/assemble-site $(CONFIG_MODE_q)
# ------------------------------------------------------------
# Create a snapshot site:
@ -626,4 +715,4 @@ snapshot-site:
$(MAKE) 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
Status](https://travis-ci.org/racket/racket.svg?branch=master)](https://travis-ci.org/racket/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.
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`
in the top-level directory. To build the Minimal Racket, run `make
base`.
in the top-level directory. To build minimal Racket, run `make base`.
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).
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 version "6.12.0.4")
(define version "6.90.0.16")
(define deps `("racket-lib"
["racket" #:version ,version]))

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

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

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

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

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

@ -1,42 +1,37 @@
#lang racket/base
(require compiler/zo-parse
(require racket/linklet
compiler/zo-parse
compiler/zo-marshal
syntax/modcollapse
racket/port
racket/match
racket/list
racket/set
racket/path)
racket/path
(only-in '#%linklet compiled-position->primitive)
"private/deserialize.rkt")
(provide decompile)
;; ----------------------------------------
(define primitive-table
;; Figure out number-to-id mapping for kernel functions in `primitive'
(let ([bindings
(let ([ns (make-base-empty-namespace)])
(parameterize ([current-namespace ns])
(namespace-require ''#%kernel)
(namespace-require ''#%unsafe)
(namespace-require ''#%flfxnum)
(namespace-require ''#%extfl)
(namespace-require ''#%futures)
(namespace-require ''#%foreign)
(for/list ([l (namespace-mapped-symbols)])
(cons l (with-handlers ([exn:fail? (lambda (x) #f)])
(compile l))))))]
[table (make-hash)])
(for ([b (in-list bindings)])
(let ([v (and (cdr b)
(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))
(let ([value-names (let ([ns (make-base-empty-namespace)])
(parameterize ([current-namespace ns])
(namespace-require ''#%kernel)
(namespace-require ''#%unsafe)
(namespace-require ''#%flfxnum)
(namespace-require ''#%extfl)
(namespace-require ''#%futures)
(namespace-require ''#%foreign)
(namespace-require ''#%paramz)
(for/hasheq ([name (in-list (namespace-mapped-symbols))])
(values (namespace-variable-value name #t (lambda () #f))
name))))])
(for/hash ([i (in-naturals)]
#:break (not (compiled-position->primitive i)))
(define v (compiled-position->primitive i))
(values i (or (hash-ref value-names v #f) `',v)))))
(define (list-ref/protect l pos who)
(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:
(define (decompile top)
(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)
(define (decompile top #:to-linklets? [to-linklets? #f])
(cond
[(symbol? modidx) modidx]
[else
(collapse-module-path-index modidx)]))
[(linkl-directory? top)
(cond
[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)
(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))
(let-values ([(globs defns) (decompile-prefix prefix stx-ht)]
[(stack) (append '(#%modvars) orig-stack)]
[(closed) (make-hasheq)])
`(,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-module-with-submodules l-dir name-list main-l)
(decompile-module main-l
(lambda ()
(for/list ([(k l) (in-hash (linkl-directory-table l-dir))]
#:when (and (list? k)
(= (length k) (add1 (length name-list)))
(for/and ([s1 (in-list name-list)]
[s2 (in-list k)])
(eq? s1 s2))))
(decompile-module-with-submodules l-dir k l)))))
(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
[(? mod?)
(decompile-module form stack stx-ht 'module)]
[(struct def-values (ids rhs))
`(define-values ,(map (lambda (tl)
(match tl
@ -344,29 +242,10 @@
,(decompile-expr (inline-variant-inline rhs) globs stack closed)
,(decompile-expr (inline-variant-direct 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))
`(begin ,@(map (lambda (form)
(decompile-form form globs stack closed stx-ht))
(decompile-form form globs stack closed))
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
(decompile-expr form globs stack closed)]))
@ -417,12 +296,12 @@
(match expr
[(struct toplevel (depth pos const? ready?))
(decompile-tl expr globs stack closed #f)]
[(struct varref (tl dummy))
`(#%variable-reference ,(if (eq? tl #t)
'<constant-local>
(decompile-tl tl globs stack closed #t)))]
[(struct topsyntax (depth pos midpt))
(list-ref/protect (glob-desc-vars globs) (+ midpt pos) 'topsyntax)]
[(struct varref (tl dummy constant? from-unsafe?))
`(#%variable-reference . ,(cond
[(not tl) '()]
[(eq? tl #t) '(<constant-local>)]
[(symbol? tl) (list tl)] ; primitive
[else (list (decompile-tl tl globs stack closed #t))]))]
[(struct primval (id))
(hash-ref primitive-table id (lambda () (error "unknown primitive: " id)))]
[(struct assign (id rhs undef-ok?))
@ -558,20 +437,9 @@
'()
(list
(for/list ([pos (in-list (sort (set->list tl-map) <))])
(define tl-pos
(cond
[(or (pos . < . (glob-desc-num-tls globs))
(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))))))))
(list-ref/protect (glob-desc-vars globs)
pos
'lam)))))))
,(decompile-expr body globs
(append captures
(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
(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
#|
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
racket/set
raco/command-name
"main.rkt")
(let ([output-file (make-parameter #f)])
(command-line #:program (short-program+command-name)
#: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
(require compiler/cm
compiler/zo-marshal
"alpha.rkt"
"gc-toplevels.rkt"
(require racket/set
compiler/cm
"find.rkt"
"name.rkt"
"merge.rkt"
"module.rkt"
"mpi.rkt"
"nodep.rkt"
"replace-modidx.rkt")
"gc.rkt"
"bundle.rkt"
"write.rkt")
(provide demodularize
(provide current-excluded-modules
garbage-collect-toplevels-enabled
recompile-enabled
demodularize)
current-excluded-modules
recompile-enabled)
(define garbage-collect-toplevels-enabled (make-parameter #f))
(define recompile-enabled (make-parameter #f))
(define logger (make-logger 'demodularizer (current-logger)))
(define (demodularize file-to-batch [output-file #f])
(parameterize ([current-logger logger])
(define-values (base name must-be-dir?) (split-path file-to-batch))
(when must-be-dir?
(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
(define (demodularize input-file [given-output-file #f])
(parameterize ([current-logger logger]
[current-excluded-modules (for/set ([path (in-set (current-excluded-modules))])
(normal-case-path (simplify-path (path->complete-path path))))])
(log-info "Compiling module")
(parameterize ([current-namespace (make-base-empty-namespace)])
(managed-compile-zo file-to-batch))
(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)))))
(managed-compile-zo input-file))
(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
(require compiler/zo-structs
"run.rkt"
"name.rkt"
"import.rkt"
"remap.rkt")
(require racket/list
racket/match
racket/contract
compiler/zo-parse
"util.rkt"
"mpi.rkt"
"nodep.rkt"
"update-toplevels.rkt")
(provide merge-linklets)
(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))
(define (merge-compilation-top get-modvar-rewrite top)
(parameterize ([current-get-modvar-rewrite get-modvar-rewrite])
(match top
[(struct compilation-top (max-let-depth binding-namess prefix form))
(define-values (new-max-let-depth new-prefix gen-new-forms)
(merge-form max-let-depth prefix form))
(define total-tls (length (prefix-toplevels new-prefix)))
(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)])))
;; Pick an order for the remaining imports:
(define import-keys (for/list ([path/submod+phase (in-hash-keys imports)]
;; References to a 'syntax-literals "phase" are
;; references to the implicit syntax-literals
;; module; drop those:
#:unless (or (syntax-literals-import? path/submod+phase)
(transformer-register-import? path/submod+phase)))
path/submod+phase))
(define (merge-forms max-let-depth prefix forms)
(if (empty? forms)
(values max-let-depth prefix (lambda _ empty))
(let*-values ([(fmax-let-depth fprefix gen-fform) (merge-form max-let-depth prefix (first forms))]
[(rmax-let-depth rprefix gen-rforms) (merge-forms fmax-let-depth fprefix (rest forms))])
(values rmax-let-depth
rprefix
(lambda args
(append (apply gen-fform args)
(apply gen-rforms args)))))))
(define any-syntax-literals?
(for/or ([path/submod+phase (in-hash-keys imports)])
(syntax-literals-import? path/submod+phase)))
(define any-transformer-registers?
(for/or ([path/submod+phase (in-hash-keys imports)])
(transformer-register-import? path/submod+phase)))
(define syntax-literals-pos 1)
(define transformer-register-pos (+ (if any-syntax-literals? 1 0)
syntax-literals-pos))
(define import-counter (+ (if any-transformer-registers? 1 0)
transformer-register-pos))
(define (merge-form max-let-depth prefix form)
(match form
[(? mod?)
(merge-module max-let-depth prefix form)]
[(struct seq (forms))
(merge-forms max-let-depth prefix forms)]
[(struct splice (forms))
(merge-forms max-let-depth prefix forms)]
[else
(values max-let-depth prefix (lambda _ (list form)))]))
;; Map each remaining import to its position
(define ordered-importss
(for/list ([key (in-list import-keys)])
(define ordered-imports (hash-ref imports key))
(for ([name (in-list ordered-imports)])
(define i (hash-ref names (cons key name)))
(set-import-pos! i import-counter)
(set! import-counter (add1 import-counter)))
ordered-imports))
;; 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)
(for/or ([e (in-list l)]
[i (in-naturals)]
#:when (eq? e v))
i))
;; Map all syntax-literal references to the same import.
;; We could update each call to the access to use a suitable
;; vector index.
(for ([(path/submod+phase imports) (in-hash imports)]
#: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)
(match-define (struct prefix (root-num-lifts root-toplevels root-stxs root-src-insp-desc)) root-prefix)
(match-define (struct prefix (mod-num-lifts mod-toplevels mod-stxs src-insp-desc)) mod-prefix)
(make-prefix (+ root-num-lifts mod-num-lifts)
(append root-toplevels mod-toplevels)
(append root-stxs mod-stxs)
root-src-insp-desc))
;; Map the transformer-register import, if any
(let* ([path/submod+phase '(#%transformer-register . transformer-register)]
[imports (hash-ref imports path/submod+phase null)])
(for ([name (in-list imports)])
(define i (hash-ref names (cons path/submod+phase name)))
(set-import-pos! i transformer-register-pos)))
(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)
(match mv
[(struct module-variable (modidx sym pos phase constantness))
(match rw
[(struct modvar-rewrite (self-modidx provide->toplevel))
(log-debug (format "Rewriting ~a@~a of ~S" sym pos (mpi->path* modidx)))
(define tl (provide->toplevel sym pos))
(log-debug (format "Rewriting ~a@~a of ~S to ~S" sym pos (mpi->path* modidx) tl))
(match-define (toplevel-offset-rewriter rewrite-fun meta)
(hash-ref MODULE-TOPLEVEL-OFFSETS self-modidx
(lambda ()
(error 'compute-new-modvar "toplevel offset not yet computed: ~S" self-modidx))))
(log-debug (format "Rewriting ~a@~a of ~S (which is ~a) with ~S" sym pos (mpi->path* modidx) tl meta))
(define res (rewrite-fun tl))
(log-debug (format "Rewriting ~a@~a of ~S (which is ~a) with ~S and got ~S"
sym pos (mpi->path* modidx) tl meta res))
res])]))
;; For each linklet that we merge, make a mapping from
;; the linklet's old position to new names (which can
;; then be mapped to new positions):
(define (make-position-mapping r)
(define h (make-hasheqv))
(define linkl (run-linkl r))
(define importss (linkl-importss linkl))
(define pos 1)
(for ([imports (in-list importss)]
[use (in-list (run-uses r))])
(for ([name (in-list imports)])
(hash-set! h pos (find-name names use name))
(set! pos (add1 pos))))
(define path/submod+phase (cons (run-path/submod r) (run-phase r)))
(for ([name (in-list (append (linkl-exports linkl)
(linkl-internals linkl)
(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)
(define-values
(i new-toplevels remap)
(for/fold ([i 0]
[new-toplevels empty]
[remap empty])
([tl (in-list mod-toplevels)]
[idx (in-naturals)])
(log-debug (format "[~S] mod-prefix tls\t~v ~v"
name idx tl))
(match tl
[(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))
;; Do we need the implicit initial variable for `(#%variable-reference)`?
;; The slot will be reserved whether we use it or not, but the
;; slot is not necessarily initialized if we don't need it.
(define saw-zero-pos-toplevel? #f)
(define body
(apply
append
(for/list ([r (in-list runs)])
(define pos-to-name/import (make-position-mapping r))
(define (remap-toplevel-pos pos)
(cond
; Primitive module like #%paramz
[(symbol? rw)
(log-debug (format "~S from ~S" sym rw))
(values (add1 i)
(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))]
[(zero? pos)
;; Implicit variable for `(#%variable-reference)` stays in place:
(set! saw-zero-pos-toplevel? #t)
0]
[else
(error 'filter-rewritable-module-variable? "Unsupported module-rewrite: ~S" rw)])]
[tl
(cond
[(and new-#f-idx (not tl))
(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 new-name/import (hash-ref pos-to-name/import pos))
(if (import? new-name/import)
(import-pos new-name/import)
(hash-ref positions new-name/import))]))
(define (merge-module max-let-depth top-prefix mod-form)
(match mod-form
[(struct mod (name srcname self-modidx
mod-prefix provides requires body syntax-bodies
unexported mod-max-let-depth dummy lang-info
internal-context binding-names
flags pre-submodules post-submodules))
(define top-toplevels (prefix-toplevels top-prefix))
(define toplevel-offset (length top-toplevels))
(define topsyntax-offset (length (prefix-stxs top-prefix)))
(define lift-offset (prefix-num-lifts top-prefix))
(define mod-toplevels (prefix-toplevels mod-prefix))
(define new-#f-idx
(index-of #f top-toplevels))
(when new-#f-idx
(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)))]))
(remap-positions (linkl-body (run-linkl r))
remap-toplevel-pos
#:application-hook
(lambda (rator rands remap)
;; Check for a `(.get-syntax-literal! '<pos>)` call
(cond
[(and (toplevel? rator)
(let ([i (hash-ref pos-to-name/import (toplevel-pos rator))])
(and (import? i)
(eqv? syntax-literals-pos (import-pos i)))))
;; This is a `(.get-syntax-literal! '<pos>)` call
(application (remap rator)
;; To support syntax objects, change the offset
rands)]
[else #f]))))))
(provide/contract
[merge-compilation-top (-> get-modvar-rewrite/c
compilation-top?
compilation-top?)])
(values body
first-internal-pos
;; Communicates into to `wrap-bundle`:
(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))
(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
(define-values (modular-output modular-error)
(capture-output (find-exe) filename))
@ -26,7 +26,9 @@
;; demodularize
(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
(define-values (whole-output whole-error)
@ -50,4 +52,9 @@
(define ip (build-path tests i))
(when (modular-program? 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 (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)
(parameterize ([current-input-port
(open-input-string
@ -260,11 +272,33 @@ exec racket -qu "$0" ${1+"$@"}
bm))])
(system "petite")))
(define (extract-petite-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)])
(list (bytes->number (cadr m))
(bytes->number (cadddr m))
(if (caddr m) (bytes->number (caddr m)) 0))))
(define (extract-chez-times bm 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)])
(define (s n) (inexact->exact (floor (* n 1000))))
(list (s (bytes->number (cadr m)))
(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
(define (mk-guile bm)
@ -537,9 +571,23 @@ exec racket -qu "$0" ${1+"$@"}
void
void
run-petite
extract-petite-times
extract-chez-times
void
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
void
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")
;; Needed for rxmzold, comment out otherwise:
#;
(begin
(define pregexp 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 10000 (char->integer #\x)) #"x*" 10000 '())
(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 1000 (char->integer #\x)) #"[xy]*" 10000 '())
(list 'stress-xy (make-bytes 10000 (char->integer #\x)) #"[xy]*" 1000 '())
(list 'stress-xy (make-bytes 100000 (char->integer #\x)) #"[xy]*" 100 '())
(list 'stress-xy (make-bytes 100 (char->integer #\x)) #"[xy]*" 1000000 '())
(list 'stress-xy (make-bytes 1000 (char->integer #\x)) #"[xy]*" 100000 '())
(list 'stress-xy (make-bytes 10000 (char->integer #\x)) #"[xy]*" 10000 '())
(list 'stress-xy (make-bytes 100000 (char->integer #\x)) #"[xy]*" 1000 '())
(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 1000 (char->integer #\x)) #"(?:y|x)*" 1000 '(python))
(list 'stress-xory (make-bytes 10000 (char->integer #\x)) #"(?:y|x)*" 100 '(python))
(list 'stress-xory (make-bytes 100000 (char->integer #\x)) #"(?:y|x)*" 10 '(pcre python))
(list 'stress-xorysave (make-bytes 100 (char->integer #\x)) #"(y|x)*" 10000 '())
(list 'stress-yzorx (make-bytes 100 (char->integer #\x)) #"(?:[yz]|x)*" 10000 '())
(list 'stress-yzorx (make-bytes 1000 (char->integer #\x)) #"(?:[yz]|x)*" 1000 '(python))
(list 'stress-yzorx (make-bytes 10000 (char->integer #\x)) #"(?:[yz]|x)*" 100 '(python))
(list 'stress-yzorx (make-bytes 100000 (char->integer #\x)) #"(?:[yz]|x)*" 10 '(pcre python))
(list 'stress-yzorxsave (make-bytes 100 (char->integer #\x)) #"([yz]|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)*" 10000 '(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)*" 100 '(pcre python))
(list 'stress-xorysave (make-bytes 100 (char->integer #\x)) #"(y|x)*" 100000 '())
(list 'stress-yzorx (make-bytes 100 (char->integer #\x)) #"(?:[yz]|x)*" 100000 '())
(list 'stress-yzorx (make-bytes 1000 (char->integer #\x)) #"(?:[yz]|x)*" 10000 '(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)*" 100 '(pcre python))
(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 1000 (char->integer #\x)) #"(?:x{2})*" 10000 '(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} ...}
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
@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?]
[dirs (listof path-string?)]
[#:immediate? immediate? any/c #f]
[#:link? link? any/c #f]
[#:merge? merge? 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
are contained in each directory specified by @racket[dirs]. Packages
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
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]
and @racket[pkg-desc] definition in each package's @filepath{info.rkt}
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["port.scrbl"]
@include-section["global.scrbl"]
@include-section["os-thread.scrbl"]
@include-section["objc.scrbl"]
@include-section["ns.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}
deactivates tracking of the calling OS thread---to the degree
supported by the Racket variant---during the foreign call.
Currently the value of @racket[blocking?] has no effect, but it
may enable activity such as concurrent garbage collection in
future variants of Racket. If the blocking @tech{callout} can
supported by the Racket variant---during the foreign call. The
value of @racket[blocking?] affects only the @tech[#:doc
guide.scrbl]{CS} variant of Racket, where it enable activity
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
@tech{callbacks} must be constructed with a non-@racket[#f]
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?]
[abi (or/c #f 'default 'stdcall 'sysv) #f]
[save-errno? any/c]
[orig-place? any/c])
[orig-place? any/c]
[lock-name (or/c #f string?) #f]
[blocking? any/c #f])
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-callable primitive function that uses the types to specify how
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]
[atomic? any/c #f]
[async-apply (or/c #f ((-> any) . -> . any)) #f])
ffi-callback?]{
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.}
@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?]{

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}
The Racket implementation is available in two variants: @deftech{3m} and
@deftech{CGC}. The @tech{3m} variant uses a modern,
The Racket implementation is available in three variants: @deftech{3m},
@deftech{CGC}, and @deftech{CS}. The @tech{3m} and @tech{CS} variants use a modern,
@deftech{generational garbage collector} that makes allocation
relatively cheap for short-lived objects. The @tech{CGC} variant uses
a @deftech{conservative garbage collector} which facilitates
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
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"
(for-label racket/base
compiler/decompile
(only-in compiler/zo-parse compilation-top? req)
(only-in compiler/zo-parse linkl-directory? linkl-bundle? linkl?)
compiler/zo-marshal))
@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]
@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
(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]
@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].}
@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
the marshaled bytecode.}
@ -160,4 +160,3 @@ the marshaled bytecode.}
@; ------------------------------------------------------------
@include-section["zo-struct.scrbl"]

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

@ -71,7 +71,7 @@ parameter is true.
null]
[#:gracket? gracket? any/c #f]
[#:mred? mred? any/c #f]
[#:variant variant (or/c 'cgc '3m)
[#:variant variant (or/c 'cgc '3m 'cs)
(system-type 'gc)]
[#:aux aux (listof (cons/c symbol? any/c)) null]
[#:collects-path collects-path
@ -384,7 +384,7 @@ have been applied as needed to refer to the existing file).}
[cmdline (listof string?)]
[aux (listof (cons/c symbol? any/c)) null]
[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
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]
[#:untetherd? untethered? any/c #f]
[gracket? any/c #f]
[variant (or/c 'cgc '3m) (if cross?
(cross-system-type 'gc)
(system-type 'gc))])
[variant (or/c 'cgc '3m 'cs) (if cross?
(cross-system-type 'gc)
(system-type 'gc))])
path?]{
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
@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
executable based on @nonterm{file}'s suffix; see
@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[aux] associations are used for an old-style launcher.}
@item{@racket['exe-name] (Mac OS, @racket['script-3m] or
@racket['script-cgc] variant) --- provides the base name for a
@racket['3m]-/@racket['cgc]-variant launcher, which the script
@item{@racket['exe-name] (Mac OS, @racket['script-3m],
@racket['script-cgc] or @racket['script-cs] variant) --- provides the base name for a
@racket['3m]-/@racket['cgc]-/@racket['cs]-variant launcher, which the script
will call ignoring @racket[args]. If this name is not provided,
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
launcher creation and for generating launcher names. The default is
the result of @racket[(system-type 'gc)]. On Unix and Windows, the
possibilities are @racket['cgc] and @racket['3m]. On Mac OS, the
@racket['script-3m] and @racket['script-cgc] variants are also
possibilities are @racket['cgc], @racket['3m], and @racket['cs]. On Mac OS, the
@racket['script-cgc], @racket['script-3m], and @racket['script-cs] variants are also
available for GRacket launchers.}
@defproc[(available-gracket-variants) (listof symbol?)]{
Returns a list of symbols corresponding to available variants of GRacket
in the current Racket installation. The list normally includes at
least one of @racket['3m] or @racket['cgc]--- whichever is the result
of @racket[(system-type 'gc)]---and may include the other, as well as
@racket['script-3m] and/or @racket['script-cgc] on Mac OS.}
least one of @racket['3m], @racket['cgc], or @racket['cs]--- whichever is the result
of @racket[(system-type 'gc)]---and may include the others, as well as
@racket['script-3m], @racket['script-cgc], and/or @racket['script-cs] on Mac OS.}
@defproc[(available-racket-variants) (listof symbol?)]{
Returns a list of symbols corresponding to available variants of
Racket in the current Racket installation. The list normally
includes at least one of @racket['3m] or @racket['cgc]---whichever is
the result of @racket[(system-type 'gc)]---and may include the other.}
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 others.}
@deftogether[(
@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)
@; ----------------------------------------------------------------------
@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
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}
@ -2019,7 +2054,7 @@ platform's installation already includes those libraries.
@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)
'os])
(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].}
@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)])
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
@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)
containing bytecode. Beware that the structure types used to
represent the bytecode are subject to frequent changes across Racket
versons.
The parsed bytecode is returned in a @racket[compilation-top]
structure. For a compiled module, the @racket[compilation-top]
structure will contain a @racket[mod] structure. For a top-level
sequence, it will normally contain a @racket[seq] or @racket[splice]
structure with a list of top-level declarations and expressions.
The parsed bytecode is returned in a @racket[link-directory] or
@racket[link-bundle] structure---the latter only for the compilation
of a module that contains no submodules.
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
@racket[if] form is represented by a @racket[branch] structure that
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
variable. Mutable local variables are boxed similarly to global
variables, but individual boxes are referenced from the stack and
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.}
closures.}
@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}
@defstruct+[(compilation-top zo)
([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)])]{
@deftogether[(
@defstruct+[(linkl-directory zo)
([table (hash/c (listof symbol?) linkl-bundle?)])]
@defstruct+[(linkl-bundle zo)
([table (hash/c (or/c symbol? fixnum?) (or linkl? any/c))])]
)]{
Wraps compiled code.
The @racket[max-let-depth] field indicates the
maximum stack depth that @racket[code] creates (not counting the
@racket[prefix] array).
Module and top-level compilation produce one or more linklets that
represent independent evaluation in a specific phase. Even a single
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
symbols that appear in @racket[prefix] for top-level
@racket[def-values] forms and in top-level @racket[def-syntaxes]
forms. Each symbol is mapped to an identifier that will be bound
(after introduction into the namespace) by the definition.
A linklet bundle maps an integer to a linklet representing forms to
evaluate at the integer-indicated phase. Symbols are mapped to
metadata, such as a module's name as compiled or a linklet
implementing literal syntax objects. A linklet directory normally
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,
module-level variables, and quoted syntax-objects accessed by
@racket[code].
@defstruct+[(linkl zo)
([name symbol?]
[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
@racket[form], but a literal value is represented as itself.}
Represents a linklet, which corresponds to a module body or a
top-level sequence at a single phase.
@defstruct+[(prefix zo)
([num-lifts exact-nonnegative-integer?]
[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.
The @racket[name] of a linklet is for debugging purposes, similar to
the inferred name of a @racket[lambda] form.
In @racket[toplevels], each element is one of the following:
@itemize[
@item{a @racket[#f], which indicates a dummy variable that is used
to access the enclosing module/namespace at run time;}
@item{a symbol, which is a reference to a variable defined in the
enclosing module;}
@item{a @racket[global-bucket], which is a top-level variable (appears
only outside of modules); or}
@item{a @racket[module-variable], which indicates a variable imported
from another module.}
]
The @racket[importss] list of lists describes the linklet's imports.
Each of the elements of the out list corresponds to an import
source, and each element of an inner list is the symbolic name of an
export from that source. The @racket[import-shapess] list is in
parallel to @racket[imports]; it reflects optimization assumptions
by the compiler that are used by the bytecode validator and checked
when the linklet is instantiated.
The variable buckets and syntax objects that are recorded in a prefix
are accessed by @racket[toplevel] and @racket[topsyntax] expression
forms.
When an element of @racket[stxs] is @racket[#f], it coresponds to a
syntax object that was optimized away at the last minute. The slot
must not be referenced by a @racket[topsyntax] form.
The @racket[exports] list describes the linklet's defined names that
are exported. The @racket[internals] list describes additional
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
in place of an unreferenced internal definition that has been removed.
The @racket[lifts] list
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
is used within syntax-object bindings. At run time, the prefix gets
an inspector, and bindings that reference the same inspector name are
granted access capabilities through that inspector.}
Each symbol in @racket[exports],
@racket[internals], and @racket[lifts] must be distinct from any
other symbol in those lists. The @racket[source-names] table maps
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?])]{
Represents a top-level variable, and used only in a
@racket[prefix]. Because modules cannot require top-level
variables, these will only appear in the top level
@racket[prefix]. Additionally, symbols in the top-level
prefix are an alias for @racket[global-bucket] structs,
making them redundant.}
When a linklet is instantiated, variables correponding to the
flattening of the lists @racket[importss], @racket[exports],
@racket[internals], and @racket[lifts] are placed in an array (in
that order) for access via @racket[toplevel] references. The initial
slot is reserved for a variable-like reference that strongly retains
a connection to an instance of its enclosing linklet.
@defstruct+[(module-variable zo)
([modidx module-path-index?]
[sym symbol?]
[pos exact-integer?]
[phase exact-nonnegative-integer?]
[constantness (or/c #f 'constant 'fixed
function-shape? struct-shape?)])]{
Represents a top-level variable, and used only in a @racket[prefix].
The @racket[pos] may record the variable's offset within its module,
or it can be @racket[-1] if the variable is always located by name.
The @racket[phase] indicates the phase level of the definition within
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.}
The @racket[bodys] list is the executable content of the linklet. The
value of the last element in @racket[bodys] may be returned when the
linklet is instantiated, depending on the way that it's instantiated.
The @racket[max-let-depth] field indicates the maximum size of the
stack that will be created by any @racket[body].
The @racket[need-instance-access?] boolean indicates whether the
linklet contains a @racket[toplevel] for position 0. A @racket[#t] is
allowed (but suboptimal) if not such reference is present in the
linklet body.}
@defstruct+[function-shape
([arity procedure-arity?]
@ -137,11 +140,11 @@ returns.}
@deftogether[(
@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+[(predicate-shape struct-shape) ()]
@defstruct+[(accessor-shape struct-shape) ([field-count exact-nonnegative-integer?])]
@defstruct+[(mutator-shape struct-shape) ([field-count exact-nonnegative-integer?])]
@defstruct+[(predicate-shape struct-shape) ([authentic? boolean?])]
@defstruct+[(accessor-shape struct-shape) ([field-count exact-nonnegative-integer?] [authentic? boolean?])]
@defstruct+[(mutator-shape struct-shape) ([field-count exact-nonnegative-integer?] [authentic? boolean?])]
@defstruct+[(struct-type-property-shape struct-shape) ([has-guard? boolean?])]
@defstruct+[(property-predicate-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) ()]{
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
themselves.}
@ -167,170 +170,24 @@ binding, constructor, etc.}
([ids (listof toplevel?)]
[rhs (or/c expr? seq? inline-variant? any/c)])]{
Represents a @racket[define-values] form. Each element of
@racket[ids] will reference via the prefix either a top-level variable
or a local module variable.
@racket[ids] references a defined variable in the enclosing linklet.
After @racket[rhs] is evaluated, the stack is restored to its depth
from before evaluating @racket[rhs].}
@deftogether[(
@defstruct+[(def-syntaxes form) ([ids (listof symbol?)]
[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?])]{
@defstruct+[(inline-variant zo) ([direct expr?]
[inline expr?])]{
Represents a function that is bound by @racket[define-values], where the
function has two variants.
The first variant is used for normal calls to the function. The second may
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}
@defstruct+[(expr form) ()]{
A supertype for all expression forms that can appear in compiled code,
except for literals that are represented as themselves and some
@racket[seq] structures (which can appear as an expression as long as
it contains only other things that can be expressions).}
except for literals that are represented as themselves.}
@defstruct+[(lam expr)
([name (or/c symbol? vector?)]
@ -367,7 +224,7 @@ binding, constructor, etc.}
refers to a syntax-object constant, the variables and constants are
represented in the closure by capturing a prefix (in the sense
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
system if they become unused) and whether any syntax objects are
used (so that the syntax objects as a group can be similarly
@ -497,8 +354,8 @@ binding, constructor, etc.}
[pos exact-nonnegative-integer?]
[const? boolean?]
[ready? boolean?])]{
Represents a reference to a top-level or imported variable via the
@racket[prefix] array. The @racket[depth] field indicates the number
Represents a reference to an imported or defined variable within
a linklet. 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.
@ -513,21 +370,11 @@ binding, constructor, etc.}
@racket[#f], then a check is needed to determine whether the
variable is defined.
When the @racket[toplevel] is the right-hand side for
@racket[def-values], then @racket[const?] is @racket[#f]. If
When the @racket[toplevel] is the left-hand side for
@racket[def-values], then @racket[const?] is @racket[#f]. If
@racket[ready?] is @racket[#t], the variable is marked as immutable
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)
([rator (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
@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))])]{
Represents a @racket[begin0] expression.
@ -567,13 +420,20 @@ binding, constructor, etc.}
expression in the list.}
@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]
field is @racket[#t] if the original reference was to a constant local
binding. The @racket[dummy] field
accesses a variable bucket that strongly references its namespace (as
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)
([id toplevel?]
@ -616,210 +476,3 @@ binding, constructor, etc.}
Represents a direct reference to a variable imported from the run-time
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].}
@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?))]
[old 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}.}
@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
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]{
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}

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

@ -170,7 +170,8 @@ exception.}
@defproc[(namespace-set-variable-value! [sym symbol?]
[v any/c]
[map? any/c #f]
[namespace namespace? (current-namespace)])
[namespace namespace? (current-namespace)]
[as-constant? any/c #f])
void?]{
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
@tech{identifier} mapping is also adjusted (see
@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?]
@ -502,8 +509,7 @@ an anonymous module variable as produced by
Returns @racket[#t] if the module of the variable reference itself
(not necessarily a referenced variable) is compiled in unsafe mode,
@racket[#f] otherwise. Since unsafe-mode compilation is not currently
supported, the result is always @racket[#f].
@racket[#f] otherwise.
The @racket[variable-reference-from-unsafe?] procedure is intended for
use as
@ -512,6 +518,12 @@ use as
(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"]}

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[read/recursive]), the procedure is passed only two 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.
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)
raise-read-eof-error
raise-read-error)
"expected `,' or `>'" src l c p 1)]))]))
"expected `,` or `>`" src l c p 1)]))]))
(define (make-delims-table)
;; 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 src line col pos)
(raise-read-error
(format "misplaced `~a' in tuple" ch)
(format "misplaced `~a` in tuple" ch)
src line col pos 1)])])
(make-readtable (current-readtable)
#\, 'terminating-macro misplaced-delimiter
@ -286,14 +286,14 @@ character and the @racket[#f] readtable.}
(define parse-open-tuple
(case-lambda
[(ch port)
;; `read' mode
;; `read` mode
(wrap (parse port
(lambda ()
(read/recursive port #f
(make-delims-table)))
(object-name port)))]
[(ch port src line col pos)
;; `read-syntax' mode
;; `read-syntax` mode
(datum->syntax
#f
(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.
In @indexed-racket['vm] mode,
the only possible symbol result is:
the possible symbol results are:
@itemize[
@item{@indexed-racket['racket]}
@item{@indexed-racket['chez-scheme]}
]
In @indexed-racket['gc] mode,
the possible symbol results are:
@itemize[
@item{@indexed-racket['cgc]}
@item{@indexed-racket['3m]}
@item{@indexed-racket['cgc] --- when @racket[(system-type 'vm)] is @racket['racket]}
@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:

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

@ -18,3 +18,4 @@
@include-section["code-inspectors.scrbl"]
@include-section["plumbers.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]
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
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
bindings listed in @secref["fully-expanded"] plus the
@ -346,23 +349,31 @@ expansion history to external tools.
an explicit wrapper.}]}
@defproc[(syntax-local-expand-expression [stx any/c])
(values syntax? syntax?)]{
@defproc[(syntax-local-expand-expression [stx any/c] [opaque-only? #f])
(values (if opaque-only? #f syntax?) syntax?)]{
Like @racket[local-expand] given @racket['expression] and an empty
stop list, but with two results: a syntax object for the fully
expanded expression, and a syntax object whose content is opaque. The
latter can be used in place of the former (perhaps in a larger
expanded expression, and a syntax object whose content is opaque.
The latter can be used in place of the former (perhaps in a larger
expression produced by a macro transformer), and when the macro
expander encounters the opaque object, it substitutes the fully
expanded expression without re-expanding it; the
@exnraise[exn:fail:syntax] if the expansion context includes
@tech{scopes} that were not present for the original expansion, in which
case re-expansion might produce different results. Consistent use of
@racket[syntax-local-expand-expression] and the opaque object thus
avoids quadratic expansion times when local expansions are nested.
@tech{scopes} that were not present for the original expansion, in
which case re-expansion might produce different results. Consistent
use of @racket[syntax-local-expand-expression] and the opaque object
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]

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

@ -655,6 +655,7 @@ fixnum).}
@history[#:added "6.9.0.2"]
}
@; ------------------------------------------------------------------------
@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].}
@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?))]
[pos exact-nonnegative-integer?]
[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?]
[#: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]
[#:roots roots (listof (or/c path-string? 'same)) (current-compiled-file-roots)]
[#: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
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
module. The @racket[roots] list specifies a compiled-file search path
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.
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?]
[#: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]
[#:roots roots (listof (or/c path-string? 'same)) (current-compiled-file-roots)]
[#: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
true, the result is never a @racket['so] path, as native libraries cannot
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?]
[#: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 module source or @filepath{.zo} file.}
@defstruct[(exn:get-module-code exn:fail) ([path path?])]{
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)
;; test clearing weak boxes
(when (eq? '3m (system-type 'gc))
(unless (eq? 'cgc (system-type 'gc))
(let* ([s (gensym)]
[b (make-weak-box s)])
(test s weak-box-value b)
@ -2898,17 +2898,21 @@
(cons 1 (loop (sub1 i))))))
exn:fail:contract?)))
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
(lambda (+)
(check-ok + 0 '(0) '(1))
(check-ok + 2 '(2) '(0 1 3 4))
(check-ok + 10 '(10) (list 0 11 (expt 2 70)))
(check-ok + (expt 2 70) (list (expt 2 70)) (list 0 10 (add1 (expt 2 70))))
(check-ok + (make-arity-at-least 2) (list 2 5 (expt 2 70)) (list 0 1))
(check-ok + 10 '(10) (filter representable-arity? (list 0 11 (expt 2 70))))
(when (representable-arity? (expt 2 70))
(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) '(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 2 (make-arity-at-least 4)) '(2 4 10) '(0 1 3)))])
(check-all-but-one +)

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

@ -1922,7 +1922,7 @@
(set! access-k k)
k))]
[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)])
(test #t (format "~s ~s ~s" proc val got) (equal? val got))))])
(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 "will.rktl")
(load-relative "namespac.rktl")
(load-relative "expobs.rktl")
(load-relative "collects.rktl")
(load-relative "modprot.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 _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:
(let ()
@ -323,9 +324,10 @@
(set-box! b #f)))
;; ---
;; test exposing internal mzscheme functionality
(test '(1 2)
(get-ffi-obj 'scheme_make_pair #f (_fun _scheme _scheme -> _scheme))
1 '(2))
(when (eq? 'racket (system-type 'vm))
(test '(1 2)
(get-ffi-obj 'scheme_make_pair #f (_fun _scheme _scheme -> _scheme))
1 '(2)))
;; ---
;; test arrays
(let ([p (malloc _c7_list)]) ;; should allocate the right size
@ -573,7 +575,7 @@
(test 'hello hash-ref ht seventeen3 #f)))
;; Check proper handling of offsets:
(let ()
(when (eq? 'racket (system-type 'vm))
(define scheme_make_sized_byte_string
(get-ffi-obj 'scheme_make_sized_byte_string #f (_fun _pointer _intptr _int -> _scheme)))
;; Non-gcable:
@ -605,7 +607,7 @@
(define _stuff-pointer (_cpointer 'stuff))
(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))
(test (cast p _pointer _intptr)
cast q _pointer _intptr)
@ -647,7 +649,7 @@
(define ENOENT 2)
(define ERANGE 34)
(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
(get-ffi-obj '_chdir msvcrt (_fun #:save-errno 'posix _string -> _int)))
(define (bad/ERANGE) (_getcwd (make-bytes 1) 1))
@ -664,7 +666,7 @@
(delete-test-files)
(let ()
(when (eq? 'racket (system-type 'vm))
(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)))))
@ -679,8 +681,9 @@
(test 4.4t0 extflvector-ref v 2)
(test 2.2t0 ptr-ref (ptr-add (extflvector->cpointer v) (ctype-sizeof _longdouble)) _longdouble))
;; Check a corner of UTF-16 conversion:
(test "\U171D3" cast (cast "\U171D3" _string/utf-16 _gcpointer) _gcpointer _string/utf-16)
(when (eq? 'racket (system-type 'vm))
;; Check a corner of UTF-16 conversion:
(test "\U171D3" cast (cast "\U171D3" _string/utf-16 _gcpointer) _gcpointer _string/utf-16))
;; check async:
(when test-async?
@ -1000,6 +1003,8 @@
;; --- inplace tests
(define can-in-place? (not (eq? 'chez-scheme (system-type 'vm))))
(define-serializable-cstruct _NOIN ([a _int]))
(define-serializable-cstruct _INS ([a _int]) #:serialize-inplace)
@ -1008,7 +1013,7 @@
(define-serializable-cstruct _INSD ([a _int])
#:serialize-inplace #:deserialize-inplace
#:malloc-mode (if (eq? 'racket (system-type 'vm))
#:malloc-mode (if can-in-place?
(lambda (_) (error "should not get here"))
malloc/register))
@ -1041,7 +1046,7 @@
;; modified
(set-INS-a! ins 456)
(define ds2 (deserialize s))
(check-equal? 456 (INS-a ds2)))
(check-equal? (if can-in-place? 456 123) (INS-a ds2)))
;; inplace deser
(let ()
@ -1208,44 +1213,45 @@
;; ----------------------------------------
(define scheme_make_type
(get-ffi-obj 'scheme_make_type #f (_fun _string -> _short)))
(define scheme_register_type_gc_shape
(get-ffi-obj 'scheme_register_type_gc_shape #f (_fun _short (_list i _intptr) -> _void)))
(when (eq? 'racket (system-type 'vm))
(define scheme_make_type
(get-ffi-obj 'scheme_make_type #f (_fun _string -> _short)))
(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_PTR_OFFSET 1)
(define SHAPE_STR_TERM 0)
(define SHAPE_STR_PTR_OFFSET 1)
(define-cstruct _tagged ([type-tag _short]
[obj1 _racket]
[non2 _intptr]
[obj3 _racket]
[non4 _intptr])
#:define-unsafe
#:malloc-mode 'tagged)
(test #t cpointer-predicate-procedure? tagged?)
(define-cstruct _tagged ([type-tag _short]
[obj1 _racket]
[non2 _intptr]
[obj3 _racket]
[non4 _intptr])
#:define-unsafe
#:malloc-mode 'tagged)
(test #t cpointer-predicate-procedure? tagged?)
(define t (scheme_make_type "new-type"))
(scheme_register_type_gc_shape t (list SHAPE_STR_PTR_OFFSET tagged-obj1-offset
SHAPE_STR_PTR_OFFSET tagged-obj3-offset
SHAPE_STR_TERM))
(define t (scheme_make_type "new-type"))
(scheme_register_type_gc_shape t (list SHAPE_STR_PTR_OFFSET tagged-obj1-offset
SHAPE_STR_PTR_OFFSET tagged-obj3-offset
SHAPE_STR_TERM))
(define obj1 (make-string 10))
(define obj2 (make-bytes 12))
(define obj3 (make-bytes 14))
(define obj4 (make-string 16))
(define obj1 (make-string 10))
(define obj2 (make-bytes 12))
(define obj3 (make-bytes 14))
(define obj4 (make-string 16))
(define obj2-addr (cast obj2 _racket _intptr))
(define obj4-addr (cast obj4 _racket _intptr))
(define obj2-addr (cast obj2 _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-obj3 o) obj3)
(= (tagged-non2 o) obj2-addr)
(= (tagged-non4 o) obj4-addr)
(eq? (tagged-obj1 o) obj1)
(eq? (tagged-obj3 o) obj3)
(= (tagged-non2 o) obj2-addr)
(= (tagged-non4 o) obj4-addr))
;; ----------------------------------------

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

@ -47,7 +47,9 @@
thing? rock? stone?
continuation-mark-set-first))
(let ([s (with-handlers ([exn? exn-message])
(let ([bad bad-value])
(let ([bad (if (eq? bad-value 'unsafe-undefined)
unsafe-undefined
bad-value)])
(cond
[first-arg (proc first-arg bad)]
[second-arg (proc bad second-arg)]
@ -702,8 +704,14 @@
(bin-exact 'b 'vector-ref #(a b c) 1)
(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 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 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)
(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
@ -857,6 +865,7 @@
3rd-all-ok?))
'(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-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-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))))
#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))
(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))
(list "123")))
(err/rt-test (apply (list-ref (list (lambda (s) (bytes-set! s 0 0))) (random 1))
(list #"123")))
(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 (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)])
(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)
;; ----------------------------------------
;; 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
;; `syntax-transforming?` mode when used as an expression
@ -1707,6 +1796,13 @@
(ax))])
(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
;; pattern variable is used at different depths
@ -1716,6 +1812,35 @@
#'([(b (b ...)) ...] ...)))
(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
;; definition contexts

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

@ -212,45 +212,10 @@
(#%require '#%unsafe)
(display unsafe-car)))
(require compiler/zo-structs
compiler/zo-marshal)
(define unsafe-synth-zo
(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)))))
(require (only-in racket/unsafe/ops unsafe-car)
compiler/zo-structs
compiler/zo-marshal
(only-in '#%linklet primitive->compiled-position))
;; - - - - - - - - - - - - - - - - - - - -
@ -268,7 +233,10 @@
(define (mp-try-all zero one two/no-protect two/protect
three/nabbed three/pnabbed three/snabbed three/nfnabbed three/nfpnabbed three/nfsnabbed
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
(lambda (two three v fail-three?)
(let ([ns (make-base-namespace)]
@ -291,17 +259,17 @@
(test #t regexp-match?
(if (byte-regexp? v) v (byte-regexp (string->bytes/utf-8 (format "~a\n" v))))
(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/nfnabbed (if (and fail-prot? (not np-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/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/snabbed (if (and fail-prot? np-ok?) #rx#"unexported .* stx" #rx#"one .13.") 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?) (not unprot-ok?)) #rx#"unexported .* unexp" #rx#"two .5.") 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?) (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? (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/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/pnabbed (if fail-pnab? #rx#"protected .* prot" #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/normal (if fail-prot? #rx#"protected .* normal" #rx#"two .10.") 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" #rx#"zero .8.") 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" #rx#"two .10.") fail-three?)))
(define (unsafe-try unsafe get-inspector unsafe-fail? unsafe-ref-fail? read-fail?)
(let ([ns (make-base-namespace)]
@ -408,26 +376,26 @@
three/normal-zo
make-inspector current-code-inspector #t #f #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
three/nabbed three/pnabbed three/snabbed-zo three/nfnabbed three/nfpnabbed three/nfsnabbed-zo
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)
(displayln "zo and source, third:")
(displayln "zo, change inspector:")
(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/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:")
(mp-try-all zero one two/no-protect two/protect
three/nabbed three/pnabbed three/snabbed three/nfnabbed three/nfpnabbed three/nfsnabbed
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)

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 (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 . 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 1 m))))
(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 m extra))))
(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 . 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 not-there))))
(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 10) (define-syntax x 10)))
@ -971,7 +971,7 @@
(define b-s (compile-m b-expr (list a-s)))
(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))
(unless dir-existed? (make-directory dir))
@ -1132,7 +1132,7 @@
'(rename-out [z x])
"x"
;; slow:
"exp\nexp\nrun\nexp\nexp\n"))])
"exp\nexp\nrun\nexp\n"))])
(define ns (make-base-namespace))
(define o (open-output-string))
(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 mode (integer->char (bytes-ref s (+ start 3 vlen))))
(case mode
[(#\T)
[(#\B)
(define h (make-bytes 20 (+ 42 c)))
(bytes-copy! s (+ start 4 vlen) h)]
[(#\D)
@ -1303,8 +1303,8 @@ case of module-leve bindings; it doesn't cover local bindings.
(module s racket/base
(provide x)
(define x 1)))))
(make-directory* (build-path dir "compiled"))
(define zo-path (build-path dir "compiled" "tmx_rkt.zo"))
(make-directory* (build-path dir (car (use-compiled-file-paths))))
(define zo-path (build-path dir (car (use-compiled-file-paths)) "tmx_rkt.zo"))
(define bstr
(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
(#%provide x)
(define-values (x) 1))))
(make-directory* (build-path dir "compiled"))
(define zo-path (build-path dir "compiled" "tmx2_rkt.zo"))
(make-directory* (build-path dir (car (use-compiled-file-paths))))
(define zo-path (build-path dir (car (use-compiled-file-paths)) "tmx2_rkt.zo"))
(define bstr
(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)
(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`
@ -1677,23 +1717,23 @@ case of module-leve bindings; it doesn't cover local bindings.
(define tmp (make-temporary-file "~a-module-test" 'directory))
(parameterize ([current-directory tmp]
[current-load-relative-directory tmp])
(make-directory "compiled")
(make-directory* (car (use-compiled-file-paths)))
(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
(provide (all-defined-out))
(define a 1)
(define b 2)
(define c 3)))
o)))
(provide (all-defined-out))
(define a 1)
(define b 2)
(define c 3)))
o)))
(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
(require "a.rkt"
;; Force saving of context, instead of
;; reconstruction:
(only-in racket/base [car extra-car]))))
o))))
(require "a.rkt"
;; Force saving of context, instead of
;; reconstruction:
(only-in racket/base [car extra-car]))))
o))))
(dynamic-require (build-path tmp "b.rkt") #f)
(define ns (module->namespace (build-path tmp "b.rkt")))
(test #t
@ -1905,6 +1945,42 @@ case of module-leve bindings; it doesn't cover local bindings.
(namespace-syntax-introduce
(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`
;; 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 '(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)

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-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)
(define n (make-base-namespace))
@ -147,7 +147,7 @@
(test #f
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 +))
(require (only-in racket/unsafe/ops
[unsafe-fx+ $$unsafe-fx+]))

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

@ -6,6 +6,7 @@
(define number-table
`((,(+ 1/2 +i) "1/2+i")
(1.2+1i "1.2+i")
(100 "100")
(100 "#d100")
(0.1 ".1")
@ -28,6 +29,8 @@
(0.0 "0e13")
(0.0 "#i0")
(-0.0 "#i-0")
(0.0 "0#")
(-0.0 "-0#")
(+inf.0 ".3e2666666666")
(+inf.0 "+INF.0")
(+nan.0 "+NaN.0")
@ -78,6 +81,10 @@
(1/20 "#e0.5e-1")
(1/20 "#e0.005e1")
(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")
@ -111,6 +118,8 @@
(X "#d1#/#3")
(+inf.0 "1/0#")
(-inf.0 "-1/0#")
(DBZ "1#/0")
(DBZ "-1#/0")
(NOE "#e+inf.0")
(NOE "#e-inf.0")
(NOE "#e+nan.0")
@ -176,6 +185,10 @@
(#f "-+1")
(#f "-1+3-4")
(#f "1\0002")
(#f "1/2+3")
(#f "1.2+3")
(#f "2+1/2")
(#f "3+1.2")
(X "#xg")
(X "#x")
(X "#xa#a")
@ -251,4 +264,17 @@
(DBZ "1/0@+inf.0")
(DBZ "+inf.0@1/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)))
'(lambda (w z) (random) #t))
(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))))
'(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))))
'(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))))
'(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)))
'(lambda (w z) #t))
(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?
(test-arg-types '(k:map procedure? 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)
(let ([x (list* w z)]
@ -1186,6 +1189,9 @@
(begin (quote-syntax foo) 3))])
x)
'3)
;; The compiler doens't currently recognize the expansion of `quote-syntax`
#;
(test-comp '(if (lambda () 10)
'ok
(quote-syntax no!))
@ -2140,6 +2146,8 @@
(void 10))
'(module m racket/base))
;; The compiler doens't currently recognize the expansion of `quote-syntax`
#;
(test-comp '(module m racket/base
(void (quote-syntax unused!)))
'(module m racket/base))
@ -3003,6 +3011,7 @@
(require (submod ".." a))
(list b c (c)))))
(test-comp `(module m racket/base
(module a racket/base
(provide b c)
@ -3032,6 +3041,36 @@
(require (submod ".." a))
(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
(require racket/performance-hint)
(provide loop)
@ -4053,19 +4092,19 @@
(test-comp '(letrec-values ([(x y) (error "oops")]) 11)
'(error "oops"))
(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)
'(let () (begin (read) (error "oops"))))
'(let () (begin (values (read)) (error "oops"))))
(test-comp '(let-values ((() (error "oops")) ((x) 9)) 11)
'(error "oops"))
(test-comp '(let-values ((() (error "oops")) (() (values))) 11)
'(error "oops"))
(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)
'(let () (begin (read) (error "oops"))))
'(let () (begin (values (read)) (error "oops"))))
(test-comp '(error "oops")
'(let () (begin (read) (error "oops")))
'(let () (begin (values (read)) (error "oops")))
#f)
(test-comp '(with-continuation-mark
@ -5013,24 +5052,28 @@
(write-bytes
(zo-marshal
(match m
[(compilation-top max-let-depth binding-namess prefix code)
(compilation-top max-let-depth binding-namess prefix
(let ([body (mod-body code)])
(struct-copy mod code [body
(match body
[(list a b)
(list (match a
[(application rator (list rand))
(application
rator
(list
(struct-copy
lam rand
[body
(match (lam-body rand)
[(toplevel depth pos const? ready?)
(toplevel depth pos #t #t)])])))])
b)])])))]))
[(linkl-bundle t)
(linkl-bundle
(hash-set t
0
(let* ([l (hash-ref t 0)]
[body (linkl-body l)])
(struct-copy linkl l [body
(match body
[(list a b c)
(list (match a
[(application rator (list rand))
(application
rator
(list
(struct-copy
lam rand
[body
(match (lam-body rand)
[(toplevel depth pos const? ready?)
(toplevel depth pos #t #t)])])))])
b
c)])]))))]))
o2))
;; 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
(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 expr-z (car (beg0-seq body-z)))
(cond
@ -5272,8 +5316,9 @@
(write (compile l) o)
(parameterize ([read-accept-compiled #t])
(zo-parse (open-input-bytes (get-output-bytes o))))))
(let* ([m (compilation-top-code b)]
[d (car (mod-body m))]
(let* ([lb (hash-ref (linkl-directory-table b) '())]
[m (hash-ref (linkl-bundle-table lb) 0)]
[d (car (linkl-body m))]
[b (closure-code (def-values-rhs d))]
[c (application-rator (lam-body b))]
[l (closure-code c)]
@ -5294,8 +5339,9 @@
(write (compile l) o)
(parameterize ([read-accept-compiled #t])
(zo-parse (open-input-bytes (get-output-bytes o))))))
(let* ([m (compilation-top-code b)]
[d (car (mod-body m))]
(let* ([lb (hash-ref (linkl-directory-table b) '())]
[m (hash-ref (linkl-bundle-table lb) 0)]
[d (car (linkl-body m))]
[rhs (def-values-rhs d)]
[b (inline-variant-direct rhs)]
[v (application-rator (lam-body b))])
@ -5313,8 +5359,9 @@
(write (compile l) o)
(parameterize ([read-accept-compiled #t])
(zo-parse (open-input-bytes (get-output-bytes o))))))
(let* ([m (compilation-top-code b)]
[d (cadr (mod-body m))]
(let* ([lb (hash-ref (linkl-directory-table b) '())]
[m (hash-ref (linkl-bundle-table lb) 0)]
[d (cadr (linkl-body m))]
[rhs (def-values-rhs d)]
[b (inline-variant-direct rhs)]
[v (application-rator (lam-body b))])
@ -5409,7 +5456,7 @@
(lambda ()
(with-handlers ([exn:fail:out-of-memory? void])
(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)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

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

@ -35,7 +35,7 @@
(if erroring-set?
(begin
(set! erroring-set? #f)
(error 'output))
(error 'output "~s" s))
(display (subbytes s start end) orig))
(- end start)))
void))
@ -267,7 +267,7 @@
(list current-output-port
(list (current-output-port)
erroring-port)
'(begin
'(let ()
(set! erroring-set? #t)
(display 5)
(set! erroring-set? #f))
@ -420,7 +420,7 @@
[expr (caddr d)]
[exn? (cadddr d)])
(parameterize ([param alt1])
(test (void) void (teval expr)))
(test (void) void (eval expr)))
(parameterize ([param alt2])
(error-test (datum->syntax #f expr #f) exn?))))
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,
;; but it is not thread-safe, because multiple
;; threads might read and change n
(define mod3-peeked? #f)
(define mod3-cycle/one-thread
(let* ([n 2]
[mod! (lambda (s delta)
@ -157,14 +158,16 @@
1)])
(make-input-port
'mod3-cycle/not-thread-safe
(lambda (s)
(lambda (s)
(set! n (modulo (add1 n) 3))
(mod! s 0))
(lambda (s skip progress-evt)
(mod! s skip))
(lambda (s skip progress-evt)
(set! mod3-peeked? #t)
(mod! s (add1 skip)))
void)))
(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
;; events. Only the server thread touches the stateful part
@ -520,7 +523,12 @@
(let ([s (make-bytes 6 (char->integer #\-))])
(test 5 read-bytes-avail! s in)
(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):
(let-values ([(i o) (make-pipe 50)]
@ -633,11 +641,13 @@
(peek-byte r)
(let ([t (thread (lambda ()
(port-commit-peeked 1 (port-progress-evt r) ch r)))])
(sleep 0.01)
(sync (system-idle-evt))
(let ([t2
(thread (lambda ()
(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)
(break-thread t2)
(kill-thread t)
@ -657,9 +667,9 @@
void)])
(let ([t (thread (lambda () (with-handlers ([exn:break? void])
(read-char p))))])
(sleep 0.1)
(sync (system-idle-evt))
(break-thread t)
(sleep 0.1)
(sync (system-idle-evt))
(test #f thread-running? t))))])
(try sync)
(try sync/enable-break)

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

@ -288,7 +288,7 @@
(list allowed)))
(begin
(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))))))
procs)
;; 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))
(lambda () (out 'post1))))
p1))
(printf "here ~a\n" count)
(set! count (add1 count))
(unless (= count 3)
(call-with-continuation-prompt
@ -1989,7 +1988,7 @@
;; the C stack. Eventually, the relevant segment wraps around,
;; with an overflow. Push a little deeper and then capture
;; 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)
(cond
[(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
;; 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)])
(define l
(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))
(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?)
(test #t (lambda (x) (eq? (car x) (cdr x))) (readstr "(#1=(1 2) . #0001#)"))
@ -574,6 +574,7 @@
;; Test mid-stream EOF
(define (test-mid-stream-eof use-peek?)
(define no-peek? #f)
(define chars (map (lambda (x)
(if (char? x) (char->integer x) x))
(append
@ -1181,7 +1182,7 @@
(test (void) read-language (open-input-string ";;\n;\n#xa") void)
;; Check error-message formatting:
(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
;; and not from an ill-formed srcloc construction:
(let ()
@ -1190,6 +1191,8 @@
(err/rt-test (read-language p)
(lambda (exn) (regexp-match? #rx"read-language" (exn-message exn)))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(require racket/flonum
racket/fixnum)
(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)]
[s2 (format "~aab~a" ch ch)])
(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)
#\newline
#\space)])

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

@ -1787,10 +1787,12 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Test failure handlers
(test "`+' follows nothing in pattern" regexp "+" (λ (s) s))
(test "`+' follows nothing in pattern" pregexp "+" (λ (s) s))
(test "`+' follows nothing in pattern" byte-regexp #"+" (λ (s) s))
(test "`+' follows nothing in pattern" byte-pregexp #"+" (λ (s) s))
(define (requote s) (regexp-replace* #rx"'" s "`"))
(test "`+` follows nothing in pattern" regexp "+" requote)
(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 pregexp "+" (λ (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)))))
(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

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

@ -459,7 +459,9 @@
(copy-file ,test-zo ,list-zo) =err> "access denied"
;; timestamp .zo file (needed under Windows):
(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)
;; but the module declaration can't execute due to the inspector:
(require 'list) =err> "access disallowed by code inspector"
@ -671,7 +673,7 @@
(define r1 (try 'racket/base))
(define r2 (try '(begin)))
(test #t regexp-match?
#rx"access disallowed by code inspector to protected variable"
#rx"access disallowed by code inspector to protected"
r1)
(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 . 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
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -542,14 +552,14 @@
(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)
(test `("private/promise.rkt" delay* ,base-lib delay 0 0 0)
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)
(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)
(let ([b (identifier-binding
@ -1535,7 +1545,7 @@
(test '(10 20 #t) '@!$get @!$get)
|#
(test '(12)
(test '(1) ; old expander produced 12
eval
(expand
#'(let ([b 12])
@ -1858,6 +1868,21 @@
(syntax-arm #'(begin (define-values (x y z) (values 1 2 3)))
#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
(lambda (stx)
(parameterize ([current-namespace (make-base-namespace)])
@ -1969,7 +1994,7 @@
(require (for-syntax racket/base))
(begin-for-syntax
(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
@ -2477,7 +2502,7 @@
(err/rt-test (syntax-property #'+ 1 #'+ #t)
(lambda (exn)
(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))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -2495,7 +2520,7 @@
(write (compile (read-syntax path p)) out)
(eval (read in))
(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)
(parameterize ([read-accept-compiled #t])
(read (open-input-bytes (get-output-bytes s))))))
;; Marshaling flips the order, which is ok:
(test '(subm-example-0 b) values (module-compiled-name (car (module-compiled-submodules re-c #f)))))
;; Marshaling preserves the order:
(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)
(test s3 sync/timeout SYNC-SLEEP-DELAY set)
(test #f sync/timeout SYNC-SLEEP-DELAY set))
(let* ([c (make-channel)]
[set (choice-evt s1 s2 c)])
(test #f sync/timeout SYNC-SLEEP-DELAY set)
@ -1191,21 +1191,17 @@
(break-enabled #f))
(init ;; init function gets to decide whether to do the normal body:
(lambda ()
(printf "here ~s\n" (procedure? capture-pre))
(dynamic-wind
(lambda ()
(printf "here3 ~s\n" (procedure? capture-pre))
(capture-pre
reset
(lambda ()
(printf "here4\n")
(set! did-pre1 #t)
(semaphore-post p)
(pre-thunk)
(pre-semaphore-wait s)
(set! did-pre2 #t))))
(lambda ()
(printf "here2\n")
(capture-act
reset
(lambda ()
@ -1340,9 +1336,6 @@
(body))])
;; Grab a continuation for the dyn-wind's pre/act/post
(go (lambda args
(printf "here???\n")
(printf "??? ~s\n" k+reset)
(printf "??? ~s\n" capture)
(apply mk-t
(lambda (f) (f))
(if (eq? which 'pre) capture no-capture)
@ -1372,9 +1365,9 @@
'test
(lambda (bstr) never-evt)
(lambda (bstr skip-count progress-evt)
(wrap-evt always-evt (lambda (_) 17)))
(wrap-evt always-evt (lambda (_) 1)))
void)])
;; Make sure we don't get 17
;; Make sure we don't get 1
(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))
(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 (delay (begin (set! f-check #f) 5)))
@ -1845,7 +1858,7 @@
free-identifier=?
f-id
(eval '(extract (f #:x 8)
(lv ([(proc) f2] . _) (if const? (app f3 . _) . _))
(lv _ (if const? (app f3 . _) . _))
f3
#f)))
(test
@ -1853,17 +1866,17 @@
free-identifier=?
f-id
(eval '(extract (f #:x 8)
(lv ([(proc) f2] . _) (if const? (app f3 . _) . _))
f2
#t)))
(lv _ (if const? (app f3 . _) (app2 (app3 check&extract _ f2 . _) . _)))
f2
#t)))
(test
#t
free-identifier=?
f-id
(eval '(extract (f #:y 9)
(lv ([(proc) f2] . _) . _)
f2
#t)))
(lv _ (app2 (app3 check&extract _ f2 . _) . _))
f2
#t)))
(test
#t
free-identifier=?

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

@ -557,6 +557,9 @@
(sleep)
'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 ()
(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?)
@ -999,9 +1002,10 @@
[loop (lambda ()
(let loop ()
(set! v (add1 v))
(sync (car all-ticks))
(set! all-ticks (cdr all-ticks))
(loop)))]
(unless (null? all-ticks)
(sync (car all-ticks))
(set! all-ticks (cdr all-ticks))
(loop))))]
[c0 (make-custodian)])
(let ([try
(lambda (resumable?)
@ -1254,7 +1258,7 @@
(collect-garbage)
(plumber-flush-all c)
(test 6 values done)
(set! h #f)
(test #t plumber-flush-handle? h)
(collect-garbage)
(plumber-flush-all c)
(test 6 values done))))

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

@ -16,6 +16,9 @@
(define we (make-will-executor))
(test #f will-try-execute we)
(test 'no will-try-execute we 'no)
;; Never GC this one:
(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-register 3 3)
(arity-test will-execute 1 1)
(arity-test will-try-execute 1 1)
(arity-test will-try-execute 1 2)
;; ----------------------------------------
;; Test custodian boxes
@ -192,7 +195,7 @@
;; ----------------------------------------
;; Phantom bytes:
(when (eq? '3m (system-type 'gc))
(unless (eq? 'cgc (system-type 'gc))
(define s (make-semaphore))
(define c (make-custodian))
(define t (parameterize ([current-custodian c])
@ -238,7 +241,7 @@
;; Check that local variables are cleared for space safety
;; 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 thds
@ -267,7 +270,7 @@
;; a reference can be important to the expansion to a call to a keyword-accepting
;; function.
(when (eq? '3m (system-type 'gc))
(unless (eq? 'cgc (system-type 'gc))
(define (mk)
(parameterize ([current-namespace (make-base-namespace)])
(eval '(module module-with-unoptimized-varref-constant racket/base
@ -356,11 +359,47 @@
(kill-thread watcher-t)
(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
;; 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))
;; Create a chain of ephemerons where we have all
@ -423,7 +462,7 @@
;; ----------------------------------------
;; Check that `apply` doesn't retain its argument
(when (eq? '3m (system-type 'gc))
(unless (eq? 'cgc (system-type 'gc))
(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/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
@ -42,94 +29,51 @@
(define-form-struct struct-shape ())
(define-form-struct (constructor-shape struct-shape) ([arity exact-nonnegative-integer?]))
(define-form-struct (predicate-shape struct-shape) ())
(define-form-struct (accessor-shape struct-shape) ([field-count exact-nonnegative-integer?]))
(define-form-struct (mutator-shape struct-shape) ([field-count exact-nonnegative-integer?]))
(define-form-struct (struct-type-shape struct-shape) ([field-count exact-nonnegative-integer?]))
(define-form-struct (predicate-shape struct-shape) ([authentic? boolean?]))
(define-form-struct (accessor-shape struct-shape) ([field-count exact-nonnegative-integer?]
[authentic? boolean?]))
(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 (property-predicate-shape struct-shape) ())
(define-form-struct (property-accessor-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 (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?]
[pos exact-nonnegative-integer?]
[const? boolean?]
[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-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 (seq expr) ([forms (listof (or/c expr? any/c))])) ; `begin'
(define-form-struct (inline-variant form) ([direct expr?]
[inline expr?]))
(define-form-struct (inline-variant zo) ([direct expr?]
[inline expr?]))
;; Definitions (top level or within module):
(define-form-struct (def-values form) ([ids (listof (or/c toplevel? symbol?))]
[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)]))
[rhs (or/c expr? seq? inline-variant? any/c)]))
(define-form-struct (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?)))]
(define-form-struct (linkl zo) ([name symbol?]
[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))]
[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?)]))
[need-instance-access? boolean?]))
(define-form-struct (linkl-directory zo) ([table (hash/c (listof symbol?) linkl-bundle?)]))
(define-form-struct (linkl-bundle zo) ([table (hash/c (or/c symbol? fixnum?)
any/c)])) ; can be anythingv, but especially a linklet
(define-form-struct (lam expr) ([name (or/c symbol? vector? empty?)]
[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
(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 (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)]
[val (or/c expr? seq? any/c)]
[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 (splice form) ([forms (listof (or/c form? any/c))])) ; top-level `begin'
(define-form-struct (varref expr) ([toplevel (or/c toplevel? #t)] [dummy (or/c toplevel? #f)])) ; `#%variable-reference'
(define-form-struct (varref expr) ([toplevel (or/c toplevel? #f #t symbol?)]
[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 (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)]
@ -182,58 +126,37 @@
[body (or/c expr? seq? any/c)]))
(define-form-struct (primval expr) ([id exact-nonnegative-integer?])) ; direct preference to a kernel primitive
;; Top-level `require'
(define-form-struct (req form) ([reqs stx?] [dummy toplevel?]))
;; Syntax objects
(define-form-struct stx ([content stx-obj?]))
(define-form-struct stx-obj ([datum any/c] ; S-expression with `wrapped` components
[wrap any/c] ; should be `wrap?`, but encoded form appears initially
[srcloc any/c] ; should be `(or/c #f srcloc?)`, but encoded form appears initially
[props (hash/c symbol? any/c)]
[tamper-status (or/c 'clean 'armed 'tainted)]))
(define-form-struct wrap ([shifts (listof module-shift?)]
[simple-scopes (listof scope?)]
[multi-scopes (listof (list/c multi-scope? (or/c #f exact-integer? (box/c exact-integer?))))]))
(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?)]
[to-inspector-desc (or/c #f symbol?)]))
(define-form-struct scope ([name (or/c 'root exact-nonnegative-integer?)] ; 'root is special; otherwise, just for printing
[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]))
(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]))
(define-form-struct binding ())
(define-form-struct (free-id=?-binding binding) ([base (and/c binding?
(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)]))
;; For backward compatibility, provide limited matching support as `compilation-top`:
(provide compilation-top)
(require (for-syntax racket/base))
(define-match-expander compilation-top
(lambda (stx)
(syntax-case stx ()
[(_ max-let-depth binding-namess prefix code)
#'(linkl-directory (hash-table ('() (linkl-bundle
(hash-table (0 (linkl _ ; name
_ ; imports
_ ; import shapes
_ ; exports
_ ; internals
_ ; lifts
_ ; source-names
(list code) ; body
max-let-depth
_))
_ (... ...))))
_ (... ...)))]))
(lambda (stx)
(syntax-case stx ()
[(_ max-let-depth binding-namess prefix code)
#'(linkl-directory (hash '() (linkl-bundle
(hasheq 0 (linkl 'top
'()
'()
'()
'()
'()
#hasheq()
(list code)
(add1 max-let-depth)
#f)))))])))

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

@ -1,92 +1,27 @@
#lang racket/base
(require syntax/modcode
syntax/modresolve
syntax/modread
setup/dirs
racket/file
racket/list
racket/path
racket/promise
openssl/sha1
(require "private/cm-minimal.rkt"
(submod "private/cm-minimal.rkt" cm-internal)
racket/contract/base
racket/place
setup/collects
compiler/compilation-path
compiler/private/dep
racket/contract/base)
racket/path
racket/promise)
(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-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
compile-lock->parallel-lock-client
install-module-hashes!
(contract-out
[current-path->mode
(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)
(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)
(let ([p-eles (explode-path (simple-form-path p))])
(let c-loop ([paths paths])
@ -163,19 +98,6 @@
[else
(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)
(cond
[(eq? root 'same) base]
@ -184,668 +106,7 @@
[else
(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-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)
[(windows) #f]
[(unix) "bin"]
[(macosx) (if (memq type '(gracketcgc gracket3m))
[(macosx) (if (memq type '(gracketcgc gracket3m gracketcs))
#f
"bin")])))
orig-binaries
@ -48,7 +48,7 @@
(make-directory dest-dir))
(let-values ([(base name dir?) (split-path b)])
(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)))
(begin
(copy-app b dest)
@ -67,7 +67,7 @@
[single-mac-app? (and executables?
(eq? 'macosx (cross-system-type))
(= 1 (length types))
(memq (car types) '(gracketcgc gracket3m)))])
(memq (car types) '(gracketcgc gracket3m gracketcs)))])
;; Create directories for libs, collects, and extensions:
(let-values ([(lib-dir collects-dir relative-collects-dir exts-dir relative-exts-dir)
(if single-mac-app?
@ -131,7 +131,7 @@
[sub-dir
(build-path 'up relative-dir)]
[(and (eq? 'macosx (cross-system-type))
(memq type '(gracketcgc gracket3m))
(memq type '(gracketcgc gracket3m gracketcs))
(not single-mac-app?))
(build-path 'up 'up 'up relative-dir)]
[else
@ -187,15 +187,23 @@
(memq 'gracket3m types))
(map copy-dll
(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)
(unless extras-only?
(when (or (memq 'racketcgc types)
(memq 'gracketcgc types))
(copy-framework "Racket" #f lib-dir))
(copy-framework "Racket" 'cgc lib-dir))
(when (or (memq 'racket3m 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)
(unless extras-only?
(let ([lib-plt-dir (build-path lib-dir "plt")])
@ -213,10 +221,14 @@
(copy-bin "racket" 'cgc #f))
(when (memq 'racket3m types)
(copy-bin "racket" '3m #f))
(when (memq 'racketcs types)
(copy-bin "racket" 'cs #f))
(when (memq 'gracketcgc types)
(copy-bin "gracket" 'cgc #t))
(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 (or (memq 'racketcgc types)
(memq 'gracketcgc types))
@ -224,7 +236,10 @@
(copy-shared-lib "mzgc" lib-dir))
(when (or (memq 'racket3m 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)
(if dll-dir
@ -248,12 +263,13 @@
;; Can't find it, so just use executable's dir:
(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)]
[sub-dir (build-path fw-name "Versions"
(if 3m?
(format "~a_3m" (version))
(version)))])
(case variant
[(3m) (format "~a_3m" (version))]
[(cs) (format "~a_CS" (version))]
[else (version)]))])
(make-directory* (build-path lib-dir sub-dir))
(let* ([fw-name (build-path sub-dir (format "~a" name))]
[dll-dir (find-framework fw-name)])
@ -308,18 +324,18 @@
binaries)]
[(macosx)
(if (and (= 1 (length types))
(memq (car types) '(gracketcgc gracket3m)))
(memq (car types) '(gracketcgc gracket3m gracketcs)))
;; Special case for single GRacket app:
(update-framework-path "@executable_path/../Frameworks/"
(car binaries)
#t)
;; General case:
(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/" )
b
(memq type '(gracketcgc gracket3m))))
(memq type '(gracketcgc gracket3m gracketcs))))
binaries types))]
[(unix)
(for-each (lambda (b type)
@ -645,14 +661,19 @@
(error 'assemble-distribution
"file is an original PLT executable, not a stub binary: ~e"
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 3m?
'gracket3m
'gracketcgc)
(if 3m?
'racket3m
'racketcgc))))
(case variant
[(3m) 'gracket3m]
[(cs) 'gracketcs]
[else 'gracketcgc])
(case variant
[(3m) 'racket3m]
[(cs) 'racketcs]
[else 'racketcgc]))))
(error 'assemble-distribution
"file is not a PLT executable: ~e"
b))))))

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

@ -60,7 +60,7 @@
#:cmdline (listof string?)
#:gracket? any/c
#:mred? any/c
#:variant (or/c '3m 'cgc)
#:variant (or/c '3m 'cgc 'cs)
#:aux (listof (cons/c symbol? any/c))
#:collects-path (or/c #f
path-string?
@ -1720,7 +1720,8 @@
(lambda () (find-cmdline
"configuration"
#"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
(lambda () (find-cmdline
"exeuctable type"
@ -1743,6 +1744,9 @@
(when (eq? variant '3m)
(file-position out (+ typepos 15))
(write-bytes #"3" out))
(when (eq? variant 'cs)
(file-position out (+ typepos 15))
(write-bytes #"s" out))
(flush-output out))
(file-position out (+ numpos 7))
(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)))
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)
(call-with-input-file*
src-file
@ -275,7 +283,7 @@
void)))))))
(define (expand-elf in dest-file
;; Current state parted from `in`:
;; Current state parsed from `in`:
elf sections programs str-section strs total-size
;; New state:
section-name ; #f or name of new section

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

@ -23,16 +23,17 @@
dest)])
(for-each (lambda (p)
(let* ([orig (get-current-framework-path dest p)]
[3m (if (and orig (regexp-match #rx"_3m" orig))
"_3m"
"")]
[variant (cond
[(and orig (regexp-match #rx"_3m" orig)) "_3m"]
[(and orig (regexp-match #rx"_CS" orig)) "_CS"]
[else ""])]
[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?
(format "~a" fw-path)
(format "~a~a.framework/Versions/~a~a/~a"
fw-path
p (version) 3m p))])
p (version) variant p))])
(get/set-dylib-path dest
(byte-regexp
(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
;; 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)])
(dynamic-wind
void
@ -136,7 +137,8 @@
[nreloc (read-ulong p)]
[flags (read-ulong p)])
(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")
(set! min-used offset)))
;; (printf " ~s,~s 0x~x 0x~x\n" seg sect offset vmsz)
@ -276,7 +278,7 @@
(file-position out link-edit-pos)
(write-ulong (if link-edit-64? #x19 1) out) ; LC_SEGMENT[_64]
(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) outlen out)
((if link-edit-64? write-xulong write-ulong) out-offset out)
@ -378,6 +380,9 @@
(close-input-port p)
(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)
(when (and out (not (zero? delta)))
(file-position p (+ pos d))

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

@ -1,11 +1,12 @@
(module windlldir racket/base
(require racket/port
racket/promise
"winutf16.rkt")
(provide update-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 (update-dll-dir dest path)
@ -17,7 +18,7 @@
(error 'update-dll-dir "path too long: ~e" path))
(let ([m (with-input-from-file dest
(lambda ()
(regexp-match-positions label (current-input-port))))])
(regexp-match-positions (force label) (current-input-port))))])
(unless m
(error 'update-ddl-dir "cannot find DLL path in file: ~e" dest))
(with-output-to-file dest
@ -30,7 +31,7 @@
(define (get-current-dll-dir dest)
(with-input-from-file dest
(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))
(let ([p (make-limited-input-port (current-input-port) max-dir-len)])
(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
bit-vector-copy
#f)
#f
check-bitvector)
;; A bit vector is represented as bytes.
(serializable-struct bit-vector (words size)

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

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