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

Merge branch 'master' into build-support

Browse Source 
original commit: 5806e07f1899bca867523a5ad973caa668cc7e1d
This commit is contained in:
Andy Keep 2018-04-09 21:44:32 -04:00
commit 946eb7ab0a
89 changed files with 4609 additions and 883 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

131
LOG
View File

@ -788,3 +788,134 @@
- fix bounds checking with an immediate index on immutable vectors,
fxvectors, strings, and bytevectors
cpnanopass.ss, 5_5.ms, 5_6.ms, bytevector.ms
- fix a few signatures
primdata.ss
- more staid and consistent Mf-cross main target
Mf-cross
- cpletrec now replaces the incoming prelexes with new ones so
that it doesn't have to alter the flags on the incoming ones, since
the same expander output is passed through the compiler twice while
compiling a file with macro definitions or libraries. we were
getting away without this just by luck.
cpletrec.ss
- pure? and ivory? now return #t for a primref only if the prim is
declared to be a proc, since some non-proc prims are mutable, e.g.,
$active-threads and $collect-request-pending.
cp0.ss
- $error-handling-mode? and $eol-style? are now properly declared to
be procs rather than system state variables.
primdata.ss
- the new pass $check-prelex-flags verifies that prelex referenced,
multiply-referenced, and assigned flags are set when they
should be. (it doesn't, however, complain if a flag is set
when it need not be.) when the new system parameter
$enable-check-prelex-flags is set, $check-prelex-flags is
called after each major pass that produces Lsrc forms to verify
that the flags are set correctly in the output of the pass.
this parameter is unset by default but set when running the
mats.
cprep.ss, back.ss, compile.ss, primdata.ss,
mats/Mf-base
- removed the unnecessary set of prelex referenced flag from the
build-ref routines when we've just established that it is set.
syntax.ss, compile.ss
- equivalent-expansion? now prints differences to the current output
port to aid in debugging.
mat.ss
- the nanopass that patches calls to library globals into calls to
their local counterparts during whole-program optimization now
creates new prelexes and sets the prelex referenced, multiply
referenced, and assigned flags on the new prelexes rather than
destructively setting flags on the incoming prelexes. The
only known problems this fixes are (1) the multiply referenced
flag was not previously being set for cross-library calls when
it should have been, resulting in overly aggressive inlining
of library exports during whole-program optimization, and (2)
the referenced flag could sometimes be set for library exports
that aren't actually used in the final program, which could
prevent some unreachable code from being eliminated.
compile.ss
- added support for specifying default record-equal and
record-hash procedures.
primdata.ss, cmacros.ss, cpnanopass.ss, prims.ss, newhash.ss,
gc.c,
record.ms
- added missing call to relocate for subset-mode tc field, which
wasn't burning us because the only valid non-false value, the
symbol system, is in the static generation after the initial heap
compaction.
gc.c
- added a lambda-commonization pass that runs after the other
source optimizations, particularly inlining, and a new parameter
that controls how hard it works. the value of commonization-level
ranges from 0 through 9, with 0 disabling commonization and 9
maximizing it. The default value is 0 (disabled). At present,
for non-zero level n, the commonizer attempts to commonize
lambda expressions consisting of 2^(10-n) or more nodes.
commonization of one or more lambda expressions requires that
they have identical structure down to the leaf nodes for quote
expressions, references to unassigned variables, and primitives.
So that various downstream optimizations aren't disabled, there
are some additional restrictions, the most important of which
being that call-position expressions must be identical. The
commonizer works by abstracting the code into a helper that
takes the values of the differing leaf nodes as arguments.
the name of the helper is formed by concatenating the names of
the original procedures, separated by '&', and this is the name
that will show up in a stack trace. The source location will
be that of one of the original procedures. Profiling inhibits
commonization, because commonization requires profile source
locations to be identical.
cpcommonize.ss (new), compile.ss, interpret.ss, cprep.ss,
primdata.ss, s/Mf-base,
mats/Mf-base
- cpletrec now always produces a letrec rather than a let for
single immutable lambda bindings, even when not recursive, for
consistent expand/optimize output whether the commonizer is
run or not.
cpletrec.ss,
record.ms
- trans-make-ftype-pointer no longer generates a call to
$verify-ftype-address if the address expression is a call to
ftype-pointer-address.
ftype.ss
- Remove special case for (#2%map p '()) in cp0
so the reduced version checks that p is a procedure.
Also make the same change for #2%for-each.
cp0.ss, 4.ms
- Mitigate a race condition in Windows when deleting files and directories.
windows.c
- add (& ftype) argument/result for foreign-procedure, which supports
struct arguments and results for foreign calls
syntax.ss, ftype.ss, cpnanopass.ss, x86.ss, x86_64.ss,
base-lang.ss, np-languages.ss, cprep.ss, primdata.ss,
schlib.c, prim.c, externs.h
mats/foreign4.c, mats/foreign.ms mats/Mf-*
foreign.stex, release_notes.stex
- reworked the S_call_help/S_return CCHAIN handling to fix a bug in which
the signal handler could trip over the NULL jumpbuf in a CCHAIN record.
schlib.c
- install equates.h, kernel.o, and main.o on unix-like systems
Mf-install.in
- standalone export form now handles (import import-spec ...)
8.ms, syntax.ss, release_notes.stex
- add collect-rendezvous
prim.c, 7.ss, primdata.ss, 7.ms, smgmt.stex, release_notes.stex
- added identifier? checks to detect attempts to use non-identifier
field names in define-record-type field specs.
syntax.ss,
record.ms, root-experr*
- fixed an issue with the library system where an exception that occurs
during visit or revisit left the library in an inconsistent state that
caused it to appear that it was still in the process of running. This
manifested in it raising a cyclic dependency exception, even though
there really is not a cyclic dependency. The various library
management functions involved will now reset the part of the library
when an exception occurs. This also means that if the library visit
or revisit failed for a transient reason (such as a missing or
incorrect library version that can be fixed by updating the
library-directories) it is now possible to recover from these errors.
expand-lang.ss, syntax.ss, interpret.ss, compile.ss, cprep.ss,
8.ms
- Added -Wno-implicit-fallthrough flag to macOS C makefiles.
c/Mf-a6osx, c/Mf-i3osx, c/Mf-ta6osx, c/Mf-ti3osx

2
c/Mf-a6osx
View File

@ -17,7 +17,7 @@ m = a6osx
Cpu = X86_64
mdclib = -liconv -lm -lncurses
C = ${CC} ${CPPFLAGS} -m64 -Wpointer-arith -Wall -Wextra -Werror -O2 -I/opt/X11/include/ ${CFLAGS}
C = ${CC} ${CPPFLAGS} -m64 -Wpointer-arith -Wall -Wextra -Wno-implicit-fallthrough -Werror -O2 -I/opt/X11/include/ ${CFLAGS}
o = o
mdsrc = i3le.c
mdobj = i3le.o

2
c/Mf-i3osx
View File

@ -17,7 +17,7 @@ m = i3osx
Cpu = I386
mdclib = -liconv -lm -lncurses
C = ${CC} ${CPPFLAGS} -m32 -Wpointer-arith -Wall -Wextra -Werror -O2 -msse2 -I/opt/X11/include/ ${CFLAGS}
C = ${CC} ${CPPFLAGS} -m32 -Wpointer-arith -Wall -Wextra -Wno-implicit-fallthrough -Werror -O2 -msse2 -I/opt/X11/include/ ${CFLAGS}
o = o
mdsrc = i3le.c
mdobj = i3le.o

2
c/Mf-ta6osx
View File

@ -17,7 +17,7 @@ m = ta6osx
Cpu = X86_64
mdclib = -liconv -lm -lncurses
C = ${CC} ${CPPFLAGS} -m64 -Wpointer-arith -Wall -Wextra -Werror -O2 -I/opt/X11/include/ ${CFLAGS}
C = ${CC} ${CPPFLAGS} -m64 -Wpointer-arith -Wall -Wextra -Wno-implicit-fallthrough -Werror -O2 -I/opt/X11/include/ ${CFLAGS}
o = o
mdsrc = i3le.c
mdobj = i3le.o

2
c/Mf-ti3osx
View File

@ -17,7 +17,7 @@ m = ti3osx
Cpu = I386
mdclib = -liconv -lm -lncurses
C = ${CC} ${CPPFLAGS} -m32 -Wpointer-arith -Wall -Wextra -Werror -O2 -msse2 -I/opt/X11/include/ ${CFLAGS}
C = ${CC} ${CPPFLAGS} -m32 -Wpointer-arith -Wall -Wextra -Wno-implicit-fallthrough -Werror -O2 -msse2 -I/opt/X11/include/ ${CFLAGS}
o = o
mdsrc = i3le.c
mdobj = i3le.o

15
c/externs.h
View File

@ -338,18 +338,9 @@ extern void S_machine_init PROTO((void));
extern void S_initframe PROTO((ptr tc, iptr n));
extern void S_put_arg PROTO((ptr tc, iptr i, ptr x));
extern void S_return PROTO((void));
extern void S_call_help PROTO((ptr tc, IBOOL singlep));
extern void S_call_void PROTO((void));
extern ptr S_call_ptr PROTO((void));
extern iptr S_call_fixnum PROTO((void));
extern I32 S_call_int32 PROTO((void));
extern U32 S_call_uns32 PROTO((void));
extern double S_call_double PROTO((void));
extern float S_call_single PROTO((void));
extern U8 *S_call_bytevector PROTO((void));
extern I64 S_call_int64 PROTO((void));
extern U64 S_call_uns64 PROTO((void));
extern uptr S_call_fptr PROTO((void));
extern void S_call_help PROTO((ptr tc, IBOOL singlep, IBOOL lock_ts));
extern void S_call_one_result PROTO((void));
extern void S_call_any_results PROTO((void));
#ifdef WIN32
/* windows.c */

8
c/gc.c
View File

@ -1500,9 +1500,13 @@ static void sweep_thread(p) ptr p; {
/* immediate GENERATEINSPECTORINFORMATION */
/* immediate GENERATEPROFILEFORMS */
/* immediate OPTIMIZELEVEL */
relocate(&PARAMETERS(tc))
relocate(&SUBSETMODE(tc))
/* immediate SUPPRESSPRIMITIVEINLINING */
relocate(&DEFAULTRECORDEQUALPROCEDURE(tc))
relocate(&DEFAULTRECORDHASHPROCEDURE(tc))
/* U64 INSTRCOUNTER(tc) */
/* U64 ALLOCCOUNTER(tc) */
relocate(&PARAMETERS(tc))
for (i = 0 ; i < virtual_register_count ; i += 1) {
relocate(&VIRTREG(tc, i));
}
@ -2126,7 +2130,7 @@ static int check_dirty_ephemeron(ptr pe, int tg, int youngest) {
youngest = tg;
} else {
/* Not reached, so far; add to pending list */
add_ephemeron_to_pending(pe);
add_ephemeron_to_pending(pe);
/* Make the consistent (but pessimistic w.r.t. to wrong-way
pointers) assumption that the key will stay live and move
to the target generation. That assumption covers the value

14
c/prim.c
View File

@ -134,17 +134,8 @@ static void create_c_entry_vector() {
install_c_entry(CENTRY_scan_remembered_set, proc2ptr(S_scan_remembered_set));
install_c_entry(CENTRY_instantiate_code_object, proc2ptr(s_instantiate_code_object));
install_c_entry(CENTRY_Sreturn, proc2ptr(S_return));
install_c_entry(CENTRY_Scall_ptr, proc2ptr(S_call_ptr));
install_c_entry(CENTRY_Scall_fptr, proc2ptr(S_call_fptr));
install_c_entry(CENTRY_Scall_bytevector, proc2ptr(S_call_bytevector));
install_c_entry(CENTRY_Scall_fixnum, proc2ptr(S_call_fixnum));
install_c_entry(CENTRY_Scall_int32, proc2ptr(S_call_int32));
install_c_entry(CENTRY_Scall_uns32, proc2ptr(S_call_uns32));
install_c_entry(CENTRY_Scall_double, proc2ptr(S_call_double));
install_c_entry(CENTRY_Scall_single, proc2ptr(S_call_single));
install_c_entry(CENTRY_Scall_int64, proc2ptr(S_call_int64));
install_c_entry(CENTRY_Scall_uns64, proc2ptr(S_call_uns64));
install_c_entry(CENTRY_Scall_void, proc2ptr(S_call_void));
install_c_entry(CENTRY_Scall_one_result, proc2ptr(S_call_one_result));
install_c_entry(CENTRY_Scall_any_results, proc2ptr(S_call_any_results));
for (i = 0; i < c_entry_vector_size; i++) {
#ifndef PTHREADS
@ -186,6 +177,7 @@ void S_prim_init() {
Sforeign_symbol("(cs)enable_object_counts", (void *)S_enable_object_counts);
Sforeign_symbol("(cs)set_enable_object_counts", (void *)S_set_enable_object_counts);
Sforeign_symbol("(cs)object_counts", (void *)S_object_counts);
Sforeign_symbol("(cs)fire_collector", (void *)S_fire_collector);
}
static void s_instantiate_code_object() {

2
c/scheme.c
View File

@ -320,7 +320,7 @@ static ptr boot_call(tc, p, n) ptr tc; ptr p; INT n; {
CP(tc) = Svoid; /* don't have calling code object */
AC0(tc) = (ptr)(uptr)n;
S_call_help(tc, 0);
S_call_help(tc, 0, 0);
check_ap(tc);
CP(tc) = Svoid; /* leave clean so direct Scall won't choke */

86
c/schlib.c
View File

@ -199,14 +199,14 @@ ptr Scall(cp, argcnt) ptr cp; iptr argcnt; {
static ptr S_call(tc, cp, argcnt) ptr tc; ptr cp; iptr argcnt; {
AC0(tc) = (ptr)argcnt;
AC1(tc) = cp;
S_call_help(tc, 1);
S_call_help(tc, 1, 0);
return AC0(tc);
}
/* args are set up, argcnt in ac0, closure in ac1 */
void S_call_help(tc, singlep) ptr tc; IBOOL singlep; {
void S_call_help(tc, singlep, lock_ts) ptr tc; IBOOL singlep; IBOOL lock_ts; {
/* declaring code volatile should be unnecessary, but it quiets gcc */
void *jb; volatile ptr code;
void *jb; volatile ptr code;
/* lock caller's code object, since his return address is sitting in
the C stack and we may end up in a garbage collection */
@ -219,7 +219,16 @@ void S_call_help(tc, singlep) ptr tc; IBOOL singlep; {
jb = CREATEJMPBUF();
if (jb == NULL)
S_error_abort("unable to allocate memory for jump buffer");
FRAME(tc, -1) = CCHAIN(tc) = Scons(Scons(jb, code), CCHAIN(tc));
if (lock_ts) {
/* Lock a code object passed in TS, which is a more immediate
caller whose return address is on the C stack */
Slock_object(TS(tc));
CCHAIN(tc) = Scons(Scons(jb, Scons(code,TS(tc))), CCHAIN(tc));
} else {
CCHAIN(tc) = Scons(Scons(jb, Scons(code,Sfalse)), CCHAIN(tc));
}
FRAME(tc, -1) = CCHAIN(tc);
switch (SETJMP(jb)) {
case 0: /* first time */
@ -252,72 +261,17 @@ void S_call_help(tc, singlep) ptr tc; IBOOL singlep; {
CP(tc) = code;
}
void S_call_void() {
void S_call_one_result() {
ptr tc = get_thread_context();
S_call_help(tc, 0);
S_call_help(tc, 1, 1);
}
ptr S_call_ptr() {
void S_call_any_results() {
ptr tc = get_thread_context();
S_call_help(tc, 1);
return AC0(tc);
S_call_help(tc, 0, 1);
}
iptr S_call_fixnum() {
ptr tc = get_thread_context();
S_call_help(tc, 1);
return Sfixnum_value(AC0(tc));
}
I32 S_call_int32() {
ptr tc = get_thread_context();
S_call_help(tc, 1);
return (I32)Sinteger_value(AC0(tc));
}
U32 S_call_uns32() {
ptr tc = get_thread_context();
S_call_help(tc, 1);
return (U32)Sinteger_value(AC0(tc));
}
I64 S_call_int64() {
ptr tc = get_thread_context();
S_call_help(tc, 1);
return S_int64_value("foreign-callable", AC0(tc));
}
U64 S_call_uns64() {
ptr tc = get_thread_context();
S_call_help(tc, 1);
return S_int64_value("foreign-callable", AC0(tc));
}
double S_call_double() {
ptr tc = get_thread_context();
S_call_help(tc, 1);
return Sflonum_value(AC0(tc));
}
float S_call_single() {
ptr tc = get_thread_context();
S_call_help(tc, 1);
return (float)Sflonum_value(AC0(tc));
}
U8 *S_call_bytevector() {
ptr tc = get_thread_context();
S_call_help(tc, 1);
return (U8 *)&BVIT(AC0(tc),0);
}
uptr S_call_fptr() {
ptr tc = get_thread_context();
S_call_help(tc, 1);
return (uptr)RECORDINSTIT(AC0(tc),0);
}
/* cchain = ((jb . co) ...) */
/* cchain = ((jb . (co . maybe-co)) ...) */
void S_return() {
ptr tc = get_thread_context();
ptr xp, yp;
@ -334,7 +288,9 @@ void S_return() {
/* error checks are done; now unlock affected code objects */
for (xp = CCHAIN(tc); ; xp = Scdr(xp)) {
Sunlock_object(CDAR(xp));
ptr p = CDAR(xp);
Sunlock_object(Scar(p));
if (Scdr(p) != Sfalse) Sunlock_object(Scdr(p));
if (xp == yp) break;
FREEJMPBUF(CAAR(xp));
}

28
c/windows.c
View File

@ -410,8 +410,18 @@ int S_windows_rmdir(const char *pathname) {
wchar_t wpathname[PATH_MAX];
if (MultiByteToWideChar(CP_UTF8,0,pathname,-1,wpathname,PATH_MAX) == 0)
return _rmdir(pathname);
else
return _wrmdir(wpathname);
else {
int rc;
if (!(rc = _wrmdir(wpathname))) {
// Spin loop until Windows deletes the directory.
int n;
for (n = 100; n > 0; n--) {
if (_wrmdir(wpathname) && (errno == ENOENT)) break;
}
return 0;
}
return rc;
}
}
int S_windows_stat64(const char *pathname, struct STATBUF *buffer) {
@ -434,8 +444,18 @@ int S_windows_unlink(const char *pathname) {
wchar_t wpathname[PATH_MAX];
if (MultiByteToWideChar(CP_UTF8,0,pathname,-1,wpathname,PATH_MAX) == 0)
return _unlink(pathname);
else
return _wunlink(wpathname);
else {
int rc;
if (!(rc = _wunlink(wpathname))) {
// Spin loop until Windows deletes the file.
int n;
for (n = 100; n > 0; n--) {
if (_wunlink(wpathname) && (errno == ENOENT)) break;
}
return 0;
}
return rc;
}
}
char *S_windows_getcwd(char *buffer, int maxlen) {

36
csug/foreign.stex
View File

@ -550,12 +550,24 @@ under Windows running on Intel hardware.
\foreigntype{\scheme{(* \var{ftype})}}
\index{ftype}This type allows a pointer to a foreign
type (ftype) to be passed.
The argument must be an ftype pointer of with type \var{ftype},
The argument must be an ftype pointer of type \var{ftype},
and the actual argument is the address encapsulated in the
ftype pointer.
See Section~\ref{SECTFOREIGNDATA} for a description of
foreign types.
\foreigntype{\scheme{(& \var{ftype})}}
\index{ftype}This type allows a foreign
type (ftype) to be passed as a value, but represented
on the Scheme side as a pointer to the foreign-type data.
That is, a \scheme{(& \var{ftype})} argument is represented on
the Scheme side the same as a \scheme{(* \var{ftype})} argument,
but a \scheme{(& \var{ftype})} argument is passed to the foreign procedure as the
content at the foreign pointer's address instead of as the
address. For example, if \var{ftype} is a \scheme{struct} type,
then \scheme{(& \var{ftype})} passes a struct argument instead of
a struct-pointer argument. The \var{ftype} cannot refer to an array type.
\medskip\noindent
The result types are similar to the parameter types with the addition of a
\index{\scheme{void}}\scheme{void} type.
@ -814,6 +826,16 @@ ftype pointer encapsulating the address is returned.
See Section~\ref{SECTFOREIGNDATA} for a description of
foreign types.
\foreigntype{\scheme{(& \var{ftype})}}
\index{ftype}The result is interpreted as a foreign object
whose structure is described by \var{ftype}, where the foreign
procedure returns a \var{ftype} result, but the caller
must provide an extra \scheme{(* \var{ftype})} argument before
all other arguments to receive the result. An unspecified Scheme object
is returned when the foreign procedure is called, since the result
is instead written into storage referenced by the extra argument.
The \var{ftype} cannot refer to an array type.
\medskip\noindent
Consider a C identity procedure:
\schemedisplay
@ -969,6 +991,12 @@ except that the requirements and conversions are effectively reversed,
e.g., the conversions described for \scheme{foreign-procedure}
arguments are performed for \scheme{foreign-callable} return
values.
A \scheme{(& \var{ftype})} argument to the callable refers to an address
that is valid only during the dynamic extent of the callback invocation.
A \scheme{(& \var{ftype})} result type for a callable causes the Scheme
procedure to receive an extra \scheme{(& \var{ftype})} argument before
all others; the Scheme procedure should write a result into the extra
argument, and the direct result of the Scheme procedure is ignored.
Type checking is performed for result values but not argument values,
since the parameter
values are provided by the foreign code and must be assumed to be
@ -1039,8 +1067,8 @@ void cb_init(void) {
callbacks[i] = (CB)0;
}
void register_callback(char c, int cb) {
callbacks[c] = (CB)cb;
void register_callback(char c, CB cb) {
callbacks[c] = cb;
}
void event_loop(void) {
@ -1062,7 +1090,7 @@ Interfaces to these functions may be defined in Scheme as follows.
(define cb-init
(foreign-procedure "cb_init" () void))
(define register-callback
(foreign-procedure "register_callback" (char int) void))
(foreign-procedure "register_callback" (char void*) void))
(define event-loop
(foreign-procedure "event_loop" () void))
\endschemedisplay

11
csug/intro.stex
View File

@ -13,15 +13,12 @@
% limitations under the License.
\chapter{Introduction}
{\ChezScheme} is an implementation of the Revised$^6$ Report on
Scheme~\cite{r6rs} (R6RS) with numerous language and programming environment
extensions.
This book describes these extensions in detail.
This book describes {\ChezScheme} extensions to the Revised$^6$
Report on Scheme~\cite{r6rs} (R6RS).
It contains as well a concise summary of standard and {\ChezScheme} forms
and procedures, which gives the syntax of each form and the number and
types of arguments accepted by each procedure.
Details on standard Scheme features can be found in
Details on standard R6RS features can be found in
\index{The Scheme Programming Language, 4th Edition@\emph{The Scheme Programming Language, 4th Edition}}\hyperlink{http://www.scheme.com/tspl4/}{\emph{The
Scheme Programming Language, 4th Edition}} (TSPL4)~\cite{Dybvig:tspl4} or
the Revised$^6$ Report on Scheme.
@ -96,7 +93,7 @@ Online versions and errata for this book and for TSPL4 can be found at
\bigskip\noindent
\emph{Acknowledgments:}
Michael Adams, Mike Ashley, Carl Bruggeman, Bob Burger, Sam
Daniel, George Davidson, Aziz Ghuloum, Bob Hieb, Andy Keep, and Oscar Waddell have
Daniel, George Davidson, Matthew Flatt, Aziz Ghuloum, Bob Hieb, Andy Keep, and Oscar Waddell have
contributed substantially to the development of {\ChezScheme}.
{\ChezScheme}'s expression editor is based on a command-line editor for
Scheme developed from 1989 through 1994 by C.~David Boyer.

2
csug/numeric.stex
View File

@ -117,7 +117,7 @@ Section~\ref{SECTNUMERICMISC}.
The Revised$^6$ Report distinguishes two types of special numeric objects:
fixnums and flonums.
{\ChezScheme} additionally distinguishes \emph{bignums} (exact integers outside
of the bignum range) and \emph{ratnums} (ratios of exact integers).
of the fixnum range) and \emph{ratnums} (ratios of exact integers).
It also provides a predicate for recognizing \emph{cflonums}, which are
flonums or inexact complex numbers.

57
csug/objects.stex
View File

@ -2380,6 +2380,12 @@ comparison of potentially cyclic structure.
When comparing two non-eq? instances that do not share an equality
procedure, \scheme{equal?} returns \scheme{#f}.
A default equality procedure to be used for all record types (including
opaque types) can be specified via the parameter
\index{\scheme{default-record-equal-procedure}}\scheme{default-record-equal-procedure}.
The default equality procedure is used only if neither instance's type has or inherits
a type-specific record equality procedure.
\index{record hashing}\index{\scheme{equal-hash} on records}%
Similarly, when the \index{\scheme{equal-hash}}\scheme{equal-hash}
primitive hashes a record instance, it defaults to a value that is
@ -2391,11 +2397,18 @@ that describes the record type.
The procedure \index{\scheme{record-hash-procedure}}\scheme{record-hash-procedure} can be used to find
the hash procedure for a given record instance, following the inheritance
chain.
\var{equal-hash} passes \var{hash-proc} two arguments: the
\var{equal-hash} passes the hash procedure two arguments: the
instance plus a \var{hash} procedure that should be used for
recursive hashing of values within the instance.
Use of \var{hash} for recursive hashing is necessary to allow
hashing of potentially cyclic structure.
hashing of potentially cyclic structure and to make the hashing
of shared structure more efficient.
A default hash procedure to be used for all record types (including
opaque types) can be specified via the parameter
\index{\scheme{default-record-hash-procedure}}\scheme{default-record-hash-procedure}.
The default hash procedure is used only if an instance's type does not have or inherit
a type-specific hash procedure.
The following example illustrates the setting of equality and hash
procedures.
@ -2532,6 +2545,10 @@ If \var{hash-proc} is \scheme{#f}, any existing association between
In the second form, \scheme{record-type-hash-procedure} returns
the hash procedure associated with \var{rtd}, if any, otherwise \scheme{#f}.
The procedure \var{hash-proc} should accept two arguments, the
instance for which it should compute a hash value and a hash procedure
to use to compute hash values for arbitrary fields of the instance,
and it return a nonnegative exact integer.
A record type's hash procedure should produce the same hash value
for any two instances the record type's equality procedure considers
equal.
@ -2550,6 +2567,42 @@ If such type is found, the hash procedure associated with the type
is returned.
Otherwise, \scheme{#f} is returned.
%----------------------------------------------------------------------------
\entryheader
\formdef{default-record-equal-procedure}{\categorythreadparameter}{default-record-equal-procedure}
\listlibraries
\endentryheader
This parameter determines how two record instances are compared by
\scheme{equal?} if neither has a type-specific equality procedure.
When the parameter has the value \scheme{#f} (the default), \scheme{equal?}
compares the instances with \scheme{eq?}, i.e., there is no attempt at
determining structural equivalence.
Otherwise, the parameter's value must be a procedure, and \scheme{equal?}
invokes that procedure to compare the instances, passing it three arguments:
the two instances and a procedure that should be used to recursively
compare arbitrary values within the instances.
%----------------------------------------------------------------------------
\entryheader
\formdef{default-record-hash-procedure}{\categorythreadparameter}{default-record-hash-procedure}
\listlibraries
\endentryheader
This parameter determines the hash procedure used when \scheme{equal-hash}
is called on a record instance and the instance does not have a type-specific
hash procedure.
When the parameter has the value \scheme{#f} (the default), \scheme{equal-hash}
returns a value that is independent of the record type and contents
of the instance.
Otherwise, the parameter's value must be a procedure, and \scheme{equal-hash}
invokes the procedure to compute the instance's hash value, passing it
the record instance and a procedure to invoke to recursively compute
hash values for arbitrary values contained within the record.
The procedure should return a nonnegative exact integer, and the
return value should be the same for any two instances the default
equal procedure considers equivalent.
\section{Legacy Record Types\label{SECTCSV7RECORDS}}
\index{records}\index{\scheme{define-record}}\index{\scheme{make-record-type}}%

78
csug/preface.stex
View File

@ -13,33 +13,26 @@
% limitations under the License.
\chapter{Preface}
{\ChezScheme} Version~9 is a complete implementation of the language of
the Revised$^6$ Report on Scheme (R6RS), with numerous extensions.
The implementation is extensively tested and actively maintained and supported.
It includes a fast compiler that generates efficient native code for each
processor upon which it runs along with a run-time system that provides
automatic storage management, foreign language interfaces, and an
{\ChezScheme} is both a general-purpose programming language and
an implementation of that language, with supporting tools and
documentation.
As a superset of the language described in the Revised$^6$ Report
on Scheme (R6RS), {\ChezScheme} supports all standard features of
Scheme, including first-class procedures, proper treatment of tail
calls, continuations, user-defined records, libraries, exceptions,
and hygienic macro expansion.
{\ChezScheme} supports numerous non-R6RS features.
A few of these are local and top-level modules,
local import, foreign datatypes and procedures, nonblocking I/O,
an interactive top-level, compile-time values and properties,
pretty-printing, and formatted output.
The implementation includes a compiler that generates native code
for each processor upon which it runs along with a run-time system
that provides automatic storage management, foreign-language
interfaces, source-level debugging, profiling support, and an
extensive run-time library.
The compiler has been rewritten for Version~9 and generates
substantially faster code than the earlier compiler at the cost of
additional compile time.
This is the primary difference between Versions~8 and~9.
This book is a companion to \emph{The Scheme Programming Language, 4th
Edition} (TSPL4).
While TSPL4 describes only standard R6RS features, this book describes
{\ChezScheme} extensions.
For the reader's convenience, the summary of forms and index at the back
of this book contain entries from both books, with each entry from TSPL4
marked with a ``t'' in front of its page number.
In the online version, the page numbers given in the summary of forms and
index double as direct links into one of the documents or the other.
Additional documentation for {\ChezScheme} includes release notes, a
manual page, and a number of published papers and articles that describe
various aspects of the system's design and implementation.
The threaded versions of {\ChezScheme} support native threads, allowing
Scheme programs to take advantage of multiprocessor or multiple-core
systems.
@ -55,4 +48,39 @@ mechanism, and command completion.
Unlike most shells that support command-line editing, the expression
editor properly supports multiline expressions.
{\ChezScheme} is intended to be as reliable and efficient as possible,
with reliability taking precedence over efficiency if necessary.
Reliability means behaving as designed and documented.
While a {\ChezScheme} program can always fail to work properly
because of a bug in the program, it should never fail because of a
bug in the {\ChezScheme} implementation.
Efficiency means performing at a high level, consuming minimal CPU
time and memory.
Performance should be balanced across features, across run time and
compile time, and across programs and data of different sizes.
These principles guide {\ChezScheme} language and tool design as
well as choice of implementation technique; for example, a language
feature or debugging hook might not exist in {\ChezScheme} because
its presence would reduce reliability, efficiency, or both.
The compiler has been rewritten for Version~9 and generates
substantially faster code than the earlier compiler at the cost of
greater compile time.
This is the primary difference between Versions~8 and~9.
This book (CSUG) is a companion to \emph{The Scheme Programming
Language, 4th Edition} (TSPL4).
TSPL4 serves as an introduction to and reference for R6RS, while
CSUG describes {\ChezScheme} features and tools that are not part
of R6RS.
For the reader's convenience, the summary of forms and index at the back
of this book contain entries from both books, with each entry from TSPL4
marked with a ``t'' in front of its page number.
In the online version, the page numbers given in the summary of forms and
index double as direct links into one of the documents or the other.
Additional documentation for {\ChezScheme} includes release notes, a
manual page, and a number of published papers and articles that describe
various aspects of the system's design and implementation.
Thank you for using {\ChezScheme}.

19
csug/smgmt.stex
View File

@ -153,6 +153,25 @@ The system determines which generations to collect, based on \var{g} and
\var{tg} if provided, as described in the lead-in to this section.
%----------------------------------------------------------------------------
\entryheader
\formdef{collect-rendezvous}{\categoryprocedure}{(collect-rendezvous)}
\returns unspecified
\listlibraries
\endentryheader
\noindent
Requests a garbage collection in the same way as when the system
determines that a collection should occur. All running threads are
coordinated so that one of them calls the collect-request handler, while
the other threads pause until the handler returns.
Note that if the collect-request handler (see
\scheme{collect-request-handler}) does not call \scheme{collect}, then
\scheme{collect-rendezvous} does not actualy perform a garbage
collection.
%----------------------------------------------------------------------------
\entryheader
\formdef{collect-notify}{\categoryglobalparameter}{collect-notify}

28
csug/system.stex
View File

@ -2631,6 +2631,34 @@ would be reduced to \scheme{3628800}, but
would be left unchanged, although the optimizer may take a while to
reach this decision if the effort and outer unroll limits are large.
%----------------------------------------------------------------------------
\entryheader
\formdef{commonization-level}{\categorythreadparameter}{commonization-level}
\listlibraries
\endentryheader
After running the main source optimization pass (cp0) for the last time, the
compiler optionally runs a \emph{commonization} pass.
The pass commonizes the code for lambda expressions that have
identical structure by abstracting differences at certain leaves
of the program, namely constants, references to unassigned variables,
and references to primitives.
The parameter \scheme{commonization-level} controls whether commonization
is run and, if so, how aggressive it is.
Its value must be a nonnegative exact integer ranging from 0 through 9.
When the parameter is set to 0, the default, commonization is not run.
Otherwise, higher values result in more commonization.
Commonization can undo some of the effects of cp0's inlining, can
add run-time overhead, and can complicate debugging, particularly
at higher commonization levels, which is why it is disabled by
default.
On the other hand, for macros or other meta programs that can
generate large, mostly similar lambda expressions, enabling
commonization can result in significant savings in object-code size
and even reduce run-time overhead by making more efficient use of
instruction caches.
%----------------------------------------------------------------------------
\entryheader
\formdef{undefined-variable-warnings}{\categorythreadparameter}{undefined-variable-warnings}

5
makefiles/Makefile-csug.in
View File

@ -1,7 +1,7 @@
m = $(m)
Scheme=../$m/bin/$m/scheme -b ../$m/boot/$m/petite.boot -b ../$m/boot/$m/scheme.boot
STEXLIB=../stex
installdir=/tmp/csug9
installdir=/tmp/csug9.5
INSTALL=../$m/installsh
x = csug
@ -16,7 +16,8 @@ target: logcheck1 logcheck2 checklibs $(x).html $(x).pdf
install: target
$(INSTALL) -m 2755 -d $(installdir)
$(INSTALL) -m 0644 --ifdiff *.html *.pdf *.css $(installdir)
$(INSTALL) -m 0644 --ifdiff *.html *.css $(installdir)
$(INSTALL) -m 0644 --ifdiff csug.pdf $(installdir)/csug9_5.pdf
$(INSTALL) -m 2755 -d $(installdir)/canned
$(INSTALL) -m 0644 --ifdiff canned/* $(installdir)/canned
$(INSTALL) -m 2755 -d $(installdir)/gifs

3
makefiles/Mf-install.in
View File

@ -123,6 +123,9 @@ libbininstall: ${LibBin}
ln -f ${LibBin}/scheme.boot ${LibBin}/${InstallSchemeName}.boot;\
fi
ln -sf ${LibBin}/scheme.boot ${LibBin}/${InstallScriptName}.boot;
$I -m 444 ${Include}/equates.h ${LibBin}
$I -m 444 ${Include}/kernel.o ${LibBin}
$I -m 444 ${Include}/main.o ${LibBin}
$I -m 444 ${Include}/scheme.h ${LibBin}
maninstall: scheme.1 petite.1 ${Man}

41
mats/4.ms
View File

@ -1079,6 +1079,10 @@
((1 f k p u a) (2 g l q v b) (3 h m r w c) (4 i n s x d) (5 j o t y e))))
; make sure compiler doesn't bomb w/two few args
(procedure? (lambda (x) (map x)))
(error? ; nonprocedure
(map 3 '()))
(error? ; nonprocedure
(map 3 '() '()))
(error? ; nonprocedure
(map 3 '(a b c)))
(error? ; nonprocedure
@ -1420,6 +1424,10 @@
21)
(procedure? (lambda (x) (fold-left x)))
(procedure? (lambda (x) (fold-left x y)))
(error? ; nonprocedure
(fold-left 3 0 '()))
(error? ; nonprocedure
(fold-left 3 0 '() '()))
(error? ; nonprocedure
(fold-left 3 0 '(a b c)))
(error? ; improper list
@ -1544,6 +1552,10 @@
; make sure compiler doesn't bomb w/two few args
(procedure? (lambda (x) (fold-right x)))
(procedure? (lambda (x) (fold-right x y)))
(error? ; nonprocedure
(fold-right 3 0 '()))
(error? ; nonprocedure
(fold-right 3 0 '() '()))
(error? ; nonprocedure
(fold-right 3 0 '(a b c)))
(error? ; improper list
@ -1722,11 +1734,24 @@
; make sure compiler doesn't bomb w/two few args
(procedure? (lambda (x) (for-each x)))
(error? ; nonprocedure
(for-each 3 '()))
(error? ; nonprocedure
(for-each 3 '() '()))
(error? ; nonprocedure
(for-each 3 '(a b c)))
(error? ; nonprocedure
(parameterize ([optimize-level 3])
(eval '(#2%for-each 3 '(a b c)))))
(error? ; nonprocedure
(parameterize ([optimize-level 3])
(eval
'(let ()
(define (f p b)
(unbox b)
(#2%for-each p (if (box? b) '() '(1 2 3)))
(list p (procedure? p)))
(f 7 (box 0))))))
(error? ; improper list
(for-each pretty-print 'a))
(error? ; improper list
@ -2232,6 +2257,10 @@
(not (ormap (lambda (x y z) #t) '() '() '()))
; make sure compiler doesn't bomb w/two few args
(procedure? (lambda (x) (ormap x)))
(error? ; nonprocedure
(ormap 3 '()))
(error? ; nonprocedure
(ormap 3 '() '()))
(error? ; nonprocedure
(ormap 3 '(a b c)))
(error? ; improper list
@ -2333,6 +2362,10 @@
(eq? (andmap (lambda (x y z) #t) '() '() '()) #t)
; make sure compiler doesn't bomb w/two few args
(procedure? (lambda (x) (andmap x)))
(error? ; nonprocedure
(andmap 3 '()))
(error? ; nonprocedure
(andmap 3 '() '()))
(error? ; nonprocedure
(andmap 3 '(a b c)))
(error? ; improper list
@ -2434,6 +2467,10 @@
(not (exists (lambda (x y z) #t) '() '() '()))
; make sure compiler doesn't bomb w/two few args
(procedure? (lambda (x) (exists x)))
(error? ; nonprocedure
(exists 3 '()))
(error? ; nonprocedure
(exists 3 '() '()))
(error? ; nonprocedure
(exists 3 '(a b c)))
(error? ; improper list
@ -2535,6 +2572,10 @@
(eq? (for-all (lambda (x y z) #t) '() '() '()) #t)
; make sure compiler doesn't bomb w/two few args
(procedure? (lambda (x) (for-all x)))
(error? ; nonprocedure
(for-all 3 '()))
(error? ; nonprocedure
(for-all 3 '() '()))
(error? ; nonprocedure
(for-all 3 '(a b c)))
(error? ; improper list

39
mats/7.ms
View File

@ -3589,6 +3589,45 @@ evaluating module init
(or (not a) (not (assq 'static (cdr a)))))
)
(mat collect-rendezvous
(begin
(define (check-working-gc collect)
(with-interrupts-disabled
(let ([p (weak-cons (gensym) #f)])
(collect)
(eq? (car p) #!bwp))))
(and (check-working-gc collect)
(check-working-gc collect-rendezvous)))
(or (not (threaded?))
(let ([m (make-mutex)]
[c (make-condition)]
[done? #f])
(fork-thread
(lambda ()
(let loop ()
(mutex-acquire m)
(cond
[done?
(condition-signal c)
(mutex-release m)]
[else
(mutex-release m)
(loop)]))))
(and (check-working-gc collect-rendezvous)
;; End thread:
(begin
(mutex-acquire m)
(set! done? #t)
(condition-wait c m)
(mutex-release m)
;; Make sure the thread is really done
(let loop ()
(unless (= 1 (#%$top-level-value '$active-threads))
(loop)))
;; Plain `collect` should work again:
(check-working-gc collect)))))
)
;;; section 7.6:

262
mats/8.ms
View File

@ -7976,6 +7976,19 @@
(equal?
(let () (import ($l3)) (f (f 3)))
3)
(begin
;; (export import-spec ...) empty case
(library ($empty) (export) (import (chezscheme)) (export (import)))
#t)
(begin
(library ($l4-A) (export a) (import (chezscheme)) (define a 1))
(library ($l4-B) (export b) (import (chezscheme)) (define b 2))
#t)
(equal? '(1 2) (let () (import ($l4-A) ($l4-B)) (list a b)))
(begin
;; (export import-spec ...) multiple imports case
(library ($l4-C) (export) (import (chezscheme)) (export (import ($l4-A) ($l4-B))))
(equal? '(1 2) (let () (import ($l4-C)) (list a b))))
)
(mat library2
@ -8717,6 +8730,255 @@
"revisiting testfile-l6-prog1\n#((10 . 12))\n")
)
(mat library-regression
; test that failing invoke code does not result in cyclic dependency problem on re-run
(equal?
(separate-eval
'(begin
(library (invoke-fail)
(export x)
(import (chezscheme))
(define x #f)
(error #f "failed to load library (invoke-fail)"))
(guard (e [else
(guard (e2 [else
(display-condition e) (newline)
(display-condition e2) (newline)])
(eval 'x (environment '(chezscheme) '(invoke-fail))))])
(eval 'x (environment '(chezscheme) '(invoke-fail))))))
"Exception: failed to load library (invoke-fail)\nException: failed to load library (invoke-fail)\n")
; test that true cyclic dependency will always report the same thing
(equal?
(separate-eval
'(begin
(library (invoke-cyclic)
(export x y)
(import (chezscheme))
(define x #f)
(define y (eval '(if x 5 10) (environment '(chezscheme) '(invoke-cyclic)))))
(guard (e [else
(guard (e2 [else
(display-condition e) (newline)
(display-condition e2) (newline)])
(eval 'x (environment '(chezscheme) '(invoke-cyclic))))])
(eval 'x (environment '(chezscheme) '(invoke-cyclic))))))
"Exception: cyclic dependency involving invocation of library (invoke-cyclic)\nException: cyclic dependency involving invocation of library (invoke-cyclic)\n")
(begin
; library to help make it easier to cause a failure in the visit-code that
; does not lead to failure during compilation of the file.
(with-output-to-file "testfile-lr-l1.ss"
(lambda ()
(pretty-print
'(library (testfile-lr-l1)
(export make-it-fail)
(import (chezscheme))
(define make-it-fail (make-parameter #f (lambda (x) (and x #t)))))))
'replace)
; simple test to define one macro and potentially to raise an error when
; defining the second one.
(with-output-to-file "testfile-lr-l2.ss"
(lambda ()
(pretty-print
'(library (testfile-lr-l2)
(export M1 M2)
(import (chezscheme) (testfile-lr-l1))
(define-syntax M1
(identifier-syntax #f))
(define-syntax M2
(if (make-it-fail)
(error 'M2 "user requested failure with (make-it-fail) parameter")
(lambda (x)
(syntax-case x ()
[(_ expr) #'expr])))))))
'replace)
; more complete test that attempts to create the various types of things
; that can be defined in visit code so that we can verify things are being
; properly reset.
(with-output-to-file "testfile-lr-l3.ss"
(lambda ()
(pretty-print
'(library (testfile-lr-l3)
(export a b c d e f g h)
(import (chezscheme) (testfile-lr-l1))
(module a (x) (define x 5))
(alias b cons)
(define-syntax c (make-compile-time-value 5))
(define d 5)
(meta define e 5)
(define-syntax f (identifier-syntax #f))
(define $g (make-parameter #f))
(define-syntax g
(make-variable-transformer
(lambda (x)
(syntax-case x ()
[(set! _ v) #'($g v)]
[_ #'($g)]
[(_ e* ...) #'(($g) e* ...)]))))
(define-property f g 10)
(define-syntax h
(if (make-it-fail)
(error 'h "user requested failure with (make-it-fail) parameter")
(lambda (x)
(syntax-case x ()
[(_ expr) #'expr])))))))
'replace)
(separate-compile
'(lambda (x)
(parameterize ([compile-imported-libraries #t])
(for-each compile-library x)))
'(list "testfile-lr-l1" "testfile-lr-l2" "testfile-lr-l3"))
#t)
(equal?
(separate-eval
'(begin
(import (testfile-lr-l2) (testfile-lr-l1))
(make-it-fail #t)
(guard (e [else
(guard (e2
[else
(display-condition e) (newline)
(display-condition e2) (newline)])
(eval 'M1 (environment '(testfile-lr-l2))))])
(eval 'M1 (environment '(testfile-lr-l2))))))
"Exception in M2: user requested failure with (make-it-fail) parameter\nException in M2: user requested failure with (make-it-fail) parameter\n")
; module is defined as part of import code, run time bindings are setup as part of invoke code
(equal?
(separate-eval
'(begin
(import (testfile-lr-l3) (testfile-lr-l1))
(make-it-fail #t)
(import a)
x))
"5\n")
; alias is part of module binding ribcage, set up by import code
(equal?
(separate-eval
'(begin
(import (testfile-lr-l3) (testfile-lr-l1))
(make-it-fail #t)
(b 'a 'b)))
"(a . b)\n")
; compile-time-value is set in visit code, should show same error each time it is referenced
(equal?
(separate-eval
'(begin
(library (lookup)
(export lookup)
(import (chezscheme))
(define-syntax lookup
(lambda (x)
(syntax-case x ()
[(_ id) (lambda (rho) #`'#,(rho #'id))]
[(_ id key) (lambda (rho) #`'#,(rho #'id #'key))]))))
(import (testfile-lr-l3) (testfile-lr-l1))
(make-it-fail #t)
(guard (e [else
(guard (e2
[else
(display-condition e) (newline)
(display-condition e2) (newline)])
(eval '(lookup c) (environment '(testfile-lr-l3) '(lookup))))])
(eval '(lookup c) (environment '(testfile-lr-l3) '(lookup))))))
"Exception in h: user requested failure with (make-it-fail) parameter\nException in h: user requested failure with (make-it-fail) parameter\n")
; defines are set up as part of invoke code
(equal?
(separate-eval
'(begin
(import (testfile-lr-l3) (testfile-lr-l1))
(make-it-fail #t)
d))
"5\n")
; meta defines are set up as part of visit code
(equal?
(separate-eval
'(begin
(import (testfile-lr-l3) (testfile-lr-l1))
(make-it-fail #t)
(guard (e [else
(guard (e2
[else
(display-condition e) (newline)
(display-condition e2) (newline)])
(eval '(let ()
(define-syntax get-e
(lambda (x)
(syntax-case x ()
[(_) #`'#,e])))
(get-e))
(environment '(chezscheme) '(testfile-lr-l3))))])
(eval '(let ()
(define-syntax get-e
(lambda (x)
(syntax-case x ()
[(_) #`'#,e])))
(get-e))
(environment '(chezscheme) '(testfile-lr-l3))))))
"Exception in h: user requested failure with (make-it-fail) parameter\nException in h: user requested failure with (make-it-fail) parameter\n")
; macros are set up as part of visit code
(equal?
(separate-eval
'(begin
(import (testfile-lr-l3) (testfile-lr-l1))
(make-it-fail #t)
(guard (e [else
(guard (e2
[else
(display-condition e) (newline)
(display-condition e2) (newline)])
(eval 'f (environment '(testfile-lr-l3))))])
(eval 'f (environment '(testfile-lr-l3))))))
"Exception in h: user requested failure with (make-it-fail) parameter\nException in h: user requested failure with (make-it-fail) parameter\n")
; variable transformer macros are set up as part of visit code
(equal?
(separate-eval
'(begin
(import (testfile-lr-l3) (testfile-lr-l1))
(make-it-fail #t)
(guard (e [else
(guard (e2
[else
(display-condition e) (newline)
(display-condition e2) (newline)])
(eval 'g (environment '(testfile-lr-l3))))])
(eval 'g (environment '(testfile-lr-l3))))))
"Exception in h: user requested failure with (make-it-fail) parameter\nException in h: user requested failure with (make-it-fail) parameter\n")
; properties are setup as part of visit code.
(equal?
(separate-eval
'(begin
(library (lookup)
(export lookup)
(import (chezscheme))
(define-syntax lookup
(lambda (x)
(syntax-case x ()
[(_ id) (lambda (rho) #`'#,(rho #'id))]
[(_ id key) (lambda (rho) #`'#,(rho #'id #'key))]))))
(import (testfile-lr-l3) (testfile-lr-l1))
(make-it-fail #t)
(guard (e [else
(guard (e2
[else
(display-condition e) (newline)
(display-condition e2) (newline)])
(eval '(lookup f g) (environment '(testfile-lr-l3) '(lookup))))])
(eval '(lookup f g) (environment '(testfile-lr-l3) '(lookup))))))
"Exception in h: user requested failure with (make-it-fail) parameter\nException in h: user requested failure with (make-it-fail) parameter\n")
)
(mat cross-library-optimization
(begin
(with-output-to-file "testfile-clo-1a.ss"

4
mats/Mf-a6fb
View File

@ -15,13 +15,13 @@
m = a6fb
fsrc = foreign1.c foreign2.c foreign3.c
fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
fobj = foreign1.so
include Mf-base
foreign1.so: ${fsrc} ../boot/$m/scheme.h
cc -fPIC -shared -I${Include} -o foreign1.so foreign1.c foreign2.c foreign3.c
cc -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
cat_flush: cat_flush.c
cc -o cat_flush cat_flush.c

4
mats/Mf-a6le
View File

@ -15,13 +15,13 @@
m = a6le
fsrc = foreign1.c foreign2.c foreign3.c
fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
fobj = foreign1.so
include Mf-base
foreign1.so: ${fsrc} ../boot/$m/scheme.h
cc -m64 -fPIC -shared -I${Include} -o foreign1.so foreign1.c foreign2.c foreign3.c
cc -m64 -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
cat_flush: cat_flush.c
cc -o cat_flush cat_flush.c

4
mats/Mf-a6nb
View File

@ -15,13 +15,13 @@
m = a6nb
fsrc = foreign1.c foreign2.c foreign3.c
fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
fobj = foreign1.so
include Mf-base
foreign1.so: ${fsrc} ../boot/$m/scheme.h
cc -fPIC -shared -I${Include} -o foreign1.so foreign1.c foreign2.c foreign3.c
cc -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
cat_flush: cat_flush.c
cc -o cat_flush cat_flush.c

4
mats/Mf-a6nt
View File

@ -15,9 +15,9 @@
m = a6nt
fsrc = foreign1.c foreign2.c foreign3.c
fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
fobj = foreign1.so
mdclean = cat_flush.exe cat_flush.obj foreign1.exp foreign1.lib foreign1.obj foreign2.obj foreign3.obj
mdclean = cat_flush.exe cat_flush.obj foreign1.exp foreign1.lib foreign1.obj foreign2.obj foreign3.obj foreign4.obj
include Mf-base

4
mats/Mf-a6ob
View File

@ -15,13 +15,13 @@
m = a6ob
fsrc = foreign1.c foreign2.c foreign3.c
fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
fobj = foreign1.so
include Mf-base
foreign1.so: ${fsrc} ../boot/$m/scheme.h
cc -fPIC -shared -I${Include} -o foreign1.so foreign1.c foreign2.c foreign3.c
cc -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
cat_flush: cat_flush.c
cc -o cat_flush cat_flush.c

2
mats/Mf-a6osx
View File

@ -15,7 +15,7 @@
m = a6osx
fsrc = foreign1.c foreign2.c foreign3.c
fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
fobj = foreign1.so
include Mf-base

4
mats/Mf-a6s2
View File

@ -15,13 +15,13 @@
m = a6s2
fsrc = foreign1.c foreign2.c foreign3.c
fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
fobj = foreign1.so
include Mf-base
foreign1.so: ${fsrc} ../boot/$m/scheme.h
gcc -m64 -fPIC -shared -I${Include} -o foreign1.so foreign1.c foreign2.c foreign3.c
gcc -m64 -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
cat_flush: cat_flush.c
gcc -o cat_flush cat_flush.c

4
mats/Mf-arm32le
View File

@ -15,13 +15,13 @@
m = arm32le
fsrc = foreign1.c foreign2.c foreign3.c
fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
fobj = foreign1.so
include Mf-base
foreign1.so: ${fsrc} ../boot/$m/scheme.h
cc -fPIC -shared -I${Include} -o foreign1.so foreign1.c foreign2.c foreign3.c
cc -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
cat_flush: cat_flush.c
cc -o cat_flush cat_flush.c

30
mats/Mf-base
View File

@ -115,6 +115,14 @@ ehc = $(defaultehc)
defaulteoc = t
eoc = $(defaulteoc)
# cl determines the commonization level
defaultcl = (commonization-level)
cl = $(defaultcl)
# ecpf determines whether the compiler checks prelex flags
defaultecpf = t
ecpf = $(defaultecpf)
# set of mats to run
mats = primvars 3 4 5_1 5_2 5_3 5_4 5_5 bytevector thread\
misc cp0 5_6 5_7 5_8 6 io format 7 record hash enum 8 fx fl cfl foreign\
@ -141,11 +149,13 @@ $(objdir)/%.mo : %.ms mat.so
echo '(optimize-level $o)'\
'(#%$$suppress-primitive-inlining #${spi})'\
'(#%$$enable-check-heap #${ehc})'\
'(#%$$enable-check-prelex-flags #${ecpf})'\
'(compile-profile #$p)'\
'(collect-trip-bytes ${ctb})'\
'(collect-generation-radix ${cgr})'\
'(collect-maximum-generation ${cmg})'\
'(enable-object-counts #${eoc})'\
'(commonization-level ${cl})'\
'(compile-interpret-simple #${cis})'\
'(set! *examples-directory* "${Examples}")'\
'(enable-cp0 #${cp0})'\
@ -162,11 +172,13 @@ $(objdir)/%.mo : %.ms mat.so
echo '(optimize-level $o)'\
'(#%$$suppress-primitive-inlining #${spi})'\
'(#%$$enable-check-heap #${ehc})'\
'(#%$$enable-check-prelex-flags #${ecpf})'\
'(compile-profile #$p)'\
'(collect-trip-bytes ${ctb})'\
'(collect-generation-radix ${cgr})'\
'(collect-maximum-generation ${cmg})'\
'(enable-object-counts #${eoc})'\
'(commonization-level ${cl})'\
'(compile-interpret-simple #${cis})'\
'(set! *examples-directory* "${Examples}")'\
'(enable-cp0 #${cp0})'\
@ -222,15 +234,15 @@ partialx:
allx: prettyclean
$(MAKE) allxhelp o=0
$(MAKE) allxhelp o=3
$(MAKE) allxhelp o=0 cp0=t
$(MAKE) allxhelp o=3 cp0=t
$(MAKE) allxhelp o=0 cp0=t cl=3
$(MAKE) allxhelp o=3 cp0=t cl=3
$(MAKE) allxhelp o=0 spi=t rmg=2 p=t
$(MAKE) allxhelp o=3 spi=t rmg=2 p=t
$(MAKE) allxhelp o=0 eval=interpret
$(MAKE) allxhelp o=3 eval=interpret
$(MAKE) allxhelp o=0 eval=interpret cl=6
$(MAKE) allxhelp o=3 eval=interpret cl=6
$(MAKE) allxhelp o=0 eval=interpret cp0=t rmg=2
$(MAKE) allxhelp o=3 eval=interpret cp0=t rmg=2
$(MAKE) allxhelp o=0 eoc=f ehc=t
$(MAKE) allxhelp o=0 eoc=f ehc=t cl=9
$(MAKE) allxhelp o=3 eval=interpret ehc=t rmg=2
just-reports:
@ -252,12 +264,12 @@ bullyx:
bully:
-$(MAKE) allxhelpnotall spi=t cp0=f
-$(MAKE) allxhelp spi=f cp0=f ctb='(/ (collect-trip-bytes) 64)' ehc=t
-$(MAKE) allxhelp spi=f cp0=f cl=9 ctb='(/ (collect-trip-bytes) 64)' ehc=t
-$(MAKE) allxhelp spi=t cp0=f cis=t cmg=1
-$(MAKE) allxhelp spi=f cp0=f cis=t cmg=6 ehc=t
-$(MAKE) allxhelp spi=t cp0=t ctb='(/ (collect-trip-bytes) 64)' cgr=6
-$(MAKE) allxhelp spi=t cp0=f p=t eoc=f ehc=t
-$(MAKE) allxhelp spi=f cp0=t p=t ehc=t
-$(MAKE) allxhelp spi=f cp0=t cl=9 p=t ehc=t
-$(MAKE) allxhelp eval=interpret spi=f cp0=f
-$(MAKE) allxhelp eval=interpret spi=f cp0=t
-$(MAKE) allxhelp eval=interpret spi=t cp0=f ctb='(/ (collect-trip-bytes) 64)' ehc=t
@ -272,6 +284,7 @@ doheader:
printf "%s" "-------- o=$o" >> summary
if [ "$(spi)" != "$(defaultspi)" ] ; then printf " spi=$(spi)" >> summary ; fi
if [ "$(ehc)" != "$(defaultehc)" ] ; then printf " ehc=$(ehc)" >> summary ; fi
if [ "$(ecpf)" != "$(defaultecpf)" ] ; then printf " ecpf(ecpf)" >> summary ; fi
if [ "$(cp0)" != "$(defaultcp0)" ] ; then printf " cp0=$(cp0)" >> summary ; fi
if [ "$(cis)" != "$(defaultcis)" ] ; then printf " cis=$(cis)" >> summary ; fi
if [ "$p" != "$(defaultp)" ] ; then printf " p=$p" >> summary ; fi
@ -280,6 +293,7 @@ doheader:
if [ "$(cgr)" != "$(defaultcgr)" ] ; then printf " cgr=$(cgr)" >> summary ; fi
if [ "$(cmg)" != "$(defaultcmg)" ] ; then printf " cmg=$(cmg)" >> summary ; fi
if [ "$(eoc)" != "$(defaulteoc)" ] ; then printf " eoc=$(eoc)" >> summary ; fi
if [ "$(cl)" != "$(defaultcl)" ] ; then printf " cl=$(cl)" >> summary ; fi
if [ "$(hdrmsg)" != "" ] ; then printf " $(hdrmsg)" >> summary ; fi
dosummary:
@ -312,11 +326,13 @@ script.all$o makescript$o:
echo '(optimize-level $o)'\
'(#%$$suppress-primitive-inlining #${spi})'\
'(#%$$enable-check-heap #${ehc})'\
'(#%$$enable-check-prelex-flags #${ecpf})'\
'(compile-profile #$p)'\
'(collect-trip-bytes ${ctb})'\
'(collect-generation-radix ${cgr})'\
'(collect-maximum-generation ${cmg})'\
'(enable-object-counts #${eoc})'\
'(commonization-level ${cl})'\
'(compile-interpret-simple #${cis})'\
'(set! *examples-directory* "${Examples}")'\
'(enable-cp0 #${cp0})'\

4
mats/Mf-i3fb
View File

@ -15,13 +15,13 @@
m = i3fb
fsrc = foreign1.c foreign2.c foreign3.c
fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
fobj = foreign1.so
include Mf-base
foreign1.so: ${fsrc} ../boot/$m/scheme.h
cc -fPIC -shared -I${Include} -o foreign1.so foreign1.c foreign2.c foreign3.c
cc -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
cat_flush: cat_flush.c
cc -o cat_flush cat_flush.c

4
mats/Mf-i3le
View File

@ -15,13 +15,13 @@
m = i3le
fsrc = foreign1.c foreign2.c foreign3.c
fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
fobj = foreign1.so
include Mf-base
foreign1.so: ${fsrc} ../boot/$m/scheme.h
cc -m32 -fPIC -shared -I${Include} -o foreign1.so foreign1.c foreign2.c foreign3.c
cc -m32 -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
cat_flush: cat_flush.c
cc -o cat_flush cat_flush.c

4
mats/Mf-i3nb
View File

@ -15,13 +15,13 @@
m = i3nb
fsrc = foreign1.c foreign2.c foreign3.c
fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
fobj = foreign1.so
include Mf-base
foreign1.so: ${fsrc} ../boot/$m/scheme.h
cc -fPIC -shared -I${Include} -o foreign1.so foreign1.c foreign2.c foreign3.c
cc -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
cat_flush: cat_flush.c
cc -o cat_flush cat_flush.c

2
mats/Mf-i3nt
View File

@ -15,7 +15,7 @@
m = i3nt
fsrc = foreign1.c foreign2.c foreign3.c
fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
fobj = foreign1.so
mdclean = cat_flush.exe cat_flush.obj foreign1.exp foreign1.lib foreign1.obj foreign2.obj foreign3.obj

4
mats/Mf-i3ob
View File

@ -15,13 +15,13 @@
m = i3ob
fsrc = foreign1.c foreign2.c foreign3.c
fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
fobj = foreign1.so
include Mf-base
foreign1.so: ${fsrc} ../boot/$m/scheme.h
cc -fPIC -shared -I${Include} -o foreign1.so foreign1.c foreign2.c foreign3.c
cc -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
cat_flush: cat_flush.c
cc -o cat_flush cat_flush.c

2
mats/Mf-i3osx
View File

@ -15,7 +15,7 @@
m = i3osx
fsrc = foreign1.c foreign2.c foreign3.c
fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
fobj = foreign1.so
include Mf-base

4
mats/Mf-i3qnx
View File

@ -15,13 +15,13 @@
m = i3qnx
fsrc = foreign1.c foreign2.c foreign3.c
fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
fobj = foreign1.so
include Mf-base
foreign1.so: ${fsrc} ../boot/$m/scheme.h
cc -m32 -fPIC -shared -I${Include} -o foreign1.so foreign1.c foreign2.c foreign3.c
cc -m32 -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
cat_flush: cat_flush.c
cc -o cat_flush cat_flush.c

4
mats/Mf-i3s2
View File

@ -15,13 +15,13 @@
m = i3s2
fsrc = foreign1.c foreign2.c foreign3.c
fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
fobj = foreign1.so
include Mf-base
foreign1.so: ${fsrc} ../boot/$m/scheme.h
gcc -m32 -fPIC -shared -I${Include} -o foreign1.so foreign1.c foreign2.c foreign3.c
gcc -m32 -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
cat_flush: cat_flush.c
gcc -o cat_flush cat_flush.c

4
mats/Mf-ppc32le
View File

@ -15,13 +15,13 @@
m = ppc32le
fsrc = foreign1.c foreign2.c foreign3.c
fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
fobj = foreign1.so
include Mf-base
foreign1.so: ${fsrc} ../boot/$m/scheme.h
cc -m32 -fPIC -shared -I${Include} -o foreign1.so foreign1.c foreign2.c foreign3.c
cc -m32 -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
cat_flush: cat_flush.c
cc -o cat_flush cat_flush.c

4
mats/Mf-ta6fb
View File

@ -15,13 +15,13 @@
m = ta6fb
fsrc = foreign1.c foreign2.c foreign3.c
fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
fobj = foreign1.so
include Mf-base
foreign1.so: ${fsrc} ../boot/$m/scheme.h
cc -fPIC -shared -I${Include} -o foreign1.so foreign1.c foreign2.c foreign3.c
cc -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
cat_flush: cat_flush.c
cc -o cat_flush cat_flush.c

4
mats/Mf-ta6le
View File

@ -15,13 +15,13 @@
m = ta6le
fsrc = foreign1.c foreign2.c foreign3.c
fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
fobj = foreign1.so
include Mf-base
foreign1.so: ${fsrc} ../boot/$m/scheme.h
cc -m64 -fPIC -shared -I${Include} -o foreign1.so foreign1.c foreign2.c foreign3.c
cc -m64 -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
cat_flush: cat_flush.c
cc -o cat_flush cat_flush.c

4
mats/Mf-ta6nb
View File

@ -15,13 +15,13 @@
m = ta6nb
fsrc = foreign1.c foreign2.c foreign3.c
fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
fobj = foreign1.so
include Mf-base
foreign1.so: ${fsrc} ../boot/$m/scheme.h
cc -fPIC -shared -I${Include} -o foreign1.so foreign1.c foreign2.c foreign3.c
cc -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
cat_flush: cat_flush.c
cc -o cat_flush cat_flush.c

2
mats/Mf-ta6nt
View File

@ -15,7 +15,7 @@
m = ta6nt
fsrc = foreign1.c foreign2.c foreign3.c
fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
fobj = foreign1.so
mdclean = cat_flush.exe cat_flush.obj foreign1.exp foreign1.lib foreign1.obj foreign2.obj foreign3.obj

4
mats/Mf-ta6ob
View File

@ -15,13 +15,13 @@
m = ta6ob
fsrc = foreign1.c foreign2.c foreign3.c
fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
fobj = foreign1.so
include Mf-base
foreign1.so: ${fsrc} ../boot/$m/scheme.h
cc -fPIC -shared -I${Include} -o foreign1.so foreign1.c foreign2.c foreign3.c
cc -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
cat_flush: cat_flush.c
cc -o cat_flush cat_flush.c

2
mats/Mf-ta6osx
View File

@ -15,7 +15,7 @@
m = ta6osx
fsrc = foreign1.c foreign2.c foreign3.c
fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
fobj = foreign1.so
include Mf-base

4
mats/Mf-ta6s2
View File

@ -15,13 +15,13 @@
m = ta6s2
fsrc = foreign1.c foreign2.c foreign3.c
fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
fobj = foreign1.so
include Mf-base
foreign1.so: ${fsrc} ../boot/$m/scheme.h
gcc -m64 -fPIC -shared -I${Include} -o foreign1.so foreign1.c foreign2.c foreign3.c
gcc -m64 -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
cat_flush: cat_flush.c
gcc -o cat_flush cat_flush.c

4
mats/Mf-ti3fb
View File

@ -15,13 +15,13 @@
m = ti3fb
fsrc = foreign1.c foreign2.c foreign3.c
fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
fobj = foreign1.so
include Mf-base
foreign1.so: ${fsrc} ../boot/$m/scheme.h
cc -fPIC -shared -I${Include} -o foreign1.so foreign1.c foreign2.c foreign3.c
cc -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
cat_flush: cat_flush.c
cc -o cat_flush cat_flush.c

4
mats/Mf-ti3le
View File

@ -15,13 +15,13 @@
m = ti3le
fsrc = foreign1.c foreign2.c foreign3.c
fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
fobj = foreign1.so
include Mf-base
foreign1.so: ${fsrc} ../boot/$m/scheme.h
cc -m32 -fPIC -shared -I${Include} -o foreign1.so foreign1.c foreign2.c foreign3.c
cc -m32 -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
cat_flush: cat_flush.c
cc -o cat_flush cat_flush.c

4
mats/Mf-ti3nb
View File

@ -15,13 +15,13 @@
m = ti3nb
fsrc = foreign1.c foreign2.c foreign3.c
fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
fobj = foreign1.so
include Mf-base
foreign1.so: ${fsrc} ../boot/$m/scheme.h
cc -fPIC -shared -I${Include} -o foreign1.so foreign1.c foreign2.c foreign3.c
cc -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
cat_flush: cat_flush.c
cc -o cat_flush cat_flush.c

2
mats/Mf-ti3nt
View File

@ -15,7 +15,7 @@
m = ti3nt
fsrc = foreign1.c foreign2.c foreign3.c
fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
fobj = foreign1.so
mdclean = cat_flush.exe cat_flush.obj foreign1.exp foreign1.lib foreign1.obj foreign2.obj foreign3.obj

4
mats/Mf-ti3ob
View File

@ -15,13 +15,13 @@
m = ti3ob
fsrc = foreign1.c foreign2.c foreign3.c
fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
fobj = foreign1.so
include Mf-base
foreign1.so: ${fsrc} ../boot/$m/scheme.h
cc -fPIC -shared -I${Include} -o foreign1.so foreign1.c foreign2.c foreign3.c
cc -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
cat_flush: cat_flush.c
cc -o cat_flush cat_flush.c

2
mats/Mf-ti3osx
View File

@ -15,7 +15,7 @@
m = ti3osx
fsrc = foreign1.c foreign2.c foreign3.c
fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
fobj = foreign1.so
include Mf-base

4
mats/Mf-ti3s2
View File

@ -15,13 +15,13 @@
m = ti3s2
fsrc = foreign1.c foreign2.c foreign3.c
fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
fobj = foreign1.so
include Mf-base
foreign1.so: ${fsrc} ../boot/$m/scheme.h
gcc -m32 -fPIC -shared -I${Include} -o foreign1.so foreign1.c foreign2.c foreign3.c
gcc -m32 -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
cat_flush: cat_flush.c
gcc -o cat_flush cat_flush.c

4
mats/Mf-tppc32le
View File

@ -15,13 +15,13 @@
m = tppc32le
fsrc = foreign1.c foreign2.c foreign3.c
fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
fobj = foreign1.so
include Mf-base
foreign1.so: ${fsrc} ../boot/$m/scheme.h
cc -m32 -fPIC -shared -I${Include} -o foreign1.so foreign1.c foreign2.c foreign3.c
cc -m32 -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
cat_flush: cat_flush.c
cc -o cat_flush cat_flush.c

281
mats/foreign.ms
View File

@ -2018,7 +2018,7 @@
(foreign-callable
(lambda (x y)
(collect)
(let ([ls (make-list 20000 #\z)])
(let ([ls (map (lambda (x) (make-vector 200 x)) (make-list 100))])
(collect)
(collect)
(collect)
@ -2028,8 +2028,13 @@
(scheme-object iptr)
scheme-object))
(define (go) (Sinvoke2 Fcons 4 5))
(go))
'(20000 4 . 5))
(define initial-result (go))
(let loop ([i 100])
(if (zero? i)
initial-result
(and (equal? initial-result (go))
(loop (sub1 i))))))
'(100 4 . 5))
(eqv?
(let ()
(define Sinvoke2
@ -2486,6 +2491,31 @@
(ftype-pointer-address fptr)))
*m*)
(+ $stack-depth $base-value)))
;; Make sure that a callable is suitably locked, and that it's
;; unlocked when the C stack is popped by an escape
(equal?
(let ()
(define Sinvoke2
(foreign-procedure "Sinvoke2"
(scheme-object scheme-object iptr)
scheme-object))
(define Fcons
(foreign-callable
(lambda (k y)
;; Escape with locked, which should be #t
;; because a callable is locked while it's
;; called:
(k (locked-object? Fcons)))
(scheme-object iptr)
scheme-object))
(list
;; Call and normal callable return:
(let ([v (Sinvoke2 Fcons (lambda (x) x) 5)])
(list v (locked-object? Fcons)))
;; Escape from callable:
(let ([v ($with-exit-proc (lambda (k) (Sinvoke2 Fcons k 5)))])
(list v (locked-object? Fcons)))))
'((#t #f) (#t #f)))
)
(machine-case
@ -2643,3 +2673,248 @@
read)
'(3.5 2.5 -1.5 6.75 8.25 -9.5 1e32 -4.5 7.25 -0.5))
)
(mat structs
(begin
(define-ftype i8 integer-8)
(define-ftype u8 unsigned-8)
(define-ftype u16 unsigned-16)
(define-ftype i64 integer-64)
(define-syntax check*
(syntax-rules ()
[(_ T s [vi ...] [T-ref ...] [T-set! ...])
(let ()
(define-ftype callback (function ((& T)) double))
(define-ftype callback-two (function ((& T) (& T)) double))
(define-ftype pre-int-callback (function (int (& T)) double))
(define-ftype pre-double-callback (function (double (& T)) double))
(define-ftype callback-r (function () (& T)))
(define get (foreign-procedure (format "f4_get~a" s)
() (& T)))
(define sum (foreign-procedure (format "f4_sum~a" s)
((& T)) double))
(define sum_two (foreign-procedure (format "f4_sum_two~a" s)
((& T) (& T)) double))
(define sum_pre_int (foreign-procedure (format "f4_sum_pre_int~a" s)
(int (& T)) double))
(define sum_pre_int_int (foreign-procedure (format "f4_sum_pre_int_int~a" s)
(int int (& T)) double))
(define sum_pre_int_int_int_int (foreign-procedure (format "f4_sum_pre_int_int_int_int~a" s)
(int int int int (& T)) double))
(define sum_pre_int_int_int_int_int_int (foreign-procedure (format "f4_sum_pre_int_int_int_int_int_int~a" s)
(int int int int int int (& T)) double))
(define sum_post_int (foreign-procedure (format "f4_sum~a_post_int" s)
((& T) int) double))
(define sum_pre_double (foreign-procedure (format "f4_sum_pre_double~a" s)
(double (& T)) double))
(define sum_pre_double_double (foreign-procedure (format "f4_sum_pre_double_double~a" s)
(double double (& T)) double))
(define sum_pre_double_double_double_double (foreign-procedure (format "f4_sum_pre_double_double_double_double~a" s)
(double double double double (& T)) double))
(define sum_pre_double_double_double_double_double_double_double_double
(foreign-procedure (format "f4_sum_pre_double_double_double_double_double_double_double_double~a" s)
(double double double double double double double double (& T)) double))
(define sum_post_double (foreign-procedure (format "f4_sum~a_post_double" s)
((& T) double) double))
(define cb_send (foreign-procedure (format "f4_cb_send~a" s)
((* callback)) double))
(define cb_send_two (foreign-procedure (format "f4_cb_send_two~a" s)
((* callback-two)) double))
(define cb_send_pre_int (foreign-procedure (format "f4_cb_send_pre_int~a" s)
((* pre-int-callback)) double))
(define cb_send_pre_double (foreign-procedure (format "f4_cb_send_pre_double~a" s)
((* pre-double-callback)) double))
(define sum_cb (foreign-procedure (format "f4_sum_cb~a" s)
((* callback-r)) double))
(define-syntax with-callback
(syntax-rules ()
[(_ ([id rhs])
body)
(let ([id rhs])
(let ([v body])
(unlock-object
(foreign-callable-code-object
(ftype-pointer-address id)))
v))]))
(and (let ([v (make-ftype-pointer T (foreign-alloc (ftype-sizeof T)))])
(get v)
(and (= (T-ref v) vi)
...
(begin
(foreign-free (ftype-pointer-address v))
#t)))
(let ([a (make-ftype-pointer T (malloc_at_boundary (ftype-sizeof T)))])
(T-set! a) ...
(and (= (+ vi ...) (sum a))
(= (+ vi ... vi ...) (sum_two a a))
(= (+ 8 vi ...) (sum_pre_int 8 a))
(= (+ 8 9 vi ...) (sum_pre_int_int 8 9 a))
(= (+ 8 9 10 11 vi ...) (sum_pre_int_int_int_int 8 9 10 11 a))
(= (+ 8 9 10 11 12 13 vi ...) (sum_pre_int_int_int_int_int_int 8 9 10 11 12 13 a))
(= (+ 8 vi ...) (sum_post_int a 8))
(= (+ 8.25 vi ...) (sum_pre_double 8.25 a))
(= (+ 8.25 9.25 vi ...) (sum_pre_double_double 8.25 9.25 a))
(= (+ 8.25 9.25 10.25 11.25 vi ...) (sum_pre_double_double_double_double 8.25 9.25 10.25 11.25 a))
(= (+ 8.25 9.25 10.25 11.25 12.25 13.25 14.25 15.25 vi ...)
(sum_pre_double_double_double_double_double_double_double_double
8.25 9.25 10.25 11.25 12.25 13.25 14.25 15.25 a))
(= (+ 8.25 vi ...) (sum_post_double a 8.25))
(= (+ 1.0 vi ...) (with-callback ([cb (make-ftype-pointer
callback
(lambda (r)
(exact->inexact (+ (T-ref r) ...))))])
(cb_send cb)))
(= (+ 1.0 vi ... vi ...) (with-callback ([cb (make-ftype-pointer
callback-two
(lambda (r1 r2)
(exact->inexact (+ (T-ref r1) ...
(T-ref r2) ...))))])
(cb_send_two cb)))
(= (+ 1.0 8 vi ...) (with-callback ([cb (make-ftype-pointer
pre-int-callback
(lambda (v r)
(exact->inexact (+ v (T-ref r) ...))))])
(cb_send_pre_int cb)))
(= (+ 1.0 8.25 vi ...) (with-callback ([cb (make-ftype-pointer
pre-double-callback
(lambda (v r)
(exact->inexact (+ v (T-ref r) ...))))])
(cb_send_pre_double cb)))
(= (+ vi ...) (with-callback ([cb (make-ftype-pointer
callback-r
(lambda (r)
(T-set! r) ...))])
(sum_cb cb)))
(begin
(free_at_boundary (ftype-pointer-address a))
#t)))))]))
(define-syntax check-n
(syntax-rules ()
[(_ [ni ti vi] ...)
(let ()
(define-ftype T (struct [ni ti] ...))
(define s (apply string-append
"_struct"
(let loop ([l '(ti ...)])
(cond
[(null? l) '()]
[else (cons (format "_~a" (car l))
(loop (cdr l)))]))))
(check* T s
[vi ...]
[(lambda (a) (ftype-ref T (ni) a)) ...]
[(lambda (a) (ftype-set! T (ni) a vi)) ...]))]))
(define-syntax check
(syntax-rules ()
[(_ t1 v1)
(check* t1 (format "_~a" 't1)
[v1]
[(lambda (a) (ftype-ref t1 () a))]
[(lambda (a) (ftype-set! t1 () a v1))])]))
(define-syntax check-union
(syntax-rules ()
[(_ [n0 t0 v0] [ni ti vi] ...)
(let ()
(define-ftype T (union [n0 t0] [ni ti] ...))
(define s (apply string-append
"_union"
(let loop ([l '(t0 ti ...)])
(cond
[(null? l) '()]
[else (cons (format "_~a" (car l))
(loop (cdr l)))]))))
(check* T s
[v0]
[(lambda (a) (ftype-ref T (n0) a))]
[(lambda (a) (ftype-set! T (n0) a v0))]))]))
(define-syntax check-1
(syntax-rules ()
[(_ t1 v1)
(check-n [x t1 v1])]))
(define-syntax check-2
(syntax-rules ()
[(_ t1 t2 v1 v2)
(check-n [x t1 v1] [y t2 v2])]))
(define-syntax check-2-set
(syntax-rules ()
[(_ t x)
(and
(check-2 t i8 (+ 1 x) 10)
(check-2 t short (+ 2 x) 20)
(check-2 t long (+ 3 x) 30)
(check-2 t i64 (+ 5 x) 50)
(check-2 short t 6 (+ 60 x))
(check-2 long t 7 (+ 70 x))
(check-2 i64 t 9 (+ 90 x))
(check-2 i8 t 10 (+ 100 x)))]))
(define-syntax check-3
(syntax-rules ()
[(_ t1 t2 t3 v1 v2 v3)
(check-n [x t1 v1] [y t2 v2] [z t3 v3])]))
(define-syntax check-3-set
(syntax-rules ()
[(_ t x)
(and
(check-3 t i8 int (+ 1 x) 10 100)
(check-3 t short int (+ 2 x) 20 200)
(check-3 t long int (+ 3 x) 30 300)
(check-3 t i64 int (+ 5 x) 50 500)
(check-3 short t int 6 (+ 60 x) 600)
(check-3 long t int 7 (+ 70 x) 700)
(check-3 i64 t int 9 (+ 90 x) 900)
(check-3 i8 t int 10 (+ 100 x) 1000))]))
(define malloc_at_boundary (foreign-procedure "malloc_at_boundary"
(int) uptr))
(define free_at_boundary (foreign-procedure "free_at_boundary"
(uptr) void))
#t)
(check i8 -11)
(check u8 129)
(check short -22)
(check u16 33022)
(check long 33)
(check int 44)
(check i64 49)
(check float 55.0)
(check double 66.0)
(check-1 i8 -12)
(check-1 u8 212)
(check-1 short -23)
(check-1 u16 33023)
(check-1 long 34)
(check-1 int 45)
(check-1 i64 48)
(check-1 float 56.0)
(check-1 double 67.0)
(check-2-set int 0)
(check-2-set float 0.5)
(check-2-set double 0.25)
(check-2 int int 4 40)
(check-2 float float 4.5 40.5)
(check-2 double double 4.25 40.25)
(check-3-set int 0)
(check-3-set float 0.5)
(check-3-set double 0.25)
(check-3 i8 i8 i8 4 38 127)
(check-3 short short short 4 39 399)
(check-3 int int int 4 40 400)
(check-3 float float float 4.5 40.5 400.5)
(check-3 double double double 4.25 40.25 400.25)
(check-n [x i8 1] [y i8 2] [z i8 3] [w i8 4] [q i8 5])
(check-n [x i8 1] [y i8 2] [z i8 3] [w i8 4] [q i8 5] [r i8 6] [s i8 7])
(check-union [x i8 -17])
(check-union [x u8 217])
(check-union [x short -27])
(check-union [x u16 33027])
(check-union [x long 37])
(check-union [x int 47])
(check-union [x i64 49])
(check-union [x float 57.0])
(check-union [x double 77.0])
(check-union [x i8 18] [y int 0])
(check-union [x short 28] [y int 0])
(check-union [x long 38] [y int 0])
(check-union [x int 48] [y int 0])
(check-union [x i64 43] [y int 0])
(check-union [x float 58.0] [y int 0])
(check-union [x double 68.0] [y int 0]))

288
mats/foreign4.c Normal file
View File

@ -0,0 +1,288 @@
/* foreign4.c
* Copyright 1984-2017 Cisco Systems, Inc.
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
*/
#include <stdio.h>
#include <stdlib.h>
typedef signed char i8;
typedef unsigned char u8;
typedef unsigned short u16;
#ifdef _WIN32
typedef __int64 i64;
# define EXPORT extern __declspec (dllexport)
#else
typedef long long i64;
# define EXPORT
#endif
/* To help make sure that argument and result handling doens't
read or write too far, try to provide functions that allocate
a structure at the end of a memory page (where the next page is
likely to be unmapped) */
#if defined(__linux__) || (defined(__APPLE__) && defined(__MACH__))
# include <stdlib.h>
# include <sys/mman.h>
# include <unistd.h>
# include <inttypes.h>
EXPORT void *malloc_at_boundary(int sz)
{
intptr_t alloc_size = getpagesize();
char *p;
p = mmap(NULL, alloc_size, PROT_READ | PROT_WRITE, MAP_ANON | MAP_PRIVATE, -1, 0);
return p + alloc_size - sz;
}
EXPORT void free_at_boundary(void *p)
{
intptr_t alloc_size = getpagesize();
munmap((void *)(((intptr_t)p) & ~(alloc_size-1)), alloc_size);
}
#else
EXPORT void *malloc_at_boundary(int sz)
{
return malloc(sz);
}
EXPORT void free_at_boundary(void *p)
{
free(p);
}
#endif
#define GEN(ts, init, sum) \
EXPORT ts f4_get_ ## ts () { \
ts r = init; \
return r; \
} \
EXPORT double f4_sum_ ## ts (ts v) { \
return sum(v); \
} \
EXPORT double f4_sum_two_ ## ts (ts v1, ts v2) { \
return sum(v1) + sum(v2); \
} \
EXPORT double f4_sum_pre_double_ ## ts (double v0, ts v) { \
return v0 + sum(v); \
} \
EXPORT double f4_sum_pre_double_double_ ## ts (double v0, double v1, ts v) { \
return v0 + v1 + sum(v); \
} \
EXPORT double f4_sum_pre_double_double_double_double_ ## ts (double v0, double v1, double v2, double v3, ts v) { \
return v0 + v1 + v2 + v3 + sum(v); \
} \
EXPORT double f4_sum_pre_double_double_double_double_double_double_double_double_ ## ts \
(double v0, double v1, double v2, double v3, double v4, double v5, double v6, double v7, ts v) { \
return v0 + v1 + v2 + v3 + v4 + v5 + v6 + v7 + sum(v); \
} \
EXPORT double f4_sum_ ## ts ## _post_double (ts v, double v0) { \
return v0 + sum(v); \
} \
EXPORT double f4_sum_pre_int_ ## ts (int v0, ts v) { \
return (double)v0 + sum(v); \
} \
EXPORT double f4_sum_pre_int_int_ ## ts (int v0, int v1, ts v) { \
return (double)v0 + (double)v1 + sum(v); \
} \
EXPORT double f4_sum_pre_int_int_int_int_ ## ts (int v0, int v1, int v2, int v3, ts v) { \
return (double)v0 + (double)v1 + (double)v2 + (double)v3 + sum(v); \
} \
EXPORT double f4_sum_pre_int_int_int_int_int_int_ ## ts (int v0, int v1, int v2, int v3, int v4, int v5, ts v) { \
return (double)v0 + (double)v1 + (double)v2 + (double)v3 + (double)v4 + (double)v5 + sum(v); \
} \
EXPORT double f4_sum_ ## ts ## _post_int (ts v, int v0) { \
return (double)v0 + sum(v); \
} \
EXPORT double f4_cb_send_ ## ts (double (*cb)(ts)) { \
ts r = init; \
return cb(r) + 1.0; \
} \
EXPORT double f4_cb_send_two_ ## ts (double (*cb)(ts, ts)) { \
ts r1 = init; \
ts r2 = init; \
return cb(r1, r2) + 1.0; \
} \
EXPORT double f4_cb_send_pre_int_ ## ts (double (*cb)(int, ts)) { \
ts r = init; \
return cb(8, r) + 1.0; \
} \
EXPORT double f4_cb_send_pre_int_int_ ## ts (double (*cb)(int, int, ts)) { \
ts r = init; \
return cb(8, 9, r) + 1.0; \
} \
EXPORT double f4_cb_send_pre_int_int_int_int_ ## ts (double (*cb)(int, int, int, int, ts)) { \
ts r = init; \
return cb(8, 9, 10, 11, r) + 1.0; \
} \
EXPORT double f4_cb_send_pre_int_int_int_int_int_int_ ## ts (double (*cb)(int, int, int, int, int, int, ts)) { \
ts r = init; \
return cb(8, 9, 10, 11, 12, 13, r) + 1.0; \
} \
EXPORT double f4_cb_send_pre_double_ ## ts (double (*cb)(double, ts)) { \
ts r = init; \
return cb(8.25, r) + 1.0; \
} \
EXPORT double f4_cb_send_pre_double_double_ ## ts (double (*cb)(double, double, ts)) { \
ts r = init; \
return cb(8.25, 9.25, r) + 1.0; \
} \
EXPORT double f4_cb_send_pre_double_double_double_double_ ## ts (double (*cb)(double, double, double, double, ts)) { \
ts r = init; \
return cb(8.25, 9.25, 10.25, 11.25, r) + 1.0; \
} \
EXPORT double f4_cb_send_pre_double_double_double_double_double_double_double_double_ ## ts \
(double (*cb)(double, double, double, double, double, double, double, double, ts)) { \
ts r = init; \
return cb(8.25, 9.25, 10.25, 11.25, 12.25, 13.25, 14.25, 15.25, r) + 1.0; \
} \
EXPORT double f4_sum_cb_ ## ts (ts (*cb)()) { \
ts v = cb(); \
return sum(v); \
}
#define TO_DOUBLE(x) ((double)(x))
GEN(i8, -11, TO_DOUBLE)
GEN(u8, 129, TO_DOUBLE)
GEN(short, -22, TO_DOUBLE)
GEN(u16, 33022, TO_DOUBLE)
GEN(long, 33, TO_DOUBLE)
GEN(int, 44, TO_DOUBLE)
GEN(i64, 49, TO_DOUBLE)
GEN(float, 55.0, TO_DOUBLE)
GEN(double, 66.0, TO_DOUBLE)
/* Some ABIs treat a struct containing a single field different that
just the field */
#define GEN_1(t1, v1) \
typedef struct struct_ ## t1 { t1 x; } struct_ ## t1; \
static double _f4_sum_struct_ ## t1 (struct_ ## t1 v) { \
return (double)v.x; \
} \
static struct_ ## t1 init_struct_ ## t1 = { v1 }; \
GEN(struct_ ## t1, init_struct_ ## t1, _f4_sum_struct_ ## t1)
GEN_1(i8, -12)
GEN_1(u8, 212)
GEN_1(short, -23)
GEN_1(u16, 33023)
GEN_1(long, 34)
GEN_1(int, 45)
GEN_1(i64, 48)
GEN_1(float, 56.0)
GEN_1(double, 67.0)
#define GEN_2(t1, t2, v1, v2) \
typedef struct struct_ ## t1 ## _ ## t2 { t1 x; t2 y; } struct_ ## t1 ## _ ## t2; \
static double _f4_sum_struct_ ## t1 ## _ ## t2 (struct_ ## t1 ## _ ## t2 v) { \
return (double)v.x + (double)v.y; \
} \
static struct_ ## t1 ## _ ## t2 init_struct_ ## t1 ## _ ## t2 = { v1, v2 }; \
GEN(struct_ ## t1 ## _ ## t2, init_struct_ ## t1 ## _ ## t2, _f4_sum_struct_ ## t1 ## _ ## t2)
#define GEN_2_SET(t, x) \
GEN_2(t, i8, 1+x, 10) \
GEN_2(t, short, 2+x, 20) \
GEN_2(t, long, 3+x, 30) \
GEN_2(t, i64, 5+x, 50) \
GEN_2(short, t, 6, 60+x) \
GEN_2(long, t, 7, 70+x) \
GEN_2(i64, t, 9, 90+x) \
GEN_2(i8, t, 10, 100+x)
GEN_2_SET(int, 0)
GEN_2_SET(float, 0.5)
GEN_2_SET(double, 0.25)
GEN_2(int, int, 4, 40)
GEN_2(float, float, 4.5, 40.5)
GEN_2(double, double, 4.25, 40.25)
#define GEN_3(t1, t2, t3, v1, v2, v3) \
typedef struct struct_ ## t1 ## _ ## t2 ## _ ## t3 { t1 x; t2 y; t3 z; } struct_ ## t1 ## _ ## t2 ## _ ## t3; \
static double _f4_sum_struct_ ## t1 ## _ ## t2 ## _ ## t3 (struct_ ## t1 ## _ ## t2 ## _ ## t3 v) { \
return (double)v.x + (double)v.y + (double)v.z; \
} \
static struct_ ## t1 ## _ ## t2 ## _ ## t3 init_struct_ ## t1 ## _ ## t2 ## _ ## t3 = { v1, v2, v3 }; \
GEN(struct_ ## t1 ## _ ## t2 ## _ ## t3, init_struct_ ## t1 ## _ ## t2 ## _ ## t3, _f4_sum_struct_ ## t1 ## _ ## t2 ## _ ## t3)
#define GEN_3_SET(t, x) \
GEN_3(t, i8, int, 1+x, 10, 100) \
GEN_3(t, short, int, 2+x, 20, 200) \
GEN_3(t, long, int, 3+x, 30, 300) \
GEN_3(t, i64, int, 5+x, 50, 500) \
GEN_3(short, t, int, 6, 60+x, 600) \
GEN_3(long, t, int, 7, 70+x, 700) \
GEN_3(i64, t, int, 9, 90+x, 900) \
GEN_3(i8, t, int, 10, 100+x, 1000)
GEN_3_SET(int, 0)
GEN_3_SET(float, 0.5)
GEN_3_SET(double, 0.25)
GEN_3(i8, i8, i8, 4, 38, 127)
GEN_3(short, short, short, 4, 39, 399)
GEN_3(int, int, int, 4, 40, 400)
GEN_3(float, float, float, 4.5, 40.5, 400.5)
GEN_3(double, double, double, 4.25, 40.25, 400.25)
typedef struct struct_i8_i8_i8_i8_i8 { i8 x, y, z, w, q; } struct_i8_i8_i8_i8_i8;
static double _f4_sum_struct_i8_i8_i8_i8_i8 (struct_i8_i8_i8_i8_i8 v) {
return (double)v.x + (double)v.y + (double)v.z + (double)v.w + (double)v.q;
}
static struct struct_i8_i8_i8_i8_i8 init_struct_i8_i8_i8_i8_i8 = { 1, 2, 3, 4, 5 };
GEN(struct_i8_i8_i8_i8_i8, init_struct_i8_i8_i8_i8_i8, _f4_sum_struct_i8_i8_i8_i8_i8)
typedef struct struct_i8_i8_i8_i8_i8_i8_i8 { i8 x, y, z, w, q, r, s; } struct_i8_i8_i8_i8_i8_i8_i8;
static double _f4_sum_struct_i8_i8_i8_i8_i8_i8_i8 (struct struct_i8_i8_i8_i8_i8_i8_i8 v) {
return (double)v.x + (double)v.y + (double)v.z + (double)v.w + (double)v.q + (double)v.r + (double)v.s;
}
static struct struct_i8_i8_i8_i8_i8_i8_i8 init_struct_i8_i8_i8_i8_i8_i8_i8 = { 1, 2, 3, 4, 5, 6, 7 };
GEN(struct_i8_i8_i8_i8_i8_i8_i8, init_struct_i8_i8_i8_i8_i8_i8_i8, _f4_sum_struct_i8_i8_i8_i8_i8_i8_i8)
/* Some ABIs treat a union containing a single field different that
just the field */
#define GEN_U1(t1, v1) \
typedef union union_ ## t1 { t1 x; } union_ ## t1; \
static double _f4_sum_union_ ## t1 (union_ ## t1 v) { \
return (double)v.x; \
} \
static union_ ## t1 init_union_ ## t1 = { v1 }; \
GEN(union_ ## t1, init_union_ ## t1, _f4_sum_union_ ## t1)
GEN_U1(i8, -17)
GEN_U1(u8, 217)
GEN_U1(short, -27)
GEN_U1(u16, 33027)
GEN_U1(long, 37)
GEN_U1(int, 47)
GEN_U1(i64, 49)
GEN_U1(float, 57.0)
GEN_U1(double, 77.0)
#define GEN_U2(t1, t2, v1) \
typedef union union_ ## t1 ## _ ## t2 { t1 x; t2 y; } union_ ## t1 ## _ ## t2; \
static double _f4_sum_union_ ## t1 ## _ ## t2 (union_ ## t1 ## _ ## t2 v) { \
return (double)v.x; \
} \
static union_ ## t1 ## _ ## t2 init_union_ ## t1 ## _ ## t2 = { v1 }; \
GEN(union_ ## t1 ## _ ## t2, init_union_ ## t1 ## _ ## t2, _f4_sum_union_ ## t1 ## _ ## t2)
GEN_U2(i8, int, 18)
GEN_U2(short, int, 28)
GEN_U2(long, int, 38)
GEN_U2(int, int, 48)
GEN_U2(i64, int, 43)
GEN_U2(float, int, 58.0)
GEN_U2(double, int, 68.0)

4
mats/ftype.ms
View File

@ -557,9 +557,9 @@
[(a6osx a6osx)
(system (format "cc -m64 -dynamiclib -o ~a ~a" testfile.so testfile.c))]
[(a6nt ta6nt)
(system (format "..\\c\\vs.bat amd64 && cl /DWIN32 /Fe~a /LD /MD /nologo ~a" testfile.so testfile.c))]
(system (format "set cl= && ..\\c\\vs.bat amd64 && cl /DWIN32 /Fe~a /LD /MD /nologo ~a" testfile.so testfile.c))]
[(i3nt ti3nt)
(system (format "..\\c\\vs.bat x86 && cl /DWIN32 /Fe~a /LD /MD /nologo ~a" testfile.so testfile.c))]
(system (format "set cl= && ..\\c\\vs.bat x86 && cl /DWIN32 /Fe~a /LD /MD /nologo ~a" testfile.so testfile.c))]
[(arm32le tarm32le)
(system (format "cc -fPIC -shared -o ~a ~a" testfile.so testfile.c))]
[else ; this should work for most intel-based systems that use gcc...

78
mats/mat.ss
View File

@ -260,38 +260,52 @@
; same modulo renaming of gensyms
; procedure in either input is used as predicate for other
(lambda (x y)
(let ([alist '()])
(let e? ([x x] [y y])
(cond
[(procedure? x) (x y)]
[(procedure? y) (y x)]
[(eqv? x y) #t]
[(pair? x)
(and (pair? y) (e? (car x) (car y)) (e? (cdr x) (cdr y)))]
[(or (and (gensym? x) (symbol? y))
(and (gensym? y) (symbol? x)))
(cond
[(assq x alist) => (lambda (a) (eq? y (cdr a)))]
[else (set! alist (cons `(,x . ,y) alist)) #t])]
[(string? x) (and (string? y) (string=? x y))]
[(bytevector? x) (and (bytevector? y) (bytevector=? x y))]
[(vector? x)
(and (vector? y)
(fx= (vector-length x) (vector-length y))
(let f ([i (fx- (vector-length x) 1)])
(or (fx< i 0)
(and (e? (vector-ref x i) (vector-ref y i))
(f (fx1- i))))))]
[(fxvector? x)
(and (fxvector? y)
(fx= (fxvector-length x) (fxvector-length y))
(let f ([i (fx- (fxvector-length x) 1)])
(if (fx< i 0)
k
(and (fx= (fxvector-ref x i) (fxvector-ref y i))
(f (fx1- i))))))]
[(box? x) (and (box? y) (e? (unbox x) (unbox y)))]
[else #f])))))
(let ([alist '()] [oops? #f])
(or (let e? ([x x] [y y])
(or (cond
[(procedure? x) (x y)]
[(procedure? y) (y x)]
[(eqv? x y) #t]
[(pair? x)
(and (pair? y) (e? (car x) (car y)) (e? (cdr x) (cdr y)))]
[(or (and (gensym? x) (symbol? y))
(and (gensym? y) (symbol? x)))
(cond
[(assq x alist) => (lambda (a) (eq? y (cdr a)))]
[else (set! alist (cons `(,x . ,y) alist)) #t])]
[(string? x) (and (string? y) (string=? x y))]
[(bytevector? x) (and (bytevector? y) (bytevector=? x y))]
[(vector? x)
(and (vector? y)
(fx= (vector-length x) (vector-length y))
(let f ([i (fx- (vector-length x) 1)])
(or (fx< i 0)
(and (e? (vector-ref x i) (vector-ref y i))
(f (fx1- i))))))]
[(fxvector? x)
(and (fxvector? y)
(fx= (fxvector-length x) (fxvector-length y))
(let f ([i (fx- (fxvector-length x) 1)])
(if (fx< i 0)
k
(and (fx= (fxvector-ref x i) (fxvector-ref y i))
(f (fx1- i))))))]
[(box? x) (and (box? y) (e? (unbox x) (unbox y)))]
[else #f])
(begin
(unless oops?
(set! oops? #t)
(printf "failure in equivalent-expansion?:\n")
(pretty-print x)
(printf "is not equivalent to\n")
(pretty-print y))
#f)))
(begin
(printf "original expressions:\n")
(pretty-print x)
(printf "is not equivalent to\n")
(pretty-print y)
#f)))))
(define *fuzz* 1e-14)

149
mats/record.ms
View File

@ -3132,6 +3132,129 @@
(hashtable-ref h graph1 #f)
(hashtable-ref h graph2 #f)
(not (hashtable-ref h graph3 #f))
(begin
(define record-hash
(lambda (x hash)
(let ([rtd (record-rtd x)])
(do ([field-name* (csv7:record-type-field-names rtd) (cdr field-name*)]
[i 0 (fx+ i 1)]
[h 0 (+ h (hash ((csv7:record-field-accessor rtd i) x)))])
((null? field-name*) h)))))
(define record-equal?
(lambda (x y e?)
(let ([rtd (record-rtd x)])
(and (eq? (record-rtd y) rtd)
(let f ([field-name* (csv7:record-type-field-names rtd)] [i 0])
(or (null? field-name*)
(and (let ([accessor (csv7:record-field-accessor rtd i)])
(e? (accessor x) (accessor y)))
(f (cdr field-name*) (fx+ i 1)))))))))
(define equiv?
(lambda (x y)
(parameterize ([default-record-equal-procedure record-equal?])
(equal? x y))))
(define equiv-hash
(lambda (x)
(parameterize ([default-record-hash-procedure record-hash])
(equal-hash x))))
(define-record-type frob (fields (mutable q)))
(define-record-type frub (fields (mutable x) y z))
(define frob-hash
(lambda (x hash)
(raise 'frob-hash)))
(define frob-equal?
(lambda (x y e?)
#f))
(define rthp
(lambda (rtd)
(case-lambda
[() (record-type-hash-procedure rtd)]
[(x) (record-type-hash-procedure rtd x)])))
(define rtep
(lambda (rtd)
(case-lambda
[() (record-type-equal-procedure rtd)]
[(x) (record-type-equal-procedure rtd x)])))
#t)
(not (record-type-equal-procedure (record-type-descriptor frob)))
(not (record-type-hash-procedure (record-type-descriptor frob)))
(not (record-type-equal-procedure (record-type-descriptor frub)))
(not (record-type-hash-procedure (record-type-descriptor frub)))
(equal?
(parameterize ([(rthp (record-type-descriptor frob)) record-hash])
(list
(record-hash-procedure (make-frob #\q))
(record-hash-procedure (make-frub 1 2 3))))
(list record-hash #f))
(equal?
(parameterize ([(rtep (record-type-descriptor frob)) record-equal?])
(list
(record-equal-procedure (make-frub 1 2 3) (make-frub 1 2 3))
(record-equal-procedure (make-frub 1 2 3) (make-frob #\q))
(record-equal-procedure (make-frob #\q) (make-frub 1 2 3))
(record-equal-procedure (make-frob #\q) (make-frob #\q))))
(list #f #f #f record-equal?))
(equal?
(parameterize ([default-record-hash-procedure record-hash])
(list
(record-hash-procedure (make-frob #\q))
(record-hash-procedure (make-frub 1 2 3))))
(list record-hash record-hash))
(equal?
(parameterize ([default-record-equal-procedure record-equal?])
(list
(record-equal-procedure (make-frub 1 2 3) (make-frub 1 2 3))
(record-equal-procedure (make-frub 1 2 3) (make-frob #\q))
(record-equal-procedure (make-frob #\q) (make-frub 1 2 3))
(record-equal-procedure (make-frob #\q) (make-frob #\q))))
(list record-equal? record-equal? record-equal? record-equal?))
(equal?
(parameterize ([default-record-hash-procedure record-hash]
[(rthp (record-type-descriptor frob)) frob-hash])
(list
(record-hash-procedure (make-frob #\q))
(record-hash-procedure (make-frub 1 2 3))))
(list frob-hash record-hash))
(equal?
(parameterize ([default-record-equal-procedure record-equal?]
[(rtep (record-type-descriptor frob)) frob-equal?])
(list
(record-equal-procedure (make-frub 1 2 3) (make-frub 1 2 3))
(record-equal-procedure (make-frub 1 2 3) (make-frob #\q))
(record-equal-procedure (make-frob #\q) (make-frub 1 2 3))
(record-equal-procedure (make-frob #\q) (make-frob #\q))))
(list record-equal? #f #f frob-equal?))
((lambda (x) (and (integer? x) (exact? x) (nonnegative? x)))
(parameterize ([default-record-hash-procedure record-hash])
(equal-hash (vector 1 2 (make-frub 1 2 3) 5 (make-frob #\q) 7))))
(eq?
(guard (c [(eq? c 'frob-hash) 'yup] [else (raise c)])
(parameterize ([default-record-hash-procedure record-hash]
[(rthp (record-type-descriptor frob)) frob-hash])
(equal-hash (list "hello" (make-frob #\q)))))
'yup)
((lambda (x) (and (integer? x) (exact? x) (nonnegative? x)))
(parameterize ([default-record-hash-procedure record-hash]
[(rthp (record-type-descriptor frob)) frob-hash])
(equal-hash (vector 1 2 (make-frub 1 2 3) 5 6))))
(equiv? (make-frob #\q) (make-frob #\q))
(equiv? (make-frub 1 2 3) (make-frub 1 2 3))
(not (parameterize ([(rtep (record-type-descriptor frob)) frob-equal?])
(equiv? (make-frob #\q) (make-frob #\q))))
(parameterize ([(rtep (record-type-descriptor frob)) frob-equal?])
(equiv? (make-frub 1 2 3) (make-frub 1 2 3)))
(equal?
(let ([ht (make-hashtable equiv-hash equiv?)])
(hashtable-set! ht (make-frob #\q) 'one)
(hashtable-set! ht (make-frub 1 2 3) 'two)
(hashtable-set! ht (make-frub 'a 'b 'c) 'three)
(list
(hashtable-ref ht (make-frob #\q) #f)
(hashtable-ref ht (make-frub 1 2 3) #f)
(hashtable-ref ht (make-frub 'a 'b 'c) #f)
(hashtable-ref ht (make-frub 'x 'y 'z) #f)))
'(one two three #f))
)
(mat record19
@ -7569,7 +7692,7 @@
'(#($cpoint 3 4 (rgb . red)) (rgb . red) #($point -8 -15))))))
`(begin
(set! $color->rgb (lambda (c) (#2%cons 'rgb c)))
(let ([g7 (lambda (n) n)])
(letrec ([g7 (lambda (n) n)])
(#3%$set-top-level-value! 'rcd1
(#3%$make-record-constructor-descriptor
',record-type-descriptor? #f g7 'define-record-type)))
@ -7643,7 +7766,7 @@
'(#($cpoint 3 4 (rgb . red)) (rgb . red) #($point -8 -15))))))
`(begin
(set! $color->rgb (lambda (c) (#3%cons 'rgb c)))
(let ([g7 (lambda (n) n)])
(letrec ([g7 (lambda (n) n)])
(#3%$set-top-level-value! 'rcd1
(#3%$make-record-constructor-descriptor
',record-type-descriptor? #f g7 'define-record-type)))
@ -8484,6 +8607,24 @@
(if b
(#3%$object-ref 'scheme-object 'x ,fixnum?)
72)))
; ensure we're checking to make sure field names, accessors, and
; mutators are identifiers
(error? ; invalid field spec
(define-record-type foo (fields 876)))
(error? ; invalid field spec
(define-record-type foo (fields (mutable (x)))))
(error? ; invalid field spec
(define-record-type foo (fields (immutable "spam"))))
(error? ; invalid field spec
(define-record-type foo (fields (immutable (x) foo-x))))
(error? ; invalid accessor name
(define-record-type foo (fields (immutable x (foo-x)))))
(error? ; invalid field spec
(define-record-type foo (fields (mutable (x) foo-x foo-x!))))
(error? ; invalid accessor name
(define-record-type foo (fields (mutable x (foo-x) foo-x!))))
(error? ; invalid accessor name
(define-record-type foo (fields (mutable x foo-x (foo-x!)))))
)
(mat define-record-type-extensions
@ -8711,7 +8852,7 @@
(new q x)))))))
(make-foo 3))))
`(let ([ctr 0])
(let ([g0 (lambda (new) (lambda (q) (new q (begin (set! ctr (#2%+ 1 xtr)) ctr))))])
(letrec ([g0 (lambda (new) (lambda (q) (new q (begin (set! ctr (#2%+ 1 xtr)) ctr))))])
(#3%$make-record-constructor-descriptor ',record-type-descriptor? #f g0 'define-record-type)
(#3%$record ',record-type-descriptor? 3 (begin (set! ctr (#2%+ 1 xtr)) ctr)))))
(equivalent-expansion?
@ -8730,7 +8871,7 @@
(new q x)))))))
(make-foo 3))))
`(let ([ctr 0])
(let ([g0 (lambda (new) (lambda (q) (new q (begin (set! ctr (#3%+ 1 xtr)) ctr))))])
(letrec ([g0 (lambda (new) (lambda (q) (new q (begin (set! ctr (#3%+ 1 xtr)) ctr))))])
(#3%$make-record-constructor-descriptor ',record-type-descriptor? #f g0 'define-record-type)
(#3%$record ',record-type-descriptor? 3 (begin (set! ctr (#3%+ 1 xtr)) ctr)))))
(error? ; invalid uid

25
mats/root-experr-compile-0-f-f-f
View File

@ -269,6 +269,8 @@ primvars.mo:Expected error in mat trace-output-port: "trace-output-port: #<input
4.mo:Expected error in mat named-let: "incorrect argument count in call ((letrec ((...)) x) 3 4)".
4.mo:Expected error in mat map: "map: 3 is not a procedure".
4.mo:Expected error in mat map: "map: 3 is not a procedure".
4.mo:Expected error in mat map: "map: 3 is not a procedure".
4.mo:Expected error in mat map: "map: 3 is not a procedure".
4.mo:Expected error in mat map: "map: 7 is not a procedure".
4.mo:Expected error in mat map: "map: a is not a proper list".
4.mo:Expected error in mat map: "map: (a . b) is not a proper list".
@ -291,6 +293,8 @@ primvars.mo:Expected error in mat trace-output-port: "trace-output-port: #<input
4.mo:Expected error in mat map: "map: (a a a a a a ...) is circular".
4.mo:Expected error in mat map: "map: (a a a a a a ...) is circular".
4.mo:Expected error in mat fold-left: "fold-left: 3 is not a procedure".
4.mo:Expected error in mat fold-left: "fold-left: 3 is not a procedure".
4.mo:Expected error in mat fold-left: "fold-left: 3 is not a procedure".
4.mo:Expected error in mat fold-left: "fold-left: a is not a proper list".
4.mo:Expected error in mat fold-left: "fold-left: (a . b) is not a proper list".
4.mo:Expected error in mat fold-left: "fold-left: (a a a a a a ...) is circular".
@ -319,6 +323,8 @@ primvars.mo:Expected error in mat trace-output-port: "trace-output-port: #<input
4.mo:Expected error in mat fold-left: "fold-left: input list was altered during operation".
4.mo:Expected error in mat fold-left: "fold-left: input list was altered during operation".
4.mo:Expected error in mat fold-right: "fold-right: 3 is not a procedure".
4.mo:Expected error in mat fold-right: "fold-right: 3 is not a procedure".
4.mo:Expected error in mat fold-right: "fold-right: 3 is not a procedure".
4.mo:Expected error in mat fold-right: "fold-right: a is not a proper list".
4.mo:Expected error in mat fold-right: "fold-right: (a . b) is not a proper list".
4.mo:Expected error in mat fold-right: "fold-right: (a a a a a a ...) is circular".
@ -341,6 +347,9 @@ primvars.mo:Expected error in mat trace-output-port: "trace-output-port: #<input
4.mo:Expected error in mat fold-right: "fold-right: (a a a a a a ...) is circular".
4.mo:Expected error in mat for-each: "for-each: 3 is not a procedure".
4.mo:Expected error in mat for-each: "for-each: 3 is not a procedure".
4.mo:Expected error in mat for-each: "for-each: 3 is not a procedure".
4.mo:Expected error in mat for-each: "for-each: 3 is not a procedure".
4.mo:Expected error in mat for-each: "for-each: 7 is not a procedure".
4.mo:Expected error in mat for-each: "for-each: a is not a proper list".
4.mo:Expected error in mat for-each: "for-each: (a . b) is not a proper list".
4.mo:Expected error in mat for-each: "for-each: (a a a a a a ...) is circular".
@ -374,6 +383,8 @@ primvars.mo:Expected error in mat trace-output-port: "trace-output-port: #<input
4.mo:Expected error in mat for-each: "for-each: input list was altered during operation".
4.mo:Expected error in mat for-each: "for-each: input list was altered during operation".
4.mo:Expected error in mat ormap: "ormap: 3 is not a procedure".
4.mo:Expected error in mat ormap: "ormap: 3 is not a procedure".
4.mo:Expected error in mat ormap: "ormap: 3 is not a procedure".
4.mo:Expected error in mat ormap: "ormap: a is not a proper list".
4.mo:Expected error in mat ormap: "ormap: (a . b) is not a proper list".
4.mo:Expected error in mat ormap: "ormap: (a a a a a a ...) is circular".
@ -407,6 +418,8 @@ primvars.mo:Expected error in mat trace-output-port: "trace-output-port: #<input
4.mo:Expected error in mat ormap: "ormap: input list was altered during operation".
4.mo:Expected error in mat ormap: "ormap: input list was altered during operation".
4.mo:Expected error in mat andmap: "andmap: 3 is not a procedure".
4.mo:Expected error in mat andmap: "andmap: 3 is not a procedure".
4.mo:Expected error in mat andmap: "andmap: 3 is not a procedure".
4.mo:Expected error in mat andmap: "andmap: a is not a proper list".
4.mo:Expected error in mat andmap: "andmap: (a . b) is not a proper list".
4.mo:Expected error in mat andmap: "andmap: (a a a a a a ...) is circular".
@ -440,6 +453,8 @@ primvars.mo:Expected error in mat trace-output-port: "trace-output-port: #<input
4.mo:Expected error in mat andmap: "andmap: input list was altered during operation".
4.mo:Expected error in mat andmap: "andmap: input list was altered during operation".
4.mo:Expected error in mat exists: "exists: 3 is not a procedure".
4.mo:Expected error in mat exists: "exists: 3 is not a procedure".
4.mo:Expected error in mat exists: "exists: 3 is not a procedure".
4.mo:Expected error in mat exists: "exists: a is not a proper list".
4.mo:Expected error in mat exists: "exists: (a . b) is not a proper list".
4.mo:Expected error in mat exists: "exists: (a a a a a a ...) is circular".
@ -473,6 +488,8 @@ primvars.mo:Expected error in mat trace-output-port: "trace-output-port: #<input
4.mo:Expected error in mat exists: "exists: input list was altered during operation".
4.mo:Expected error in mat exists: "exists: input list was altered during operation".
4.mo:Expected error in mat for-all: "for-all: 3 is not a procedure".
4.mo:Expected error in mat for-all: "for-all: 3 is not a procedure".
4.mo:Expected error in mat for-all: "for-all: 3 is not a procedure".
4.mo:Expected error in mat for-all: "for-all: a is not a proper list".
4.mo:Expected error in mat for-all: "for-all: (a . b) is not a proper list".
4.mo:Expected error in mat for-all: "for-all: (a a a a a a ...) is circular".
@ -7436,6 +7453,14 @@ record.mo:Expected error in mat r6rs-records-syntactic: "invalid define-record-t
record.mo:Expected error in mat r6rs-records-syntactic: "no constructor descriptor for define-record record type frob".
record.mo:Expected error in mat r6rs-records-syntactic: "define-record-type: invalid protocol oops".
record.mo:Expected error in mat r6rs-records-syntactic: "parent record type is sealed prnt".
record.mo:Expected error in mat r6rs-records-syntactic: "invalid field specifier 876".
record.mo:Expected error in mat r6rs-records-syntactic: "invalid field specifier (mutable (x))".
record.mo:Expected error in mat r6rs-records-syntactic: "invalid field specifier (immutable "spam")".
record.mo:Expected error in mat r6rs-records-syntactic: "invalid field specifier (immutable (x) foo-x)".
record.mo:Expected error in mat r6rs-records-syntactic: "invalid field specifier (immutable x (foo-x))".
record.mo:Expected error in mat r6rs-records-syntactic: "invalid field specifier (mutable (x) foo-x foo-x!)".
record.mo:Expected error in mat r6rs-records-syntactic: "invalid field specifier (mutable x (foo-x) foo-x!)".
record.mo:Expected error in mat r6rs-records-syntactic: "invalid field specifier (mutable x foo-x (foo-x!))".
record.mo:Expected error in mat define-record-type-extensions: "missing nongenerative clause and require-nongenerative-clause is #t (define-record-type foo)".
record.mo:Expected error in mat cp0-record-ref-optimizations: "make-record-type-descriptor: invalid uid 5".
hash.mo:Expected error in mat old-hash-table: "get-hash-table: ((a . b)) is not an eq hashtable".

28
mats/root-experr-compile-2-f-f-f
View File

@ -268,6 +268,10 @@ primvars.mo:Expected error in mat trace-output-port: "trace-output-port: #<input
4.mo:Expected error in mat r6rs:case: "invalid syntax (case)".
4.mo:Expected error in mat named-let: "incorrect argument count in call ((letrec ((...)) x) 3 4)".
4.mo:Expected error in mat map: "map: 3 is not a procedure".
4.mo:Expected error in mat map: "map: 3 is not a procedure".
4.mo:Expected error in mat map: "map: 3 is not a procedure".
4.mo:Expected error in mat map: "map: 3 is not a procedure".
4.mo:Expected error in mat map: "map: 7 is not a procedure".
4.mo:Expected error in mat map: "map: a is not a proper list".
4.mo:Expected error in mat map: "map: (a . b) is not a proper list".
4.mo:Expected error in mat map: "map: (a a a a a a ...) is circular".
@ -289,6 +293,8 @@ primvars.mo:Expected error in mat trace-output-port: "trace-output-port: #<input
4.mo:Expected error in mat map: "map: (a a a a a a ...) is circular".
4.mo:Expected error in mat map: "map: (a a a a a a ...) is circular".
4.mo:Expected error in mat fold-left: "fold-left: 3 is not a procedure".
4.mo:Expected error in mat fold-left: "fold-left: 3 is not a procedure".
4.mo:Expected error in mat fold-left: "fold-left: 3 is not a procedure".
4.mo:Expected error in mat fold-left: "fold-left: a is not a proper list".
4.mo:Expected error in mat fold-left: "fold-left: (a . b) is not a proper list".
4.mo:Expected error in mat fold-left: "fold-left: (a a a a a a ...) is circular".
@ -317,6 +323,8 @@ primvars.mo:Expected error in mat trace-output-port: "trace-output-port: #<input
4.mo:Expected error in mat fold-left: "fold-left: input list was altered during operation".
4.mo:Expected error in mat fold-left: "fold-left: input list was altered during operation".
4.mo:Expected error in mat fold-right: "fold-right: 3 is not a procedure".
4.mo:Expected error in mat fold-right: "fold-right: 3 is not a procedure".
4.mo:Expected error in mat fold-right: "fold-right: 3 is not a procedure".
4.mo:Expected error in mat fold-right: "fold-right: a is not a proper list".
4.mo:Expected error in mat fold-right: "fold-right: (a . b) is not a proper list".
4.mo:Expected error in mat fold-right: "fold-right: (a a a a a a ...) is circular".
@ -338,6 +346,10 @@ primvars.mo:Expected error in mat trace-output-port: "trace-output-port: #<input
4.mo:Expected error in mat fold-right: "fold-right: (a a a a a a ...) is circular".
4.mo:Expected error in mat fold-right: "fold-right: (a a a a a a ...) is circular".
4.mo:Expected error in mat for-each: "for-each: 3 is not a procedure".
4.mo:Expected error in mat for-each: "for-each: 3 is not a procedure".
4.mo:Expected error in mat for-each: "for-each: 3 is not a procedure".
4.mo:Expected error in mat for-each: "for-each: 3 is not a procedure".
4.mo:Expected error in mat for-each: "for-each: 7 is not a procedure".
4.mo:Expected error in mat for-each: "for-each: a is not a proper list".
4.mo:Expected error in mat for-each: "for-each: (a . b) is not a proper list".
4.mo:Expected error in mat for-each: "for-each: (a a a a a a ...) is circular".
@ -371,6 +383,8 @@ primvars.mo:Expected error in mat trace-output-port: "trace-output-port: #<input
4.mo:Expected error in mat for-each: "for-each: input list was altered during operation".
4.mo:Expected error in mat for-each: "for-each: input list was altered during operation".
4.mo:Expected error in mat ormap: "ormap: 3 is not a procedure".
4.mo:Expected error in mat ormap: "ormap: 3 is not a procedure".
4.mo:Expected error in mat ormap: "ormap: 3 is not a procedure".
4.mo:Expected error in mat ormap: "ormap: a is not a proper list".
4.mo:Expected error in mat ormap: "ormap: (a . b) is not a proper list".
4.mo:Expected error in mat ormap: "ormap: (a a a a a a ...) is circular".
@ -404,6 +418,8 @@ primvars.mo:Expected error in mat trace-output-port: "trace-output-port: #<input
4.mo:Expected error in mat ormap: "ormap: input list was altered during operation".
4.mo:Expected error in mat ormap: "ormap: input list was altered during operation".
4.mo:Expected error in mat andmap: "andmap: 3 is not a procedure".
4.mo:Expected error in mat andmap: "andmap: 3 is not a procedure".
4.mo:Expected error in mat andmap: "andmap: 3 is not a procedure".
4.mo:Expected error in mat andmap: "andmap: a is not a proper list".
4.mo:Expected error in mat andmap: "andmap: (a . b) is not a proper list".
4.mo:Expected error in mat andmap: "andmap: (a a a a a a ...) is circular".
@ -437,6 +453,8 @@ primvars.mo:Expected error in mat trace-output-port: "trace-output-port: #<input
4.mo:Expected error in mat andmap: "andmap: input list was altered during operation".
4.mo:Expected error in mat andmap: "andmap: input list was altered during operation".
4.mo:Expected error in mat exists: "exists: 3 is not a procedure".
4.mo:Expected error in mat exists: "exists: 3 is not a procedure".
4.mo:Expected error in mat exists: "exists: 3 is not a procedure".
4.mo:Expected error in mat exists: "exists: a is not a proper list".
4.mo:Expected error in mat exists: "exists: (a . b) is not a proper list".
4.mo:Expected error in mat exists: "exists: (a a a a a a ...) is circular".
@ -470,6 +488,8 @@ primvars.mo:Expected error in mat trace-output-port: "trace-output-port: #<input
4.mo:Expected error in mat exists: "exists: input list was altered during operation".
4.mo:Expected error in mat exists: "exists: input list was altered during operation".
4.mo:Expected error in mat for-all: "for-all: 3 is not a procedure".
4.mo:Expected error in mat for-all: "for-all: 3 is not a procedure".
4.mo:Expected error in mat for-all: "for-all: 3 is not a procedure".
4.mo:Expected error in mat for-all: "for-all: a is not a proper list".
4.mo:Expected error in mat for-all: "for-all: (a . b) is not a proper list".
4.mo:Expected error in mat for-all: "for-all: (a a a a a a ...) is circular".
@ -7433,6 +7453,14 @@ record.mo:Expected error in mat r6rs-records-syntactic: "invalid define-record-t
record.mo:Expected error in mat r6rs-records-syntactic: "no constructor descriptor for define-record record type frob".
record.mo:Expected error in mat r6rs-records-syntactic: "define-record-type: invalid protocol oops".
record.mo:Expected error in mat r6rs-records-syntactic: "parent record type is sealed prnt".
record.mo:Expected error in mat r6rs-records-syntactic: "invalid field specifier 876".
record.mo:Expected error in mat r6rs-records-syntactic: "invalid field specifier (mutable (x))".
record.mo:Expected error in mat r6rs-records-syntactic: "invalid field specifier (immutable "spam")".
record.mo:Expected error in mat r6rs-records-syntactic: "invalid field specifier (immutable (x) foo-x)".
record.mo:Expected error in mat r6rs-records-syntactic: "invalid field specifier (immutable x (foo-x))".
record.mo:Expected error in mat r6rs-records-syntactic: "invalid field specifier (mutable (x) foo-x foo-x!)".
record.mo:Expected error in mat r6rs-records-syntactic: "invalid field specifier (mutable x (foo-x) foo-x!)".
record.mo:Expected error in mat r6rs-records-syntactic: "invalid field specifier (mutable x foo-x (foo-x!))".
record.mo:Expected error in mat define-record-type-extensions: "missing nongenerative clause and require-nongenerative-clause is #t (define-record-type foo)".
record.mo:Expected error in mat cp0-record-ref-optimizations: "make-record-type-descriptor: invalid uid 5".
hash.mo:Expected error in mat old-hash-table: "get-hash-table: ((a . b)) is not an eq hashtable".

7
newrelease
View File

@ -35,6 +35,9 @@ if ({(echo -n "$1" | grep '^[0-9]\.[0-9]$' >& /dev/null)}) then
# set ZR to release number w/o "."
set ZR = $MR$mR
# set underscoreR to release number w/ "_" in place of "."
set underscoreR = $MR"_"$mR
else if ({(echo -n "$1" | grep '^[0-9]\.[0-9]\.[0-9]$' >& /dev/null)}) then
# set MR to major release number
set tmp = $R:r
@ -48,6 +51,9 @@ else if ({(echo -n "$1" | grep '^[0-9]\.[0-9]\.[0-9]$' >& /dev/null)}) then
# set ZR to release number w/o "."
set ZR = $MR$mR$bR
# set underscoreR to release number w/ "_" in place of "."
set underscoreR = $MR"_"$mR"_"$bR
else
echo "invalid release number $R"
exit 1
@ -87,6 +93,7 @@ set updatedfiles = ($updatedfiles NOTICE)
mkdir makefiles
sed -e "s/csv[0-9]\.[0-9]\(\.[0-9]\)*/csv$R/" ../makefiles/Mf-install.in > makefiles/Mf-install.in
sed -e "s/csug[0-9]\.[0-9]\(\.[0-9]\)*/csug$R/" -e "s/csug[0-9]_[0-9]\(_[0-9]\)*/csug$underscoreR/" ../makefiles/Makefile-csug.in > makefiles/Makefile-csug.in
set updatedfiles = ($updatedfiles makefiles/Mf-install.in)
/bin/rm scheme.1.in

79
release_notes/release_notes.stex
View File

@ -2,8 +2,8 @@
\thisversion{Version 9.5.1}
\thatversion{Version 8.4}
\pubmonth{October}
\pubyear{2017}
\pubmonth{January}
\pubyear{2018}
\begin{document}
@ -58,15 +58,46 @@ Online versions of both books can be found at
%-----------------------------------------------------------------------------
\section{Functionality Changes}\label{section:functionality}
\subsection{Record equality and hashing (9.5)}
\subsection{Garbage collection and threads (9.5.1)}
The new procedures \scheme{record-type-equal-procedure} and
A new \scheme{collect-rendezvous} function performs a garbage
collection in the same way as when the system determines that a
collection should occur. For many purposes,
\scheme{collect-rendezvous} is a variant of \scheme{collect} that
works when multiple threads are active. More precisely, the
\scheme{collect-rendezvous} function invokes the collect-request
handler (in an unspecified thread) after synchronizing all active
threads and temporarily deactivating all but the one used to call the
collect-request handler.
\subsection{Foreign-procedure struct arguments and results (9.5.1)}
A new \scheme{(& \var{ftype})} form allows a struct or union to be
passed between Scheme and a foreign procedure. The Scheme-side
representation of a \scheme{(& \var{ftype})} argument is the
same as a \scheme{(* \var{ftype})} argument, but where
\scheme{(& \var{ftype})} passes an address between the Scheme and C
worlds, \scheme{(& \var{ftype})} passes a copy of the data at the
address. When \scheme{(& \var{ftype})} is used as a result type,
an extra \scheme{(* \var{ftype})} argument must be provided to receive
the copied result, and the directly returned result is unspecified.
\subsection{Record equality and hashing (9.5, 9.5.1)}
Several new procedures and parameters allow a program to control what
\scheme{equal?} and \scheme{equal-hash} do when applied
to structures containing record instances.
The procedures \scheme{record-type-equal-procedure} and
\scheme{record-type-hash-procedure} can be used to customize the
handling of records by \scheme{equal?} and \scheme{hash}, and
the new procedures \scheme{record-equal-procedure} and
handling of records of specific types by \scheme{equal?} and \scheme{hash}, and
the procedures \scheme{record-equal-procedure} and
\scheme{record-hash-procedure} can be used to look up the
applicable (possibly inherited) equality and hashing procedures
for specific record instances.
The parameters \scheme{default-record-equal-procedure} and
\scheme{default-record-hash-procedure} can be used to control
the default behavior when comparing or hashing records without
type-specific equality and hashing procedures.
\subsection{Immutable vectors, fxvectors, bytevectors, strings, and boxes (9.5)}
@ -1535,6 +1566,30 @@ in fasl files does not generally make sense.
%-----------------------------------------------------------------------------
\section{Bug Fixes}\label{section:bugfixes}
\subsection{Misleading cyclic dependency error (9.5)}
The library system no longer reports a cyclic dependency error
during the second and subsequent attempts to visit or invoke a
library after the first attempt fails for some reason other than
an actual cyclic dependency.
The fix also allows a library to be visited or invoked successfully
on the second or subsequent attempt if the visit or invoke failed
for a transient reason, such as a missing or incorrect version in
an imported library.
\subsection{Incomplete handling of import specs within standalone export forms (9.5)}
A bug that limited the \scheme{(import \var{import-spec} \dots)} form within a
standalone \scheme{export} form to \scheme{(import \var{import-spec})} has been
fixed.
\subsection{Permission denied after deleting files or directories in Windows (9.5)}
In Windows, deleting a file or directory briefly leaves the file or
directory in a state where a subsequent create operation fails with
permission denied. This race condition is now mitigated.
[This bug applies to all versions up to 9.5 on Windows 7 and later.]
\subsection{Incorrect handling of offset in
\protect\scheme{date->time-utc} on Windows (9.5)}
@ -1768,6 +1823,18 @@ x86\_64 has been fixed.
%-----------------------------------------------------------------------------
\section{Performance Enhancements}\label{section:performance}
\subsection{Lambda commonization (9.5.1)}
After running the main source optimization pass (cp0), the
compiler optionally runs a \emph{commonization} pass, which
commonizes code for similar lambda expressions.
The parameter \scheme{commonization-level} controls whether the
commonization pass is run and, if so, how aggressive it is.
The parameter's value must be a nonnegative exact integer ranging
from 0 through 9. When the parameter is set to 0, the default,
commonization is not run. Otherwise, higher values result in more
commonization.
\subsection{Improved compile times (9.5.1)}
Compile times are now lower, sometimes by an order of magnitude or

6
s/7.ss
View File

@ -750,6 +750,12 @@
($oops who "invalid target generation ~s for generation ~s" gtarget g))
(collect2 g (if (eq? gtarget 'static) (constant static-generation) gtarget))])))
(set! collect-rendezvous
(let ([fire-collector (foreign-procedure "(cs)fire_collector" () void)])
(lambda ()
(fire-collector)
($collect-rendezvous))))
(set! keyboard-interrupt-handler
($make-thread-parameter
(lambda ()

18
s/Mf-base
View File

@ -24,6 +24,9 @@ o = 3
# d is the debug level at which the system should be built
d = 0
# cl (xcl) determines the commonization level
cl = (commonization-level)
# i determines whether inspector-information is generated: f for false, t for true
i = f
@ -102,7 +105,7 @@ patch = patch
# putting cpnanopass.patch early for maximum make --jobs=2 benefit
patchobj = patch.patch cpnanopass.patch cprep.patch cpcheck.patch\
cp0.patch cpvalid.patch cpletrec.patch\
cp0.patch cpvalid.patch cpcommonize.patch cpletrec.patch\
reloc.patch\
compile.patch fasl.patch syntax.patch env.patch\
read.patch interpret.patch ftype.patch strip.patch\
@ -124,7 +127,7 @@ basesrc =\
strnum.ss bytevector.ss 5_4.ss 5_6.ss 5_7.ss\
event.ss 4.ss front.ss foreign.ss 6.ss print.ss newhash.ss\
format.ss date.ss 7.ss cafe.ss trace.ss engine.ss\
interpret.ss cprep.ss cpcheck.ss cp0.ss cpvalid.ss cpletrec.ss inspect.ss\
interpret.ss cprep.ss cpcheck.ss cp0.ss cpvalid.ss cpcommonize.ss cpletrec.ss inspect.ss\
enum.ss io.ss read.ss primvars.ss syntax.ss costctr.ss expeditor.ss\
exceptions.ss pretty.ss env.ss\
fasl.ss reloc.ss pdhtml.ss strip.ss ftype.ss back.ss
@ -205,6 +208,7 @@ clean: profileclean
echo '(reset-handler abort)'\
'(optimize-level $o)'\
'(debug-level $d)'\
'(commonization-level $(cl))'\
'(when #$p (compile-profile (quote source)))'\
'(when #$(bp) (compile-profile (quote block)))'\
'(when #$(loadspd) (profile-load-data "${ProfileDumpSource}"))'\
@ -228,6 +232,7 @@ clean: profileclean
echo '(reset-handler abort)'\
'(optimize-level $o)'\
'(debug-level $d)'\
'(commonization-level $(cl))'\
'(when #$p (compile-profile (quote source)))'\
'(when #$(bp) (compile-profile (quote block)))'\
'(when #$(loadspd) (profile-load-data "${ProfileDumpSource}"))'\
@ -254,6 +259,7 @@ clean: profileclean
'(keyboard-interrupt-handler (lambda () (display "interrupted---aborting\n") (reset)))'\
'(optimize-level $o)'\
'(debug-level $d)'\
'(commonization-level $(cl))'\
'(generate-inspector-information #$i)'\
'(subset-mode (quote system))'\
'(compile-file "$*.ss" "$*.so")'\
@ -263,6 +269,7 @@ clean: profileclean
echo '(reset-handler abort)'\
'(optimize-level $o)'\
'(debug-level $d)'\
'(commonization-level $(cl))'\
'(when #$(xp) (compile-profile (quote source)))'\
'(when #$(xbp) (compile-profile (quote block)))'\
'(generate-inspector-information #$i)'\
@ -331,6 +338,7 @@ cmacros.so: cmacros.ss machine.def layout.ss
'(keyboard-interrupt-handler (lambda () (display "interrupted---aborting\n") (reset)))'\
'(optimize-level $o)'\
'(debug-level $d)'\
'(commonization-level $(cl))'\
'(generate-inspector-information #$i)'\
'(subset-mode (quote system))'\
'(compile-file "$*.ss" "$*.so")'\
@ -342,6 +350,7 @@ priminfo.so: priminfo.ss primdata.ss cmacros.so
'(keyboard-interrupt-handler (lambda () (display "interrupted---aborting\n") (reset)))'\
'(optimize-level $o)'\
'(debug-level $d)'\
'(commonization-level $(cl))'\
'(generate-inspector-information #$i)'\
'(subset-mode (quote system))'\
'(compile-file "$*.ss" "$*.so")'\
@ -354,6 +363,7 @@ mkheader.so: mkheader.ss cmacros.so primvars.so env.so
'(keyboard-interrupt-handler (lambda () (display "interrupted---aborting\n") (reset)))'\
'(optimize-level $o)'\
'(debug-level $d)'\
'(commonization-level $(cl))'\
'(generate-inspector-information #$i)'\
'(subset-mode (quote system))'\
'(compile-file "$*.ss" "$*.so")'\
@ -365,6 +375,7 @@ nanopass.so: $(shell echo ../nanopass/nanopass/*) ../nanopass/nanopass.ss
'(keyboard-interrupt-handler (lambda () (display "interrupted---aborting\n") (reset)))'\
'(optimize-level $o)'\
'(debug-level $d)'\
'(commonization-level $(cl))'\
'(generate-inspector-information #$i)'\
'(collect-trip-bytes (expt 2 24))'\
'(collect-request-handler (lambda () (collect 0 1)))'\
@ -387,6 +398,7 @@ script.all makescript:
'(for-each load (command-line-arguments))'\
'(optimize-level $o)'\
'(debug-level $d)'\
'(commonization-level $(cl))'\
'(when #$p (compile-profile (quote source)))'\
'(when #$(bp) (compile-profile (quote block)))'\
'(when #$(loadspd) (profile-load-data "${ProfileDumpSource}"))'\
@ -422,6 +434,7 @@ script-static.all:
'(for-each load (command-line-arguments))'\
'(optimize-level $o)'\
'(debug-level $d)'\
'(commonization-level $(cl))'\
'(when #$p (compile-profile (quote source)))'\
'(when #$(bp) (compile-profile (quote block)))'\
'(generate-inspector-information #$i)'\
@ -443,6 +456,7 @@ script-dynamic.all:
'(for-each load (command-line-arguments))'\
'(optimize-level $o)'\
'(debug-level $d)'\
'(commonization-level $(cl))'\
'(when #$p (compile-profile (quote source)))'\
'(when #$(bp) (compile-profile (quote block)))'\
'(generate-inspector-information #$i)'\

2
s/Mf-cross
View File

@ -20,7 +20,7 @@
what = all examples
base = ../..
doitformebaby: xboot
xdoit: xboot
include Mf-${xm}

523
s/arm32.ss
View File

@ -890,7 +890,7 @@
asm-fl-load/cvt asm-fl-store/cvt asm-flt asm-trunc
asm-lock asm-lock+/-
asm-flop-2 asm-flsqrt asm-c-simple-call
asm-save-flrv asm-restore-flrv asm-return asm-size
asm-save-flrv asm-restore-flrv asm-return asm-c-return asm-size
asm-enter asm-foreign-call asm-foreign-callable
asm-read-counter
asm-inc-cc-counter
@ -2051,7 +2051,7 @@
(rec asm-c-simple-call-internal
(lambda (code* jmp-tmp . ignore)
(asm-helper-call code* target save-ra? jmp-tmp))))))
(define-who asm-indirect-call
(lambda (code* dest lr . ignore)
(safe-assert (eq? lr %lr))
@ -2277,6 +2277,8 @@
; NB: reads from %lr...should be okay if declare-intrinsics sets up return-live* properly
(define asm-return (lambda () (emit bx (cons 'reg %lr) '())))
(define asm-c-return (lambda (info) (emit bx (cons 'reg %lr) '())))
(define-who asm-shiftop
(lambda (op)
(lambda (code* dest src0 src1)
@ -2313,10 +2315,28 @@
(module (asm-foreign-call asm-foreign-callable)
(define align (lambda (b x) (let ([k (- b 1)]) (fxlogand (fx+ x k) (fxlognot k)))))
(define (double-member? m) (and (eq? (car m) 'float)
(fx= (cadr m) 8)))
(define (float-member? m) (and (eq? (car m) 'float)
(fx= (cadr m) 4)))
(define (indirect-result-that-fits-in-registers? result-type)
(nanopass-case (Ltype Type) result-type
[(fp-ftd& ,ftd)
(let* ([members ($ftd->members ftd)]
[num-members (length members)])
(or (fx<= ($ftd-size ftd) 4)
(and (fx= num-members 1)
;; a struct containing only int64 is not returned in a register
(or (not ($ftd-compound? ftd))))
(and (fx<= num-members 4)
(or (andmap double-member? members)
(andmap float-member? members)))))]
[else #f]))
(define sgl-regs (lambda () (list %Cfparg1 %Cfparg1b %Cfparg2 %Cfparg2b %Cfparg3 %Cfparg3b %Cfparg4 %Cfparg4b
%Cfparg5 %Cfparg5b %Cfparg6 %Cfparg6b %Cfparg7 %Cfparg7b %Cfparg8 %Cfparg8b)))
(define-who asm-foreign-call
(with-output-language (L13 Effect)
(define int-regs (lambda () (list %Carg1 %Carg2 %Carg3 %Carg4)))
(define sgl-regs (lambda () (list %Cfparg1 %Cfparg1b %Cfparg2 %Cfparg2b %Cfparg3 %Cfparg3b %Cfparg4 %Cfparg4b %Cfparg5 %Cfparg5b %Cfparg6 %Cfparg6b %Cfparg7 %Cfparg7b %Cfparg8 %Cfparg8b)))
(letrec ([load-double-stack
(lambda (offset)
(lambda (x) ; requires var
@ -2327,7 +2347,7 @@
(lambda (offset)
(lambda (x) ; requires var
(%seq
(inline ,(make-info-loadfl %flreg1) ,%load-double->single ,x ,%zero ,(%constant flonum-data-disp))
(inline ,(make-info-loadfl %flreg1) ,%load-double->single ,x ,%zero ,(%constant flonum-data-disp))
(inline ,(make-info-loadfl %flreg1) ,%store-single ,%sp ,%zero (immediate ,offset)))))]
[load-int-stack
(lambda (offset)
@ -2339,14 +2359,33 @@
(%seq
(set! ,(%mref ,%sp ,offset) ,lorhs)
(set! ,(%mref ,%sp ,(fx+ offset 4)) ,hirhs))))]
[load-int-indirect-stack
(lambda (offset from-offset size)
(lambda (x) ; requires var
(case size
[(3)
(%seq
(set! ,(%mref ,%sp ,offset) (inline ,(make-info-load 'integer-16 #f) ,%load ,x ,%zero (immediate ,from-offset)))
(set! ,(%mref ,%sp ,(fx+ offset 2)) (inline ,(make-info-load 'integer-8 #f) ,%load ,x ,%zero (immediate ,(fx+ from-offset 2)))))]
[else
`(set! ,(%mref ,%sp ,offset) ,(case size
[(1) `(inline ,(make-info-load 'integer-8 #f) ,%load ,x ,%zero (immediate ,from-offset))]
[(2) `(inline ,(make-info-load 'integer-16 #f) ,%load ,x ,%zero (immediate ,from-offset))]
[(4) (%mref ,x ,from-offset)]))])))]
[load-int64-indirect-stack
(lambda (offset from-offset)
(lambda (x) ; requires var
(%seq
(set! ,(%mref ,%sp ,offset) ,(%mref ,x ,from-offset))
(set! ,(%mref ,%sp ,(fx+ offset 4)) ,(%mref ,x ,(fx+ from-offset 4))))))]
[load-double-reg
(lambda (fpreg)
(lambda (fpreg fp-disp)
(lambda (x) ; requires var
`(inline ,(make-info-loadfl fpreg) ,%load-double ,x ,%zero ,(%constant flonum-data-disp))))]
`(inline ,(make-info-loadfl fpreg) ,%load-double ,x ,%zero (immediate ,fp-disp))))]
[load-single-reg
(lambda (fpreg)
(lambda (fpreg fp-disp single?)
(lambda (x) ; requires var
`(inline ,(make-info-loadfl fpreg) ,%load-double->single ,x ,%zero ,(%constant flonum-data-disp))))]
`(inline ,(make-info-loadfl fpreg) ,(if single? %load-single %load-double->single) ,x ,%zero (immediate ,fp-disp))))]
[load-int-reg
(lambda (ireg)
(lambda (x)
@ -2357,6 +2396,28 @@
(%seq
(set! ,loreg ,lo)
(set! ,hireg ,hi))))]
[load-int-indirect-reg
(lambda (ireg from-offset size)
(lambda (x)
(case size
[(3)
(let ([tmp %lr]) ; ok to use %lr here?
(%seq
(set! ,ireg (inline ,(make-info-load 'integer-16 #f) ,%load ,x ,%zero (immediate ,from-offset)))
(set! ,tmp (inline ,(make-info-load 'integer-8 #f) ,%load ,x ,%zero (immediate ,(fx+ from-offset 2))))
(set! ,tmp ,(%inline sll ,tmp (immediate 16)))
(set! ,ireg ,(%inline + ,ireg ,tmp))))]
[else
`(set! ,ireg ,(case size
[(1) `(inline ,(make-info-load 'integer-8 #f) ,%load ,x ,%zero (immediate ,from-offset))]
[(2) `(inline ,(make-info-load 'integer-16 #f) ,%load ,x ,%zero (immediate ,from-offset))]
[(4) (%mref ,x ,from-offset)]))])))]
[load-int64-indirect-reg
(lambda (loreg hireg from-offset)
(lambda (x)
(%seq
(set! ,loreg ,(%mref ,x ,from-offset))
(set! ,hireg ,(%mref ,x ,(fx+ from-offset 4))))))]
[do-args
(lambda (types)
; sgl* is always of even-length, i.e., has a sgl/dbl reg first
@ -2372,21 +2433,97 @@
(cons (load-double-stack isp) locs)
live* int* '() #f (fx+ isp 8)))
(loop (cdr types)
(cons (load-double-reg (car sgl*)) locs)
(cons (load-double-reg (car sgl*) (constant flonum-data-disp)) locs)
live* int* (cddr sgl*) bsgl isp))]
[(fp-single-float)
(if bsgl
(loop (cdr types)
(cons (load-single-reg bsgl) locs)
(cons (load-single-reg bsgl (constant flonum-data-disp) #f) locs)
live* int* sgl* #f isp)
(if (null? sgl*)
(loop (cdr types)
(cons (load-single-stack isp) locs)
live* int* '() #f (fx+ isp 4))
(loop (cdr types)
(cons (load-single-reg (car sgl*)) locs)
(cons (load-single-reg (car sgl*) (constant flonum-data-disp) #f) locs)
live* int* (cddr sgl*) (cadr sgl*) isp)))]
[else
[(fp-ftd& ,ftd)
(let ([size ($ftd-size ftd)]
[members ($ftd->members ftd)]
[combine-loc (lambda (loc f)
(if loc
(lambda (x) (%seq ,(loc x) ,(f x)))
f))])
(case ($ftd-alignment ftd)
[(8)
(let* ([int* (if (even? (length int*)) int* (cdr int*))]
[num-members (length members)]
[doubles? (and (fx<= num-members 4)
(andmap double-member? members))])
;; Sequence of up to 4 doubles that fits in registers?
(cond
[(and doubles?
(fx>= (length sgl*) (fx* 2 num-members)))
;; Allocate each double to a register
(let dbl-loop ([size size] [offset 0] [sgl* sgl*] [loc #f])
(cond
[(fx= size 0)
(loop (cdr types) (cons loc locs) live* int* sgl* #f isp)]
[else
(dbl-loop (fx- size 8) (fx+ offset 8) (cddr sgl*)
(combine-loc loc (load-double-reg (car sgl*) offset)))]))]
[else
;; General case; for non-doubles, use integer registers while available,
;; possibly splitting between registers and stack
(let obj-loop ([size size] [offset 0] [loc #f]
[live* live*] [int* int*] [isp isp])
(cond
[(fx= size 0)
(loop (cdr types) (cons loc locs) live* int* sgl* bsgl isp)]
[else
(if (or (null? int*) doubles?)
(let ([isp (align 8 isp)])
(obj-loop (fx- size 8) (fx+ offset 8)
(combine-loc loc (load-int64-indirect-stack isp offset))
live* int* (fx+ isp 8)))
(obj-loop (fx- size 8) (fx+ offset 8)
(combine-loc loc (load-int64-indirect-reg (car int*) (cadr int*) offset))
(cons* (car int*) (cadr int*) live*) (cddr int*) isp))]))]))]
[else
(let* ([num-members (length members)]
[floats? (and (fx<= num-members 4)
(andmap float-member? members))])
;; Sequence of up to 4 floats that fits in registers?
(cond
[(and floats?
(fx>= (fx+ (length sgl*) (if bsgl 1 0)) num-members))
;; Allocate each float to register
(let flt-loop ([size size] [offset 0] [sgl* sgl*] [bsgl bsgl] [loc #f])
(cond
[(fx= size 0)
(loop (cdr types) (cons loc locs) live* int* sgl* bsgl isp)]
[else
(flt-loop (fx- size 4) (fx+ offset 4)
(if bsgl sgl* (cddr sgl*))
(if bsgl #f (cadr sgl*))
(combine-loc loc (load-single-reg (or bsgl (car sgl*)) offset #t)))]))]
[else
;; General case; use integer registers while available,
;; possibly splitting between registers and stack
(let obj-loop ([size size] [offset 0] [loc #f]
[live* live*] [int* int*] [isp isp])
(cond
[(fx<= size 0)
(loop (cdr types) (cons loc locs) live* int* sgl* bsgl isp)]
[else
(if (or (null? int*) floats?)
(obj-loop (fx- size 4) (fx+ offset 4)
(combine-loc loc (load-int-indirect-stack isp offset (fxmin size 4)))
live* int* (fx+ isp 4))
(obj-loop (fx- size 4) (fx+ offset 4)
(combine-loc loc (load-int-indirect-reg (car int*) offset (fxmin size 4)))
(cons (car int*) live*) (cdr int*) isp))]))]))]))]
[else
(if (nanopass-case (Ltype Type) (car types)
[(fp-integer ,bits) (fx= bits 64)]
[(fp-unsigned ,bits) (fx= bits 64)]
@ -2406,14 +2543,62 @@
live* '() sgl* bsgl (fx+ isp 4))
(loop (cdr types)
(cons (load-int-reg (car int*)) locs)
(cons (car int*) live*) (cdr int*) sgl* bsgl isp)))]))))])
(cons (car int*) live*) (cdr int*) sgl* bsgl isp)))]))))]
[add-fill-result
(lambda (fill-result-here? result-type args-frame-size e)
(cond
[fill-result-here?
(nanopass-case (Ltype Type) result-type
[(fp-ftd& ,ftd)
(let* ([members ($ftd->members ftd)]
[num-members (length members)]
;; result pointer is stashed on the stack after all arguments:
[dest-x %r2]
[init-dest-e `(seq ,e (set! ,dest-x ,(%mref ,%sp ,args-frame-size)))])
(cond
[(and (fx<= num-members 4)
(or (andmap double-member? members)
(andmap float-member? members)))
;; double/float results are in floating-point registers
(let ([double? (and (pair? members) (double-member? (car members)))])
(let loop ([members members] [sgl* (sgl-regs)] [offset 0] [e init-dest-e])
(cond
[(null? members) e]
[else
(loop (cdr members)
(if double? (cddr sgl*) (cdr sgl*))
(fx+ offset (if double? 8 4))
`(seq
,e
(inline ,(make-info-loadfl (car sgl*)) ,(if double? %store-double %store-single)
,dest-x ,%zero (immediate ,offset))))])))]
[else
;; result is in %Cretval and maybe %r1
`(seq
,init-dest-e
,(case ($ftd-size ftd)
[(1) `(inline ,(make-info-load 'integer-8 #f) ,%store ,dest-x ,%zero (immediate 0) ,%Cretval)]
[(2) `(inline ,(make-info-load 'integer-16 #f) ,%store ,dest-x ,%zero (immediate 0) ,%Cretval)]
[(3) (%seq
(inline ,(make-info-load 'integer-16 #f) ,%store ,dest-x ,%zero (immediate 0) ,%Cretval)
(set! ,%Cretval ,(%inline srl ,%Cretval (immediate 16)))
(inline ,(make-info-load 'integer-8 #f) ,%store ,dest-x ,%zero (immediate 2) ,%Cretval))]
[(4) `(set! ,(%mref ,dest-x ,0) ,%Cretval)]
[(8) `(seq
(set! ,(%mref ,dest-x ,0) ,%Cretval)
(set! ,(%mref ,dest-x ,4) ,%r1))]))]))])]
[else e]))])
(lambda (info)
(safe-assert (reg-callee-save? %tc)) ; no need to save-restore
(let ([arg-type* (info-foreign-arg-type* info)]
[result-type (info-foreign-result-type info)])
(with-values (do-args arg-type*)
(lambda (frame-size locs live*)
(let* ([frame-size (align 8 frame-size)]
(let* ([arg-type* (info-foreign-arg-type* info)]
[result-type (info-foreign-result-type info)]
[fill-result-here? (indirect-result-that-fits-in-registers? result-type)])
(with-values (do-args (if fill-result-here? (cdr arg-type*) arg-type*))
(lambda (args-frame-size locs live*)
(let* ([frame-size (align 8 (+ args-frame-size
(if fill-result-here?
4
0)))]
[adjust-frame (lambda (op)
(lambda ()
(if (fx= frame-size 0)
@ -2421,9 +2606,15 @@
`(set! ,%sp (inline ,null-info ,op ,%sp (immediate ,frame-size))))))])
(values
(adjust-frame %-)
(reverse locs)
(let ([locs (reverse locs)])
(cond
[fill-result-here?
;; stash extra argument on the stack to be retrieved after call and filled with the result:
(cons (load-int-stack args-frame-size) locs)]
[else locs]))
(lambda (t0)
`(inline ,(make-info-kill*-live* (reg-list %r0) live*) ,%c-call ,t0))
(add-fill-result fill-result-here? result-type args-frame-size
`(inline ,(make-info-kill*-live* (reg-list %r0) live*) ,%c-call ,t0)))
(nanopass-case (Ltype Type) result-type
[(fp-double-float)
(lambda (lvalue)
@ -2463,18 +2654,26 @@
+---------------------------+
| |
| incoming stack args |
sp+36+X+Y+Z: | |
+---------------------------+<- 8-byte boundary
| |
| saved float reg args | 0-16 words
sp+36+X+Y: | |
sp+36+R+X+Y+Z+W: | |
+---------------------------+<- 8-byte boundary
| |
| saved int reg args | 0-4 words
sp+36+X: | |
sp+36+R+X+Y+Z: | |
+---------------------------+
| |
| pad word if necessary | 0-1 words
sp+36+R+X+Y: | |
+---------------------------+<- 8-byte boundary
| |
| saved float reg args | 0-16 words
sp+36+R+X: | |
+---------------------------+<- 8-byte boundary
| |
| &-return space | up to 8 words
sp+36+R: | |
+---------------------------+<- 8-byte boundary
| |
| pad word if necessary | 0-1 words
sp+36: | |
+---------------------------+
| |
@ -2523,10 +2722,14 @@
(%seq
(set! ,lolvalue ,(%mref ,%sp ,offset))
(set! ,hilvalue ,(%mref ,%sp ,(fx+ offset 4)))))))
(define load-stack-address
(lambda (offset)
(lambda (lvalue)
`(set! ,lvalue ,(%inline + ,%sp (immediate ,offset))))))
(define count-reg-args
(lambda (types)
(lambda (types synthesize-first?)
; bsgl? is #t iff we have a "b" single (second half of double) float reg to fill
(let f ([types types] [iint 0] [idbl 0] [bsgl? #f])
(let f ([types types] [iint (if synthesize-first? -1 0)] [idbl 0] [bsgl? #f])
(if (null? types)
(values iint idbl)
(nanopass-case (Ltype Type) (car types)
@ -2540,6 +2743,34 @@
(if (fx< idbl 8)
(f (cdr types) iint (fx+ idbl 1) #t)
(f (cdr types) iint idbl #f)))]
[(fp-ftd& ,ftd)
(let* ([size ($ftd-size ftd)]
[members ($ftd->members ftd)]
[num-members (length members)])
(cond
[(and (fx<= num-members 4)
(andmap double-member? members))
;; doubles are either in registers or all on stack
(if (fx<= (fx+ idbl num-members) 8)
(f (cdr types) iint (fx+ idbl num-members) #f)
;; no more floating-point registers should be used, but ok if we count more
(f (cdr types) iint idbl #f))]
[(and (fx<= num-members 4)
(andmap float-member? members))
;; floats are either in registers or all on stack
(let ([amt (fxsrl (align 2 (fx- num-members (if bsgl? 1 0))) 1)])
(if (fx<= (fx+ idbl amt) 8)
(let ([odd-floats? (fxodd? num-members)])
(if bsgl?
(f (cdr types) iint (+ idbl amt) (not odd-floats?))
(f (cdr types) iint (+ idbl amt) odd-floats?)))
;; no more floating-point registers should be used, but ok if we count more
(f (cdr types) iint idbl #f)))]
[(fx= 8 ($ftd-alignment ftd))
(f (cdr types) (fxmin 4 (fx+ (align 2 iint) (fxsrl size 2))) idbl bsgl?)]
[else
(let ([size (align 4 size)])
(f (cdr types) (fxmin 4 (fx+ iint (fxsrl size 2))) idbl bsgl?))]))]
[else
(if (nanopass-case (Ltype Type) (car types)
[(fp-integer ,bits) (fx= bits 64)]
@ -2551,12 +2782,16 @@
(define do-stack
; all of the args are on the stack at this point, though not contiguous since
; we push all of the int reg args with one push instruction and all of the
; float reg args with another (v)push instruction
(lambda (types saved-reg-bytes pad-bytes int-reg-bytes float-reg-bytes)
(let* ([int-reg-offset (fx+ saved-reg-bytes pad-bytes)]
[float-reg-offset (fx+ int-reg-offset int-reg-bytes)]
[stack-arg-offset (fx+ float-reg-offset float-reg-bytes)])
(let loop ([types types]
; float reg args with another (v)push instruction; the saved int regs
; continue on into the stack variables, which is convenient when a struct
; argument is split across registers and the stack
(lambda (types saved-reg-bytes pre-pad-bytes return-bytes float-reg-bytes post-pad-bytes int-reg-bytes
synthesize-first?)
(let* ([return-space-offset (fx+ saved-reg-bytes pre-pad-bytes)]
[float-reg-offset (fx+ return-space-offset return-bytes)]
[int-reg-offset (fx+ float-reg-offset float-reg-bytes post-pad-bytes)]
[stack-arg-offset (fx+ int-reg-offset int-reg-bytes)])
(let loop ([types (if synthesize-first? (cdr types) types)]
[locs '()]
[iint 0]
[idbl 0]
@ -2565,7 +2800,11 @@
[float-reg-offset float-reg-offset]
[stack-arg-offset stack-arg-offset])
(if (null? types)
(reverse locs)
(let ([locs (reverse locs)])
(if synthesize-first?
(cons (load-stack-address return-space-offset)
locs)
locs))
(nanopass-case (Ltype Type) (car types)
[(fp-double-float)
(if (< idbl 8)
@ -2590,12 +2829,73 @@
(loop (cdr types)
(cons (load-single-stack stack-arg-offset) locs)
iint 8 #f int-reg-offset float-reg-offset (fx+ stack-arg-offset 4))))]
[(fp-ftd& ,ftd)
(let* ([size ($ftd-size ftd)]
[members ($ftd->members ftd)]
[num-members (length members)])
(cond
[(and (fx<= num-members 4)
(andmap double-member? members))
;; doubles are either in registers or all on stack
(if (fx<= (fx+ idbl num-members) 8)
(loop (cdr types)
(cons (load-stack-address float-reg-offset) locs)
iint (fx+ idbl num-members) #f int-reg-offset (fx+ float-reg-offset size) stack-arg-offset)
(let ([stack-arg-offset (align 8 stack-arg-offset)])
(loop (cdr types)
(cons (load-stack-address stack-arg-offset) locs)
iint 8 #f int-reg-offset #f (fx+ stack-arg-offset size))))]
[(and (fx<= num-members 4)
(andmap float-member? members))
;; floats are either in registers or all on stack
(let ([amt (fxsrl (align 2 (fx- num-members (if bsgl-offset 1 0))) 1)])
(if (fx<= (fx+ idbl amt) 8)
(let ([odd-floats? (fxodd? num-members)])
(if bsgl-offset
(let ([dbl-size (align 8 (fx- size 4))])
(loop (cdr types)
(cons (load-stack-address bsgl-offset) locs)
iint (fx+ idbl amt) (if odd-floats? #f (+ bsgl-offset size)) int-reg-offset
(fx+ float-reg-offset dbl-size) stack-arg-offset))
(let ([dbl-size (align 8 size)])
(loop (cdr types)
(cons (load-stack-address float-reg-offset) locs)
iint (fx+ idbl amt) (and odd-floats? (fx+ float-reg-offset size)) int-reg-offset
(fx+ float-reg-offset dbl-size) stack-arg-offset))))
(loop (cdr types)
(cons (load-stack-address stack-arg-offset) locs)
iint 8 #f int-reg-offset float-reg-offset (fx+ stack-arg-offset size))))]
[(fx= 8 ($ftd-alignment ftd))
(let ([int-reg-offset (if (fxeven? iint) int-reg-offset (fx+ int-reg-offset 4))]
[iint (align 2 iint)]
[amt (fxsrl size 2)])
(if (fx< iint 4) ; argument starts in registers, may continue on stack
(loop (cdr types)
(cons (load-stack-address int-reg-offset) locs)
(fxmin 4 (fx+ iint amt)) idbl bsgl-offset (fx+ int-reg-offset size) float-reg-offset
(fx+ stack-arg-offset (fxmax 0 (fx* 4 (fx- (fx+ iint amt) 4)))))
(let ([stack-arg-offset (align 8 stack-arg-offset)])
(loop (cdr types)
(cons (load-stack-address stack-arg-offset) locs)
iint idbl bsgl-offset int-reg-offset float-reg-offset (fx+ stack-arg-offset size)))))]
[else
(let* ([size (align 4 size)]
[amt (fxsrl size 2)])
(if (fx< iint 4) ; argument starts in registers, may continue on stack
(loop (cdr types)
(cons (load-stack-address int-reg-offset) locs)
(fxmin 4 (fx+ iint amt)) idbl bsgl-offset (fx+ int-reg-offset size) float-reg-offset
(fx+ stack-arg-offset (fxmax 0 (fx* 4 (fx- (fx+ iint amt) 4)))))
(loop (cdr types)
(cons (load-stack-address stack-arg-offset) locs)
iint idbl bsgl-offset int-reg-offset float-reg-offset (fx+ stack-arg-offset size))))]))]
[else
(if (nanopass-case (Ltype Type) (car types)
[(fp-integer ,bits) (fx= bits 64)]
[(fp-unsigned ,bits) (fx= bits 64)]
[else #f])
(let ([iint (align 2 iint)])
(let ([int-reg-offset (if (fxeven? iint) int-reg-offset (fx+ int-reg-offset 4))]
[iint (align 2 iint)])
(if (fx= iint 4)
(let ([stack-arg-offset (align 8 stack-arg-offset)])
(loop (cdr types)
@ -2611,44 +2911,127 @@
(loop (cdr types)
(cons (load-int-stack (car types) int-reg-offset) locs)
(fx+ iint 1) idbl bsgl-offset (fx+ int-reg-offset 4) float-reg-offset stack-arg-offset)))]))))))
(define do-result
(lambda (result-type synthesize-first? return-stack-offset)
(nanopass-case (Ltype Type) result-type
[(fp-ftd& ,ftd)
(let* ([members ($ftd->members ftd)]
[num-members (length members)])
(cond
[(and (fx<= 1 num-members 4)
(or (andmap double-member? members)
(andmap float-member? members)))
;; double/float results returned in floating-point registers
(values
(lambda ()
(let ([double? (and (pair? members) (double-member? (car members)))])
(let loop ([members members] [sgl* (sgl-regs)] [offset return-stack-offset] [e #f])
(cond
[(null? members) e]
[else
(loop (cdr members)
(if double? (cddr sgl*) (cdr sgl*))
(fx+ offset (if double? 8 4))
(let ([new-e
`(inline ,(make-info-loadfl (car sgl*)) ,(if double? %load-double %load-single)
,%sp ,%zero (immediate ,offset))])
(if e `(seq ,e ,new-e) new-e)))]))))
'()
($ftd-size ftd))]
[else
(case ($ftd-size ftd)
[(8)
(values (lambda ()
`(seq
(set! ,%Cretval ,(%mref ,%sp ,return-stack-offset))
(set! ,%r1 ,(%mref ,%sp ,(fx+ 4 return-stack-offset)))))
(list %Cretval %r1)
8)]
[else
(values (lambda ()
`(set! ,%Cretval ,(%mref ,%sp ,return-stack-offset)))
(list %Cretval %r1)
4)])]))]
[(fp-double-float)
(values (lambda (rhs)
`(inline ,(make-info-loadfl %Cfpretval) ,%load-double
,rhs ,%zero ,(%constant flonum-data-disp)))
'()
0)]
[(fp-single-float)
(values (lambda (rhs)
`(inline ,(make-info-loadfl %Cfpretval) ,%load-double->single
,rhs ,%zero ,(%constant flonum-data-disp)))
'()
0)]
[(fp-void)
(values (lambda () `(nop))
'()
0)]
[else
(cond
[(nanopass-case (Ltype Type) result-type
[(fp-integer ,bits) (fx= bits 64)]
[(fp-unsigned ,bits) (fx= bits 64)]
[else #f])
(values (lambda (lo hi)
`(seq
(set! ,%Cretval ,lo)
(set! ,%r1 ,hi)))
(list %Cretval %r1)
0)]
[else
(values (lambda (x)
`(set! ,%Cretval ,x))
(list %Cretval %r1)
0)])])))
(lambda (info)
(define callee-save-regs+lr (list %r4 %r5 %r6 %r7 %r8 %r9 %r10 %r11 %lr))
(define isaved (length callee-save-regs+lr))
(let ([arg-type* (info-foreign-arg-type* info)]
[result-type (info-foreign-result-type info)])
(let-values ([(iint idbl) (count-reg-args arg-type*)])
(let* ([arg-type* (info-foreign-arg-type* info)]
[result-type (info-foreign-result-type info)]
[synthesize-first? (indirect-result-that-fits-in-registers? result-type)])
(let-values ([(iint idbl) (count-reg-args arg-type* synthesize-first?)])
(let ([saved-reg-bytes (fx* isaved 4)]
[pad-bytes (if (fxeven? (fx+ isaved iint)) 0 4)]
[pre-pad-bytes (if (fxeven? isaved) 0 4)]
[int-reg-bytes (fx* iint 4)]
[post-pad-bytes (if (fxeven? iint) 0 4)]
[float-reg-bytes (fx* idbl 8)])
(values
(lambda ()
(%seq
; save argument register values to the stack so we don't lose the values
; across possible calls to C while setting up the tc and allocating memory
,(if (fx= idbl 0) `(nop) `(inline ,(make-info-vpush %Cfparg1 idbl) ,%vpush-multiple))
,(if (fx= iint 0) `(nop) `(inline ,(make-info-kill*-live* '() (list-head (list %Carg1 %Carg2 %Carg3 %Carg4) iint)) ,%push-multiple))
; pad if necessary to force 8-byte boundardy after saving callee-save-regs+lr
,(if (fx= pad-bytes 0) `(nop) `(set! ,%sp ,(%inline - ,%sp (immediate 4))))
; save the callee save registers & return address
(inline ,(make-info-kill*-live* '() callee-save-regs+lr) ,%push-multiple)
; set up tc for benefit of argument-conversion code, which might allocate
,(if-feature pthreads
(%seq
(set! ,%r0 ,(%inline get-tc))
(set! ,%tc ,%r0))
`(set! ,%tc (literal ,(make-info-literal #f 'entry (lookup-c-entry thread-context) 0))))))
; list of procedures that marshal arguments from their C stack locations
; to the Scheme argument locations
(do-stack arg-type* saved-reg-bytes pad-bytes int-reg-bytes float-reg-bytes)
(lambda (fv* Scall->result-type)
(in-context Tail
(%seq
; restore the callee save registers
(inline ,(make-info-kill* callee-save-regs+lr) ,%pop-multiple)
; deallocate space for pad & arg reg values
(set! ,%sp ,(%inline + ,%sp (immediate ,(fx+ pad-bytes int-reg-bytes float-reg-bytes))))
; tail call the C helper that calls the Scheme procedure
(jump (literal ,(make-info-literal #f 'entry Scall->result-type 0))
(,callee-save-regs+lr ... ,fv* ...))))))))))))))
(let-values ([(get-result result-regs return-bytes) (do-result result-type synthesize-first?
(fx+ saved-reg-bytes pre-pad-bytes))])
(let ([return-bytes (align 8 return-bytes)])
(values
(lambda ()
(%seq
; save argument register values to the stack so we don't lose the values
; across possible calls to C while setting up the tc and allocating memory
,(if (fx= iint 0) `(nop) `(inline ,(make-info-kill*-live* '() (list-head (list %Carg1 %Carg2 %Carg3 %Carg4) iint)) ,%push-multiple))
; pad if necessary to force 8-byte boundary, and make room for indirect return:
,(let ([len (+ post-pad-bytes return-bytes)])
(if (fx= len 0) `(nop) `(set! ,%sp ,(%inline - ,%sp (immediate ,len)))))
,(if (fx= idbl 0) `(nop) `(inline ,(make-info-vpush %Cfparg1 idbl) ,%vpush-multiple))
; pad if necessary to force 8-byte boundardy after saving callee-save-regs+lr
,(if (fx= pre-pad-bytes 0) `(nop) `(set! ,%sp ,(%inline - ,%sp (immediate 4))))
; save the callee save registers & return address
(inline ,(make-info-kill*-live* '() callee-save-regs+lr) ,%push-multiple)
; set up tc for benefit of argument-conversion code, which might allocate
,(if-feature pthreads
(%seq
(set! ,%r0 ,(%inline get-tc))
(set! ,%tc ,%r0))
`(set! ,%tc (literal ,(make-info-literal #f 'entry (lookup-c-entry thread-context) 0))))))
; list of procedures that marshal arguments from their C stack locations
; to the Scheme argument locations
(do-stack arg-type* saved-reg-bytes pre-pad-bytes return-bytes float-reg-bytes post-pad-bytes int-reg-bytes
synthesize-first?)
get-result
(lambda ()
(in-context Tail
(%seq
; restore the callee save registers
(inline ,(make-info-kill* callee-save-regs+lr) ,%pop-multiple)
; deallocate space for pad & arg reg values
(set! ,%sp ,(%inline + ,%sp (immediate ,(fx+ pre-pad-bytes int-reg-bytes post-pad-bytes float-reg-bytes))))
; done
(asm-c-return ,null-info ,callee-save-regs+lr ... ,result-regs ...)))))))))))))))
)

5
s/back.ss
View File

@ -119,6 +119,11 @@
(lambda (x)
(and x #t))))
(define $enable-check-prelex-flags
($make-thread-parameter #f
(lambda (x)
(and x #t))))
(define-who run-cp0
($make-thread-parameter
(default-run-cp0)

5
s/base-lang.ss
View File

@ -184,7 +184,7 @@
; language of foreign types
(define-language Ltype
(nongenerative-id #{Ltype czp82kxwe75y4e18-0})
(nongenerative-id #{Ltype czp82kxwe75y4e18-1})
(terminals
(exact-integer (bits))
($ftd (ftd)))
@ -199,7 +199,8 @@
(fp-fixnum)
(fp-double-float)
(fp-single-float)
(fp-ftd ftd)))
(fp-ftd ftd)
(fp-ftd& ftd)))
(define arity?
(lambda (x)

15
s/cmacros.ss
View File

@ -1366,6 +1366,8 @@
[ptr optimize-level]
[ptr subset-mode]
[ptr suppress-primitive-inlining]
[ptr default-record-equal-procedure]
[ptr default-record-hash-procedure]
[U64 instr-counter]
[U64 alloc-counter]
[ptr parameters]))
@ -2631,16 +2633,7 @@
scan-remembered-set
instantiate-code-object
Sreturn
Scall->ptr
Scall->fptr
Scall->bytevector
Scall->fixnum
Scall->int32
Scall->uns32
Scall->double
Scall->single
Scall->int64
Scall->uns64
Scall->void
Scall-one-result
Scall-any-results
))
)

200
s/compile.ss
View File

@ -461,8 +461,8 @@
(Inner : Inner (ir) -> Inner ()
[,lsrc lsrc] ; NB: workaround for nanopass tag snafu
[(program ,uid ,body) ($build-invoke-program uid body)]
[(library/ct ,uid ,import-code ,visit-code)
($build-install-library/ct-code uid import-code visit-code)]
[(library/ct ,uid (,export-id* ...) ,import-code ,visit-code)
($build-install-library/ct-code uid export-id* import-code visit-code)]
[(library/rt ,uid (,dl* ...) (,db* ...) (,dv* ...) (,de* ...) ,body)
($build-install-library/rt-code uid dl* db* dv* de* body)]
[else ir]))
@ -545,6 +545,11 @@
(lambda (x)
(set-box! (cdr x) (symbol-hashtable-ref ht (car x) '()))))))
(define check-prelex-flags
(lambda (x after)
(when ($enable-check-prelex-flags)
($pass-time 'cpcheck-prelex-flags (lambda () (do-trace $cpcheck-prelex-flags x 'uncprep))))))
(define compile-file-help
(lambda (op hostop wpoop machine sfd do-read outfn)
(include "types.ss")
@ -592,7 +597,9 @@
(let ([x1 ($pass-time 'expand
(lambda ()
(expand x0 (if (eq? (subset-mode) 'system) ($system-environment) (interaction-environment)) #t #t outfn)))])
(check-prelex-flags x1 'expand)
($uncprep x1 #t) ; populate preinfo sexpr fields
(check-prelex-flags x1 'uncprep)
(when wpoop
; cross-library optimization locs might be set by cp0 during the expander's compile-time
; evaluation of library forms. since we have no need for the optimization information in
@ -631,16 +638,28 @@
(let loop ([chunk* (expand-Lexpand x1)] [rx2b* '()] [rfinal* '()])
(define finish-compile
(lambda (x1 f)
(let* ([x2 ($pass-time 'cpvalid (lambda () (do-trace $cpvalid x1)))]
(let* ([waste (check-prelex-flags x1 'before-cpvalid)]
[x2 ($pass-time 'cpvalid (lambda () (do-trace $cpvalid x1)))]
[waste (check-prelex-flags x2 'cpvalid)]
[x2a (let ([cpletrec-ran? #f])
(let ([x ((run-cp0)
(lambda (x)
(set! cpletrec-ran? #t)
(let ([x ($pass-time 'cp0 (lambda () (do-trace $cp0 x)))])
($pass-time 'cpletrec (lambda () (do-trace $cpletrec x)))))
(let* ([x ($pass-time 'cp0 (lambda () (do-trace $cp0 x)))]
[waste (check-prelex-flags x 'cp0)]
[x ($pass-time 'cpletrec (lambda () (do-trace $cpletrec x)))]
[waste (check-prelex-flags x 'cpletrec)])
x))
x2)])
(if cpletrec-ran? x ($pass-time 'cpletrec (lambda () (do-trace $cpletrec x))))))]
(if cpletrec-ran?
x
(let ([x ($pass-time 'cpletrec (lambda () (do-trace $cpletrec x)))])
(check-prelex-flags x 'cpletrec)
x))))]
[x2b ($pass-time 'cpcheck (lambda () (do-trace $cpcheck x2a)))]
[waste (check-prelex-flags x2b 'cpcheck)]
[x2b ($pass-time 'cpcommonize (lambda () (do-trace $cpcommonize x2b)))]
[waste (check-prelex-flags x2b 'cpcommonize)]
[x7 (do-trace $np-compile x2b #t)]
[x8 ($c-make-closure x7)])
(loop (cdr chunk*) (cons (f x2b) rx2b*) (cons (f x8) rfinal*)))))
@ -897,7 +916,7 @@
(program-node-ir-set! maybe-program ir)
(values)])
(ctLibrary : ctLibrary (ir situation) -> * ()
[(library/ct ,uid ,import-code ,visit-code)
[(library/ct ,uid (,export-id* ...) ,import-code ,visit-code)
(when (eq? situation 'revisit) ($oops who "encountered revisit-only compile-time library ~s while processing wpo file ~s" (lookup-path uid) ifn))
(record-ct-lib-ir! uid ir)
(values)])
@ -1023,31 +1042,13 @@
(define build-install-library/ct-code
(lambda (node)
(nanopass-case (Lexpand ctLibrary) (library-node-ctir node)
[(library/ct ,uid ,import-code ,visit-code)
($build-install-library/ct-code uid
[(library/ct ,uid (,export-id* ...) ,import-code ,visit-code)
($build-install-library/ct-code uid export-id*
(if (library-node-visible? node) import-code void-pr)
(if (library-node-visible? node) visit-code void-pr))])))
(define build-void (let ([void-rec `(quote ,(void))]) (lambda () void-rec)))
(define build-cluster*
(lambda (node*)
(define (s-entry/binary node* rcluster*)
(if (null? node*)
(reverse rcluster*)
(let ([node (car node*)])
(if (library-node-binary? node)
(s-entry/binary (cdr node*) rcluster*)
(s-source (cdr node*) (list node) rcluster*)))))
(define (s-source node* rnode* rcluster*)
(if (null? node*)
(reverse (cons (reverse rnode*) rcluster*))
(let ([node (car node*)])
(if (library-node-binary? node)
(s-entry/binary (cdr node*) (cons (reverse rnode*) rcluster*))
(s-source (cdr node*) (cons node rnode*) rcluster*)))))
(s-entry/binary node* '())))
(define build-lambda
(lambda (ids body)
`(case-lambda ,(make-preinfo-lambda)
@ -1067,12 +1068,60 @@
(build-primcall '$install-library/rt-code `(quote ,(library-node-uid node)) thunk)))
(define-pass patch : Lsrc (ir env) -> Lsrc ()
(definitions
(define with-initialized-ids
(lambda (old-id* proc)
(let ([new-id* (map (lambda (old-id)
(let ([new-id (make-prelex
(prelex-name old-id)
(let ([flags (prelex-flags old-id)])
(fxlogor
(fxlogand flags (constant prelex-sticky-mask))
(fxsll (fxlogand flags (constant prelex-is-mask))
(constant prelex-was-flags-offset))))
(prelex-source old-id)
#f)])
(prelex-operand-set! old-id new-id)
new-id))
old-id*)])
(let-values ([v* (proc new-id*)])
(for-each (lambda (old-id) (prelex-operand-set! old-id #f)) old-id*)
(apply values v*)))))
(define build-ref
(case-lambda
[(x) (build-ref #f x)]
[(src x)
(let ([x (prelex-operand x)])
(safe-assert (prelex? x))
(if (prelex-referenced x)
(set-prelex-multiply-referenced! x #t)
(set-prelex-referenced! x #t))
`(ref ,src ,x))])))
(Expr : Expr (ir) -> Expr ()
[(ref ,maybe-src ,x) (build-ref maybe-src x)]
[(call ,preinfo ,pr (quote ,d))
(guard (eq? (primref-name pr) '$top-level-value) (symbol? d))
(cond
[(symbol-hashtable-ref env d #f) => (lambda (x) `(ref ,(preinfo-src preinfo) ,x))]
[else ir])]))
[(symbol-hashtable-ref env d #f) => (lambda (x) (build-ref (preinfo-src preinfo) x))]
[else ir])]
[(set! ,maybe-src ,x ,[e])
(let ([x (prelex-operand x)])
(safe-assert (prelex? x))
(set-prelex-assigned! x #t)
`(set! ,maybe-src ,x ,e))]
[(letrec ([,x* ,e*] ...) ,body)
(with-initialized-ids x*
(lambda (x*)
`(letrec ([,x* ,(map Expr e*)] ...) ,(Expr body))))]
[(letrec* ([,x* ,e*] ...) ,body)
(with-initialized-ids x*
(lambda (x*)
`(letrec* ([,x* ,(map Expr e*)] ...) ,(Expr body))))])
(CaseLambdaClause : CaseLambdaClause (ir) -> CaseLambdaClause ()
[(clause (,x* ...) ,interface ,body)
(with-initialized-ids x*
(lambda (x*)
`(clause (,x* ...) ,interface ,(Expr body))))]))
(define build-top-level-set!*
(lambda (node)
@ -1082,7 +1131,6 @@
(lambda (dl db dv body)
(if dl
`(seq ,(build-primcall '$set-top-level-value! `(quote ,dl)
;; not using build-ref here because we don't want to change the ref/multiply refed flags
`(cte-optimization-loc ,db (ref #f ,dv)))
,body)
body))
@ -1105,7 +1153,7 @@
(define build-combined-program-ir
(lambda (program node*)
(let ([patch-env (make-patch-env node*)])
(patch
(fold-right
(lambda (node combined-body)
(if (library-node-binary? node)
@ -1117,8 +1165,8 @@
,combined-body)
(nanopass-case (Lexpand rtLibrary) (library-node-rtir node)
[(library/rt ,uid (,dl* ...) (,db* ...) (,dv* ...) (,de* ...) ,body)
`(letrec* ([,dv* ,(map (lambda (de) (patch de patch-env)) de*)] ...)
(seq ,(patch body patch-env)
`(letrec* ([,dv* ,de*] ...)
(seq ,body
(seq
,(build-install-library/rt-code node
(if (library-node-visible? node)
@ -1126,8 +1174,9 @@
void-pr))
,combined-body)))])))
(nanopass-case (Lexpand Program) (program-node-ir program)
[(program ,uid ,body) (patch body patch-env)])
node*))))
[(program ,uid ,body) body])
node*)
(make-patch-env node*))))
(define build-combined-library-ir
(lambda (node*)
@ -1135,34 +1184,41 @@
(define build-let
(lambda (ids exprs body)
`(call ,(make-preinfo) ,(build-lambda ids body) ,exprs ...)))
(define build-ref
(lambda (x)
(when (prelex-referenced x)
(set-prelex-multiply-referenced! x #t))
(set-prelex-referenced! x #t)
`(ref #f ,x)))
(define build-set!
(lambda (x e)
(set-prelex-assigned! x #t)
`(set! #f ,x ,e)))
(define build-mark-invoked!
(lambda (node)
(build-primcall '$mark-invoked! `(quote ,(library-node-uid node)))))
(let ([patch-env (make-patch-env node*)])
(define build-cluster
(lambda (node* cluster-body)
(fold-right
(lambda (node cluster-body)
(nanopass-case (Lexpand rtLibrary) (library-node-rtir node)
[(library/rt ,uid (,dl* ...) (,db* ...) (,dv* ...) (,de* ...) ,body)
`(letrec* ([,dv* ,(map (lambda (de) (patch de patch-env)) de*)] ...)
(seq ,(patch body patch-env)
(seq
,(if (library-node-visible? node)
`(seq ,(build-top-level-set!* node) ,(build-mark-invoked! node))
(build-mark-invoked! node))
,cluster-body)))]))
cluster-body node*)))
(define build-cluster*
(lambda (node*)
(define (s-entry/binary node* rcluster*)
(if (null? node*)
(reverse rcluster*)
(let ([node (car node*)])
(if (library-node-binary? node)
(s-entry/binary (cdr node*) rcluster*)
(s-source (cdr node*) (list node) rcluster*)))))
(define (s-source node* rnode* rcluster*)
(if (null? node*)
(reverse (cons (reverse rnode*) rcluster*))
(let ([node (car node*)])
(if (library-node-binary? node)
(s-entry/binary (cdr node*) (cons (reverse rnode*) rcluster*))
(s-source (cdr node*) (cons node rnode*) rcluster*)))))
(s-entry/binary node* '())))
(define build-cluster
(lambda (node* cluster-body)
(fold-right
(lambda (node cluster-body)
(nanopass-case (Lexpand rtLibrary) (library-node-rtir node)
[(library/rt ,uid (,dl* ...) (,db* ...) (,dv* ...) (,de* ...) ,body)
`(letrec* ([,dv* ,de*] ...)
(seq ,body
(seq
,(if (library-node-visible? node)
`(seq ,(build-top-level-set!* node) ,(build-mark-invoked! node))
(build-mark-invoked! node))
,cluster-body)))]))
cluster-body node*)))
(patch
; example: D imports C; C imports A, B; B imports A; A imports nothing
; have wpos for D, A, B; obj for C
; (let ([lib-f (void)])
@ -1190,31 +1246,32 @@
(let ([cluster-idx* (enumerate cluster*)])
(build-let (list lib-f) (list (build-void))
`(seq
,(build-set! lib-f
(let f ([cluster* cluster*] [cluster-idx* cluster-idx*])
(set! #f ,lib-f
,(let f ([cluster* cluster*] [cluster-idx* cluster-idx*])
(let ([idx (gen-var 'idx)])
(build-lambda (list idx)
(build-cluster (car cluster*)
(let ([cluster* (cdr cluster*)])
(if (null? cluster*)
(let ([idx (gen-var 'idx)])
(build-set! lib-f (build-lambda (list idx) (build-void))))
`(set! #f ,lib-f ,(build-lambda (list idx) (build-void))))
(let ([t (gen-var 't)])
(build-let (list t) (list (f cluster* (cdr cluster-idx*)))
`(if ,(build-primcall 'eqv? (build-ref idx) `(quote ,(car cluster-idx*)))
,(build-set! lib-f (build-ref t))
,(build-call (build-ref t) (build-ref idx))))))))))))
`(if ,(build-primcall 'eqv? `(ref #f ,idx) `(quote ,(car cluster-idx*)))
(set! #f ,lib-f (ref #f ,t))
,(build-call `(ref #f ,t) `(ref #f ,idx))))))))))))
,(fold-right (lambda (cluster cluster-idx body)
(fold-right (lambda (node body)
`(seq
,(build-install-library/rt-code node
(if (library-node-visible? node)
(build-lambda '()
(build-call (build-ref lib-f) `(quote ,cluster-idx)))
(build-call `(ref #f ,lib-f) `(quote ,cluster-idx)))
void-pr))
,body))
body cluster))
(build-void) cluster* cluster-idx*)))))))))
(build-void) cluster* cluster-idx*)))))
(make-patch-env node*)))))
(with-output-language (Lexpand Outer)
(define add-library-records
@ -1392,8 +1449,8 @@
(Inner : Inner (ir) -> Expr ()
[,lsrc lsrc]
[(program ,uid ,body) ($build-invoke-program uid body)]
[(library/ct ,uid ,import-code ,visit-code)
($build-install-library/ct-code uid import-code visit-code)]
[(library/ct ,uid (,export-id* ...) ,import-code ,visit-code)
($build-install-library/ct-code uid export-id* import-code visit-code)]
[(library/rt ,uid (,dl* ...) (,db* ...) (,dv* ...) (,de* ...) ,body)
($build-install-library/rt-code uid dl* db* dv* de* body)]
[else (sorry! who "unexpected Lexpand record ~s" ir)])
@ -1416,7 +1473,8 @@
($pass-time 'cpletrec (lambda () ($cpletrec x)))))
x2)])
(if cpletrec-ran? x ($pass-time 'cpletrec (lambda () ($cpletrec x))))))]
[x2b ($pass-time 'cpcheck (lambda () ($cpcheck x2a)))])
[x2b ($pass-time 'cpcheck (lambda () ($cpcheck x2a)))]
[x2b ($pass-time 'cpcommonize (lambda () ($cpcommonize x2b)))])
(when (and (expand/optimize-output) (not ($noexpand? x0)))
(pretty-print ($uncprep x2b) (expand/optimize-output)))
(if (and (compile-interpret-simple)

29
s/cp0.ss
View File

@ -933,7 +933,7 @@
[(seq ,e1 ,e2) (pure-call? e1 e2)]
[else (pure-call? #f e)]))]
[(quote ,d) #t]
[,pr #t]
[,pr (all-set? (prim-mask proc) (primref-flags pr))]
[(case-lambda ,preinfo ,cl* ...) #t]
[(if ,e1 ,e2 ,e3) (memoize (and (pure? e1) (pure? e2) (pure? e3)))]
[(seq ,e1 ,e2) (memoize (and (pure? e1) (pure? e2)))]
@ -991,7 +991,7 @@
[(seq ,e1 ,e2) (ivory-call? e1 e2)]
[else (ivory-call? #f e)]))]
[(quote ,d) #t]
[,pr #t]
[,pr (all-set? (prim-mask proc) (primref-flags pr))]
[(case-lambda ,preinfo ,cl* ...) #t]
[(if ,e1 ,e2 ,e3) (memoize (and (ivory? e1) (ivory? e2) (ivory? e3)))]
[(seq ,e1 ,e2) (memoize (and (ivory? e1) (ivory? e2)))]
@ -3619,14 +3619,18 @@
(cons `(call ,preinfo (ref #f ,p)
,(map (lambda (t*) (build-ref (car t*))) t**) ...)
(g (map cdr t**))))))])
(if (and map? (not (eq? ctxt 'effect)))
(build-primcall lvl 'list results)
(make-seq* ctxt results)))
(if (and map? (not (eq? (app-ctxt ctxt) 'effect)))
(if (null? results)
null-rec
(build-primcall lvl 'list results))
(if (null? results)
void-rec
(make-seq* (app-ctxt ctxt) results))))
(non-result-exp (value-visit-operand! (car ls*))
(build-let (car t**) (car e**)
(f (cdr t**) (cdr e**) (cdr ls*))))))])
(if (fx= lvl 2)
(make-seq ctxt
(make-seq (app-ctxt ctxt)
`(if ,(build-primcall 2 'procedure? (list `(ref #f ,p)))
,void-rec
,(build-primcall 3 '$oops (list `(quote ,(if map? 'map 'for-each))
@ -3642,11 +3646,7 @@
[else #f])))))
(define-inline 2 map
[(?p ?ls . ?ls*)
(if (andmap null-rec? (cons ?ls ?ls*))
(begin
(residualize-seq '() (list* ?p ?ls ?ls*) ctxt)
null-rec)
(inline-lists ?p ?ls ?ls* 2 #t ctxt sc wd name moi))])
(inline-lists ?p ?ls ?ls* 2 #t ctxt sc wd name moi)])
(define-inline 3 map
[(?p ?ls . ?ls*)
(cond
@ -3725,12 +3725,7 @@
(define-inline 2 for-each
[(?p ?ls . ?ls*)
(cond
[(andmap null-rec? (cons ?ls ?ls*))
(residualize-seq '() (list* ?p ?ls ?ls*) ctxt)
void-rec]
[else
(inline-lists ?p ?ls ?ls* 2 #f ctxt sc wd name moi)])])
(inline-lists ?p ?ls ?ls* 2 #f ctxt sc wd name moi)])
(define-inline 3 for-each
[(?p ?ls . ?ls*)
(cond

578
s/cpcommonize.ss Normal file
View File

@ -0,0 +1,578 @@
"cpcommonize.ss"
;;; cpcommonize.ss
;;; Copyright 1984-2017 Cisco Systems, Inc.
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;; http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.
(define-who commonization-level
($make-thread-parameter
0
(lambda (x)
(unless (and (fixnum? x) (<= 0 x 9))
($oops who "invalid level ~s" x))
x)))
(define $cpcommonize
(let ()
(import (nanopass))
(include "base-lang.ss")
(define-record-type binding
(nongenerative)
(sealed #t)
(fields x (mutable e) size helper-box (mutable helper-b) (mutable helper-arg*))
(protocol
(lambda (new)
(lambda (x e size helper-box)
(new x e size helper-box #f #f)))))
(define-language Lcommonize1 (extends Lsrc)
(terminals
(+ (fixnum (size))))
(Expr (e body rtd-expr)
(- (letrec ([x* e*] ...) body))
(+ (letrec ([x* e* size] ...) body))))
(define-language Lcommonize2 (extends Lcommonize1)
(terminals
(- (fixnum (size)))
(+ (binding (b helper-b))))
(Expr (e body rtd-expr)
(- (letrec ([x* e* size] ...) body))
(+ (letrec (helper-b* ...) (b* ...) body))))
(define-syntax iffalse
(syntax-rules ()
[(_ e1 e2) e1 #;(or e1 (begin e2 #f))]))
(define-syntax iftrue
(syntax-rules ()
[(_ e1 e2) e1 #;(let ([t e1]) (and t (begin e2 t)))]))
(define Lcommonize1-lambda?
(lambda (e)
(nanopass-case (Lcommonize1 Expr) e
[(case-lambda ,preinfo ,cl* ...) #t]
[else #f])))
(define-pass cpcommonize0 : Lsrc (ir) -> Lcommonize1 ()
(Expr : Expr (ir) -> Expr (1)
[(set! ,maybe-src ,x ,[e size])
(values `(set! ,maybe-src ,x ,e) (fx+ 1 size))]
[(seq ,[e1 size1] ,[e2 size2])
(values `(seq ,e1 ,e2) (fx+ size1 size2))]
[(if ,[e1 size1] ,[e2 size2] ,[e3 size3])
(values `(if ,e1 ,e2 ,e3) (fx+ size1 size2 size3))]
[(foreign ,conv ,name ,[e size] (,arg-type* ...) ,result-type)
(values `(foreign ,conv ,name ,e (,arg-type* ...) ,result-type) (fx+ 1 size))]
[(fcallable ,conv ,[e size] (,arg-type* ...) ,result-type)
(values `(fcallable ,conv ,e (,arg-type* ...) ,result-type) (fx+ 1 size))]
; ($top-level-value 'x) adds just 1 to the size
[(call ,preinfo ,pr (quote ,d))
(guard (eq? (primref-name pr) '$top-level-value))
(values `(call ,preinfo ,pr (quote ,d)) 1)]
; (let ([x* e*] ...) body) splits into letrec binding unassigned variables to lambdas plus a let for the remaining bindings
[(call ,preinfo1 (case-lambda ,preinfo2 (clause (,x* ...) ,interface ,[body size])) ,[e* -> e* size*] ...)
(guard (fx= (length e*) interface))
(define-record-type fudge (nongenerative) (sealed #t) (fields x e size))
(let-values ([(lb* ob*) (partition
(lambda (b)
(and (not (prelex-assigned (fudge-x b)))
(Lcommonize1-lambda? (fudge-e b))))
(map make-fudge x* e* size*))])
(values
(let ([body (if (null? ob*)
body
`(call ,preinfo1
(case-lambda ,preinfo2
(clause (,(map fudge-x ob*) ...) ,(length ob*) ,body))
,(map fudge-e ob*) ...))])
(if (null? lb*)
body
`(letrec ([,(map fudge-x lb*) ,(map fudge-e lb*) ,(map fudge-size lb*)] ...) ,body)))
(apply fx+ size size*)))]
[(call ,preinfo ,[e size] ,[e* size*] ...)
(values `(call ,preinfo ,e ,e* ...) (apply fx+ size size*))]
[(case-lambda ,preinfo (clause (,x** ...) ,interface* ,[body* size*]) ...)
(values `(case-lambda ,preinfo (clause (,x** ...) ,interface* ,body*) ...) (apply fx+ 1 size*))]
[(letrec ([,x* ,[e* size*]] ...) ,[body size])
(values `(letrec ([,x* ,e* ,size*] ...) ,body) (apply fx+ size size*))]
[(record-ref ,rtd ,type ,index ,[e size])
(values `(record-ref ,rtd ,type ,index ,e) (fx+ size 1))]
[(record-set! ,rtd ,type ,index ,[e1 size1] ,[e2 size2])
(values `(record-set! ,rtd ,type ,index ,e1 ,e2) (fx+ size1 size2 1))]
[(record ,rtd ,[rtd-expr size] ,[e* size*] ...)
(values `(record ,rtd ,rtd-expr ,e* ...) (apply fx+ size size*))]
[(cte-optimization-loc ,box ,[e size])
(values `(cte-optimization-loc ,box ,e) size)]
[(immutable-list (,[e* size*] ...) ,[e size])
(values `(immutable-list (,e* ...) ,e) (apply fx+ size size*))]
[(quote ,d) (values `(quote ,d) 1)]
[(ref ,maybe-src ,x) (values `(ref ,maybe-src ,x) 1)]
[,pr (values pr 1)]
[(moi) (values `(moi) 1)]
[(pariah) (values `(pariah) 0)]
[(profile ,src) (values `(profile ,src) 0)]
[else (sorry! who "unhandled record ~s" ir)])
(let-values ([(e size) (Expr ir)]) e))
(define-pass cpcommonize1 : Lcommonize1 (ir worthwhile-size) -> Lcommonize2 ()
(definitions
(define worthwhile-size?
(lambda (expr-size)
(fx>= expr-size worthwhile-size)))
(define worthwhile-ratio?
(lambda (expr-size subst-count)
(or (fx= subst-count 0)
(fx>= (div expr-size subst-count) 4))))
(define-record-type subst
(nongenerative)
(sealed #t)
(fields t e1 e2))
(define-record-type frob
(nongenerative)
(sealed #t)
(fields subst* e b))
(define ht (make-hashtable values fx=))
(define make-sym
(lambda x*
(string->symbol (apply string-append (map (lambda (x) (if (prelex? x) (symbol->string (prelex-name x)) x)) x*)))))
(define same-preinfo?
(lambda (p1 p2)
; ignore differences in src and sexpr
#t))
(define same-preinfo-lambda?
(lambda (p1 p2)
; ignore differences src, sexpr, and name
(eq? (preinfo-lambda-libspec p1) (preinfo-lambda-libspec p2))))
(define-who same-type?
(lambda (ty1 ty2)
(nanopass-case (Ltype Type) ty1
[(fp-integer ,bits1)
(nanopass-case (Ltype Type) ty2
[(fp-integer ,bits2) (= bits1 bits2)]
[else #f])]
[(fp-unsigned ,bits1)
(nanopass-case (Ltype Type) ty2
[(fp-unsigned ,bits2) (= bits1 bits2)]
[else #f])]
[(fp-void)
(nanopass-case (Ltype Type) ty2
[(fp-void) #t]
[else #f])]
[(fp-scheme-object)
(nanopass-case (Ltype Type) ty2
[(fp-scheme-object) #t]
[else #f])]
[(fp-u8*)
(nanopass-case (Ltype Type) ty2
[(fp-u8*) #t]
[else #f])]
[(fp-u16*)
(nanopass-case (Ltype Type) ty2
[(fp-u16*) #t]
[else #f])]
[(fp-u32*)
(nanopass-case (Ltype Type) ty2
[(fp-u32*) #t]
[else #f])]
[(fp-fixnum)
(nanopass-case (Ltype Type) ty2
[(fp-fixnum) #t]
[else #f])]
[(fp-double-float)
(nanopass-case (Ltype Type) ty2
[(fp-double-float) #t]
[else #f])]
[(fp-single-float)
(nanopass-case (Ltype Type) ty2
[(fp-single-float) #t]
[else #f])]
[(fp-ftd ,ftd1)
(nanopass-case (Ltype Type) ty2
[(fp-ftd ,ftd2) (eq? ftd1 ftd2)]
[else #f])]
[else (sorry! who "unhandled foreign type ~s" ty1)])))
(define okay-to-subst?
(lambda (e)
(define free?
(lambda (x)
(and (not (prelex-operand x)) #t)))
(nanopass-case (Lcommonize1 Expr) e
[(ref ,maybe-src1 ,x1) (and (not (prelex-assigned x1)) (free? x1))]
[(quote ,d) #t]
[,pr (all-set? (prim-mask proc) (primref-flags pr))]
[else #f])))
(define constant-equal?
(lambda (x y)
(define record-equal?
(lambda (x y e?)
(let ([rtd ($record-type-descriptor x)])
(and (eq? ($record-type-descriptor y) rtd)
(let f ([field-name* (csv7:record-type-field-names rtd)] [i 0])
(or (null? field-name*)
(and (let ([accessor (csv7:record-field-accessor rtd i)])
(e? (accessor x) (accessor y)))
(f (cdr field-name*) (fx+ i 1)))))))))
(parameterize ([default-record-equal-procedure record-equal?])
; equal? should be okay since even mutable constants aren't supposed to be mutated
(equal? x y))))
(define same?
(lambda (e1 e2)
(nanopass-case (Lcommonize1 Expr) e1
[(ref ,maybe-src1 ,x1)
(nanopass-case (Lcommonize1 Expr) e2
[(ref ,maybe-src2 ,x2)
(or (eq? x1 x2)
(eq? (prelex-operand x1) x2))]
[else #f])]
[(quote ,d1)
(nanopass-case (Lcommonize1 Expr) e2
[(quote ,d2) (constant-equal? d1 d2)]
[else #f])]
[,pr1
(nanopass-case (Lcommonize1 Expr) e2
[,pr2 (eq? pr1 pr2)]
[else #f])]
[(moi)
(nanopass-case (Lcommonize1 Expr) e2
[(moi) #t]
[else #f])]
[(pariah)
(nanopass-case (Lcommonize1 Expr) e2
[(pariah) #t]
[else #f])]
[(profile ,src1)
(nanopass-case (Lcommonize1 Expr) e2
[(profile ,src2) (eq? src1 src2)]
[else #f])]
[(call ,preinfo1 ,pr1 (quote ,d1))
(guard (eq? (primref-name pr1) '$top-level-value))
(nanopass-case (Lcommonize1 Expr) e2
[(call ,preinfo2 ,pr2 (quote ,d2))
(guard (eq? (primref-name pr2) '$top-level-value))
(and (same-preinfo? preinfo1 preinfo2) (eq? d1 d2))]
[else #f])]
[else #f])))
(define-who unify
(lambda (e1 e2)
(module (with-env)
(define $with-env
(lambda (x1* x2* th)
(dynamic-wind
(lambda () (map (lambda (x1 x2) (prelex-operand-set! x1 x2) (prelex-operand-set! x2 #t)) x1* x2*))
th
(lambda () (map (lambda (x1 x2) (prelex-operand-set! x1 #f) (prelex-operand-set! x2 #f)) x1* x2*)))))
(define-syntax with-env
(syntax-rules ()
[(_ x1* x2* e) ($with-env x1* x2* (lambda () e))])))
(call/cc
(lambda (return)
(let ([subst* '()])
(define lookup-subst
(lambda (e1 e2)
(define same-subst?
(lambda (x)
(and (same? (subst-e1 x) e1) (same? (subst-e2 x) e2))))
(cond
[(find same-subst? subst*) =>
(lambda (subst)
(let ([t (subst-t subst)])
(set-prelex-multiply-referenced! t #t)
t))]
[else #f])))
(let ([e (with-output-language (Lcommonize1 Expr)
(let ()
(define fclause
(lambda (cl1 cl2)
(nanopass-case (Lcommonize1 CaseLambdaClause) cl1
[(clause (,x1* ...) ,interface1 ,body1)
(nanopass-case (Lcommonize1 CaseLambdaClause) cl2
[(clause (,x2* ...) ,interface2 ,body2)
(if (fx= interface1 interface2)
(with-env x1* x2*
(with-output-language (Lcommonize1 CaseLambdaClause)
`(clause (,x1* ...) ,interface1 ,(f body1 body2))))
(return (iffalse #f (printf "lambda interfaces don't match\n")) '()))])])))
(define f
(case-lambda
[(e1 e2) (f e1 e2 #f)]
[(e1 e2 call-position?)
(or (cond
[(same? e1 e2) e1]
[(and (not call-position?) (okay-to-subst? e1) (okay-to-subst? e2))
`(ref #f ,(or (lookup-subst e1 e2)
(let ([t (make-prelex*)])
(set-prelex-referenced! t #t)
(set! subst* (cons (make-subst t e1 e2) subst*))
t)))]
[else
(nanopass-case (Lcommonize1 Expr) e1
[(ref ,maybe-src1 ,x1) #f]
[(quote ,d) #f]
[,pr #f]
[(moi) #f]
[(profile ,src1) #f]
; reject non-same top-level-value calls with constant symbol so they
; don't end up being abstracted over the symbol in the residual code
[(call ,preinfo ,pr (quote ,d))
(guard (eq? (primref-name pr) '$top-level-value))
#f]
; don't allow abstraction of first (type) argument to $object-ref, foreign-ref, etc.,
; since they can't be inlined without a constant type.
; ditto for $tc-field's first (field) argument.
; there are many other primitives we don't catch here for which the compiler generates
; more efficient code when certain arguments are constant.
[(call ,preinfo1 ,pr1 (quote ,d1) ,e1* ...)
(guard (memq (primref-name pr1) '($object-ref $swap-object-ref $object-set foreign-ref foreign-set! $tc-field)))
(nanopass-case (Lcommonize1 Expr) e2
[(call ,preinfo2 ,pr2 (quote ,d2) ,e2* ...)
(guard (eq? pr2 pr1) (eq? d1 d2))
(and (same-preinfo? preinfo1 preinfo2)
(fx= (length e1*) (length e2*))
`(call ,preinfo1 ,pr1 (quote ,d1) ,(map f e1* e2*) ...))]
[else #f])]
[(call ,preinfo1 ,e1 ,e1* ...)
(nanopass-case (Lcommonize1 Expr) e2
[(call ,preinfo2 ,e2 ,e2* ...)
(and (fx= (length e1*) (length e2*))
(same-preinfo? preinfo1 preinfo2)
`(call ,preinfo1 ,(f e1 e2 #t) ,(map f e1* e2*) ...))]
[else #f])]
[(if ,e10 ,e11 ,e12)
(nanopass-case (Lcommonize1 Expr) e2
[(if ,e20 ,e21 ,e22)
`(if ,(f e10 e20) ,(f e11 e21) ,(f e12 e22))]
[else #f])]
[(case-lambda ,preinfo1 ,cl1* ...)
(nanopass-case (Lcommonize1 Expr) e2
[(case-lambda ,preinfo2 ,cl2* ...)
(and (fx= (length cl1*) (length cl2*))
(same-preinfo-lambda? preinfo1 preinfo2)
`(case-lambda ,preinfo1 ,(map fclause cl1* cl2*) ...))]
[else #f])]
[(seq ,e11 ,e12)
(nanopass-case (Lcommonize1 Expr) e2
[(seq ,e21 ,e22) `(seq ,(f e11 e21) ,(f e12 e22))]
[else #f])]
[(set! ,maybe-src1 ,x1 ,e1)
(nanopass-case (Lcommonize1 Expr) e2
[(set! ,maybe-src2 ,x2 ,e2)
(and (eq? x1 x2)
`(set! ,maybe-src1 ,x1 ,(f e1 e2)))]
[else #f])]
[(letrec ([,x1* ,e1* ,size1*] ...) ,body1)
(nanopass-case (Lcommonize1 Expr) e2
[(letrec ([,x2* ,e2* ,size2*] ...) ,body2)
(and (fx= (length x2*) (length x1*))
(andmap fx= size1* size2*)
(with-env x1* x2*
`(letrec ([,x1* ,(map f e1* e2*) ,size1*] ...) ,(f body1 body2))))]
[else #f])]
[(foreign ,conv1 ,name1 ,e1 (,arg-type1* ...) ,result-type1)
(nanopass-case (Lcommonize1 Expr) e2
[(foreign ,conv2 ,name2 ,e2 (,arg-type2* ...) ,result-type2)
(and (eq? conv1 conv2)
(equal? name1 name2)
(fx= (length arg-type1*) (length arg-type2*))
(andmap same-type? arg-type1* arg-type2*)
(same-type? result-type1 result-type2)
`(foreign ,conv1 ,name1 ,(f e1 e2) (,arg-type1* ...) ,result-type1))]
[else #f])]
[(fcallable ,conv1 ,e1 (,arg-type1* ...) ,result-type1)
(nanopass-case (Lcommonize1 Expr) e2
[(fcallable ,conv2 ,e2 (,arg-type2* ...) ,result-type2)
(and (eq? conv1 conv2)
(fx= (length arg-type1*) (length arg-type2*))
(andmap same-type? arg-type1* arg-type2*)
(same-type? result-type1 result-type2)
`(fcallable ,conv1 ,(f e1 e2) (,arg-type1* ...) ,result-type1))]
[else #f])]
[(cte-optimization-loc ,box1 ,e1)
(nanopass-case (Lcommonize1 Expr) e2
[(cte-optimization-loc ,box2 ,e2)
(and (eq? box1 box2)
`(cte-optimization-loc ,box1 ,(f e1 e2)))]
[else #f])]
[else (sorry! who "unhandled record ~s" e1)])])
(return (iffalse #f (parameterize ([print-level 3] [print-length 5]) (printf "unify failed for ~s and ~s (call-position ~s)\n" e1 e2 call-position?))) '()))]))
(f e1 e2)))])
(values e subst*)))))))
(define sort-substs
; reestablish original argument order for substituted variables where possible
; so the arguments to an abstracted procedure aren't shuffled around in the
; call to the generated helper.
(lambda (subst0* x1* x2*)
(define (this? x x*) (and (not (null? x*)) (eq? x (car x*))))
(define (next x*) (if (null? x*) x* (cdr x*)))
(let-values ([(new-subst* subst*) (let f ([x1* x1*] [x2* x2*] [subst* subst0*] [n (length subst0*)])
(cond
[(fx= n 0) (values '() subst*)]
[(find (lambda (subst)
(define (is-this-arg? e x*)
(nanopass-case (Lcommonize1 Expr) e
[(ref ,maybe-src ,x) (this? x x*)]
[else #f]))
(or (is-this-arg? (subst-e1 subst) x1*)
(is-this-arg? (subst-e2 subst) x2*)))
subst*) =>
(lambda (subst)
(let-values ([(new-subst* subst*) (f (next x1*) (next x2*) (remq subst subst*) (fx- n 1))])
(values (cons subst new-subst*) subst*)))]
[else
(let-values ([(new-subst* subst*) (f (next x1*) (next x2*) subst* (fx- n 1))])
(values (cons (car subst*) new-subst*) (cdr subst*)))]))])
(safe-assert (null? subst*))
(safe-assert (fx= (length new-subst*) (length subst0*)))
new-subst*)))
(define find-match
(lambda (b1 ht)
(and (iffalse (worthwhile-size? (binding-size b1)) (printf "skipping b1: under worthwhile size ~s ~s\n" (binding-size b1) worthwhile-size))
(ormap (lambda (b2)
(iffalse #f (printf "checking ~s & ~s:" (prelex-name (binding-x b1)) (prelex-name (binding-x b2))))
(nanopass-case (Lcommonize1 Expr) (binding-e b1)
; NB: restricting to one clause for now...handling multiple
; NB: clauses should be straightforward with a helper per
; NB: common clause.
[(case-lambda ,preinfo1 (clause (,x1* ...) ,interface1 ,body1))
; NB: no rest interface for now. should be straightforward
(guard (fxnonnegative? interface1))
(and
(nanopass-case (Lcommonize1 Expr) (binding-e b2)
[(case-lambda ,preinfo2 (clause (,x2* ...) ,interface2 ,body2))
(guard (fxnonnegative? interface2))
(let-values ([(e subst*) (unify body1 body2)])
(and e
(iffalse (worthwhile-ratio? (binding-size b1) (length subst*)) (printf " no, not worthwhile ratio ~s ~s\n" (binding-size b1) (length subst*)))
(let ([subst* (sort-substs subst* x1* x2*)])
(iffalse #f (printf " yes\n"))
(make-frob subst* e b2))))]
[else (iffalse #f (printf " no, b2 does not meet lambda restrictions\n"))]))]
[else (iffalse #f (printf " no, b1 does not meet lambda restrictions\n"))]))
(hashtable-ref ht (binding-size b1) '())))))
(define record-helper!
(lambda (b next e*)
(binding-helper-b-set! b next)
(binding-helper-arg*-set! b e*)))
(define build-helper
(lambda (t t* body size helper-box)
(make-binding t
(with-output-language (Lcommonize1 Expr)
`(case-lambda ,(make-preinfo-lambda) (clause (,t* ...) ,(length t*) ,body)))
size
helper-box)))
(define commonize-letrec
(lambda (x* e* size* body) ; e* and body have not been processed
(define (prune-and-process! b)
(let ([b* (remq b (hashtable-ref ht (binding-size b) '()))])
(if (null? b*)
(hashtable-delete! ht (binding-size b))
(hashtable-set! ht (binding-size b) b*)))
(unless (binding-helper-b b) (binding-e-set! b (Expr (binding-e b)))))
(if (null? x*)
body
(let ([helper-box (box '())])
(let ([b* (map (lambda (x e size) (make-binding x e size helper-box)) x* e* size*)])
(let ([body (let f ([b* b*])
(if (null? b*)
(Expr body)
(let ([b (car b*)])
(let ([frob (find-match b ht)])
(if frob
(let* ([outer-b (frob-b frob)]
[helper-box (binding-helper-box outer-b)]
[helper-b (let ([t (make-prelex* (make-sym (binding-x b) "&" (binding-x outer-b)))])
(build-helper t (map subst-t (frob-subst* frob)) (frob-e frob) (binding-size outer-b) helper-box))])
(set-box! helper-box (cons helper-b (unbox helper-box)))
(record-helper! b helper-b (map subst-e1 (frob-subst* frob)))
(record-helper! outer-b helper-b (map subst-e2 (frob-subst* frob)))
(hashtable-update! ht (binding-size outer-b) (lambda (b*) (cons helper-b (remq outer-b b*))) '())
(f (cdr b*)))
(begin
(hashtable-update! ht (binding-size b) (lambda (b*) (cons b b*)) '())
(let ([body (f (cdr b*))])
(prune-and-process! b)
body)))))))])
(let ([helper-b* (unbox helper-box)])
(for-each prune-and-process! helper-b*)
(with-output-language (Lcommonize2 Expr)
`(letrec (,helper-b* ...) (,b* ...) ,body))))))))))
(Expr : Expr (ir) -> Expr ()
[(letrec ([,x* ,e* ,size*] ...) ,body)
; only unassigned lambda bindings post-cpletrec
(safe-assert (andmap (lambda (x) (not (prelex-assigned x))) x*))
(safe-assert (andmap (lambda (e) (Lcommonize1-lambda? e)) e*))
(commonize-letrec x* e* size* body)]
[(letrec* ([,x* ,e*] ...) ,body)
; no letrec* run post-cpletrec
(assert #f)]))
(define-pass cpcommonize2 : Lcommonize2 (ir) -> Lsrc ()
(definitions
(define build-caller
(lambda (e helper-b helper-arg*)
(define-who Arg
(lambda (e)
(with-output-language (Lsrc Expr)
(nanopass-case (Lcommonize1 Expr) e
[(ref ,maybe-src ,x) `(ref ,maybe-src ,x)]
[(quote ,d) `(quote ,d)]
[else (sorry! who "unexpected helper arg ~s" e)]))))
(define propagate
(lambda (alist)
(lambda (e)
(nanopass-case (Lsrc Expr) e
[(ref ,maybe-src ,x)
(cond
[(assq x alist) => cdr]
[else e])]
[else e]))))
(nanopass-case (Lcommonize1 Expr) e
[(case-lambda ,preinfo (clause (,x* ...) ,interface ,body))
(with-output-language (Lsrc Expr)
`(case-lambda ,preinfo
(clause (,x* ...) ,interface
,(let loop ([helper-b helper-b] [e* (map Arg helper-arg*)])
(if (binding-helper-b helper-b)
(nanopass-case (Lcommonize1 Expr) (binding-e helper-b)
[(case-lambda ,preinfo (clause (,x* ...) ,interface ,body))
(loop (binding-helper-b helper-b) (map (propagate (map cons x* e*)) (map Arg (binding-helper-arg* helper-b))))])
`(call ,(make-preinfo)
,(let ([t (binding-x helper-b)])
(if (prelex-referenced t)
(set-prelex-multiply-referenced! t #t)
(set-prelex-referenced! t #t))
`(ref #f ,t))
,e* ...))))))])))
(define maybe-build-caller
(lambda (b)
(let ([helper-b (binding-helper-b b)] [e (binding-e b)])
(if helper-b
(build-caller e helper-b (binding-helper-arg* b))
(Expr e))))))
(Expr : Expr (ir) -> Expr ()
[(letrec (,helper-b* ...) (,b* ...) ,[body])
(let loop ([rb* (reverse helper-b*)] [x* (map binding-x b*)] [e* (map maybe-build-caller b*)])
(if (null? rb*)
`(letrec ([,x* ,e*] ...) ,body)
(let ([b (car rb*)] [rb* (cdr rb*)])
(if (prelex-referenced (binding-x b))
(loop rb* (cons (binding-x b) x*) (cons (maybe-build-caller b) e*))
(loop rb* x* e*)))))]))
(lambda (x)
(let ([level (commonization-level)])
(if (fx= level 0)
x
(let ([worthwhile-size (expt 2 (fx- 10 level))])
(cpcommonize2 (cpcommonize1 (cpcommonize0 x) worthwhile-size))))))))

111
s/cpletrec.ss
View File

@ -109,14 +109,24 @@ Handling letrec and letrec*
(define-pass cpletrec : Lsrc (ir) -> Lsrc ()
(definitions
(define initialize-id!
(lambda (id)
(prelex-flags-set! id
(let ([flags (prelex-flags id)])
(fxlogor
(fxlogand flags (constant prelex-sticky-mask))
(fxsll (fxlogand flags (constant prelex-is-mask))
(constant prelex-was-flags-offset)))))))
(define with-initialized-ids
(lambda (old-id* proc)
(let ([new-id* (map (lambda (old-id)
(let ([new-id (make-prelex
(prelex-name old-id)
(let ([flags (prelex-flags old-id)])
(fxlogor
(fxlogand flags (constant prelex-sticky-mask))
(fxsll (fxlogand flags (constant prelex-is-mask))
(constant prelex-was-flags-offset))))
(prelex-source old-id)
#f)])
(prelex-operand-set! old-id new-id)
new-id))
old-id*)])
(let-values ([v* (proc new-id*)])
(for-each (lambda (old-id) (prelex-operand-set! old-id #f)) old-id*)
(apply values v*)))))
(define (Expr* e*)
(if (null? e*)
(values '() #t)
@ -243,9 +253,7 @@ Handling letrec and letrec*
(cond
[(and (not (prelex-referenced/assigned lhs)) (binding-pure? b)) body]
[(and (not (prelex-assigned lhs)) (lambda? rhs))
(if (binding-recursive? b)
(build-letrec (list lhs) (list rhs) body)
(build-let (make-preinfo) (make-preinfo-lambda) (list lhs) (list rhs) body))]
(build-letrec (list lhs) (list rhs) body)]
[(not (memq b (node-link* b)))
(build-let (make-preinfo) (make-preinfo-lambda) (list lhs) (list rhs) body)]
[else (grisly-letrec '() b* body)]))
@ -272,32 +280,34 @@ Handling letrec and letrec*
(and body-pure? (andmap binding-pure? b*)))))))))
(Expr : Expr (ir) -> Expr (#t)
[(ref ,maybe-src ,x)
(safe-assert (not (prelex-operand x)))
(safe-assert (prelex-was-referenced x))
(when (prelex-referenced x)
(safe-assert (prelex-was-multiply-referenced x))
(set-prelex-multiply-referenced! x #t))
(set-prelex-seen/referenced! x #t)
(values ir (not (prelex-was-assigned x)))]
(let ([x (prelex-operand x)])
(safe-assert (prelex? x))
(safe-assert (prelex-was-referenced x))
(when (prelex-referenced x)
(safe-assert (prelex-was-multiply-referenced x))
(set-prelex-multiply-referenced! x #t))
(set-prelex-seen/referenced! x #t)
(values `(ref ,maybe-src ,x) (not (prelex-was-assigned x))))]
[(quote ,d) (values ir #t)]
[(call ,preinfo0 (case-lambda ,preinfo1 (clause (,x* ...) ,interface ,body)) ,e* ...)
(guard (fx= (length e*) interface))
(for-each initialize-id! x*)
(let-values ([(body body-pure?) (Expr body)])
(let-values ([(pre* lhs* rhs* pure?)
(let f ([x* x*] [e* e*])
(if (null? x*)
(values '() '() '() #t)
(let ([x (car x*)])
(let-values ([(e e-pure?) (Expr (car e*))]
[(pre* lhs* rhs* pure?) (f (cdr x*) (cdr e*))])
(if (prelex-referenced/assigned x)
(values pre* (cons x lhs*) (cons e rhs*) (and e-pure? pure?))
(values (if e-pure? pre* (cons e pre*))
lhs* rhs* (and e-pure? pure?)))))))])
(values
(build-seq pre* (build-let preinfo0 preinfo1 lhs* rhs* body))
(and body-pure? pure?))))]
(with-initialized-ids x*
(lambda (x*)
(let-values ([(body body-pure?) (Expr body)])
(let-values ([(pre* lhs* rhs* pure?)
(let f ([x* x*] [e* e*])
(if (null? x*)
(values '() '() '() #t)
(let ([x (car x*)])
(let-values ([(e e-pure?) (Expr (car e*))]
[(pre* lhs* rhs* pure?) (f (cdr x*) (cdr e*))])
(if (prelex-referenced/assigned x)
(values pre* (cons x lhs*) (cons e rhs*) (and e-pure? pure?))
(values (if e-pure? pre* (cons e pre*))
lhs* rhs* (and e-pure? pure?)))))))])
(values
(build-seq pre* (build-let preinfo0 preinfo1 lhs* rhs* body))
(and body-pure? pure?))))))]
[(call ,preinfo ,pr ,e* ...)
(let ()
(define (arity-okay? arity n)
@ -321,19 +331,23 @@ Handling letrec and letrec*
[(seq ,[e1 e1-pure?] ,[e2 e2-pure?])
(values `(seq ,e1 ,e2) (and e1-pure? e2-pure?))]
[(set! ,maybe-src ,x ,[e pure?])
(safe-assert (prelex-was-assigned x))
; NB: cpletrec-letrec assumes assignments to unreferenced ids are dropped
(if (prelex-was-referenced x)
(begin
(set-prelex-seen/assigned! x #t)
(values `(set! ,maybe-src ,x ,e) #f))
(if pure? (values `(quote ,(void)) #t) (values `(seq ,e (quote ,(void))) #f)))]
(let ([x (prelex-operand x)])
(safe-assert (prelex? x))
(safe-assert (prelex-was-assigned x))
; NB: cpletrec-letrec assumes assignments to unreferenced ids are dropped
(if (prelex-was-referenced x)
(begin
(set-prelex-seen/assigned! x #t)
(values `(set! ,maybe-src ,x ,e) #f))
(if pure? (values `(quote ,(void)) #t) (values `(seq ,e (quote ,(void))) #f))))]
[(letrec ([,x* ,e*] ...) ,body)
(for-each initialize-id! x*)
(cpletrec-letrec #f x* e* body)]
(with-initialized-ids x*
(lambda (x*)
(cpletrec-letrec #f x* e* body)))]
[(letrec* ([,x* ,e*] ...) ,body)
(for-each initialize-id! x*)
(cpletrec-letrec #t x* e* body)]
(with-initialized-ids x*
(lambda (x*)
(cpletrec-letrec #t x* e* body)))]
[(foreign ,conv ,name ,[e pure?] (,arg-type* ...) ,result-type)
(values `(foreign ,conv ,name ,e (,arg-type* ...) ,result-type)
(and (fx= (optimize-level) 3) pure?))]
@ -367,9 +381,10 @@ Handling letrec and letrec*
[else (sorry! who "unhandled record ~s" ir)])
(CaseLambdaClause : CaseLambdaClause (ir) -> CaseLambdaClause ()
[(clause (,x* ...) ,interface ,body)
(for-each initialize-id! x*)
(let-values ([(body pure?) (Expr body)])
`(clause (,x* ...) ,interface ,body))])
(with-initialized-ids x*
(lambda (x*)
(let-values ([(body pure?) (Expr body)])
`(clause (,x* ...) ,interface ,body))))])
(let-values ([(ir pure?) (Expr ir)]) ir))
(lambda (x)

136
s/cpnanopass.ss
View File

@ -972,9 +972,19 @@
(fields type reversed? invertible?))
(define-record-type info-c-simple-call (nongenerative)
(parent info-kill*-live*)
(sealed #t)
(fields save-ra? entry)
(protocol
(lambda (new)
(case-lambda
[(save-ra? entry) ((new '() '()) save-ra? entry)]
[(live* save-ra? entry) ((new '() live*) save-ra? entry)]))))
(define-record-type info-c-return (nongenerative)
(parent info)
(sealed #t)
(fields save-ra? entry))
(fields offset))
(module ()
(record-writer (record-type-descriptor info-load)
@ -1857,7 +1867,7 @@
[(fcallable ,info)
(let ([label (make-local-label 'fcallable)])
(set! gl* (cons label gl*))
(set! gle* (cons (in-context CaseLambdaExpr `(fcallable ,info)) gle*))
(set! gle* (cons (in-context CaseLambdaExpr `(fcallable ,info ,label)) gle*))
`(label-ref ,label 0))])
(nanopass-case (L6 CaseLambdaExpr) ir
[(case-lambda ,info ,[CaseLambdaClause : cl #f -> cl] ...)
@ -2324,7 +2334,7 @@
[(fcallable ,info)
(let ([label (make-local-label 'fcallable)])
(set! gl* (cons label gl*))
(set! gle* (cons (in-context CaseLambdaExpr `(fcallable ,info)) gle*))
(set! gle* (cons (in-context CaseLambdaExpr `(fcallable ,info ,label)) gle*))
`(label-ref ,label 0))]
[(let ([,x* ,[e*]] ...) ,body)
(with-offsets index x*
@ -5335,6 +5345,8 @@
(define-tc-parameter $target-machine target-machine)
(define-tc-parameter $current-stack-link stack-link)
(define-tc-parameter $current-winders winders)
(define-tc-parameter default-record-equal-procedure default-record-equal-procedure)
(define-tc-parameter default-record-hash-procedure default-record-hash-procedure)
)
(define-inline 3 $install-guardian
@ -10470,7 +10482,23 @@
(set! ,x ,t)
,(toC (in-context Rhs
(%mref ,x ,(constant record-data-disp))))))]
[(fp-ftd& ,ftd)
(let ([x (make-tmp 't)])
(%seq
(set! ,x ,t)
(set! ,x ,(%mref ,x ,(constant record-data-disp)))
,(toC x)))]
[else ($oops who "invalid parameter type specifier ~s" type)])))
(define Scheme->C-for-result
(lambda (type toC t)
(nanopass-case (Ltype Type) type
[(fp-void) (toC)]
[(fp-ftd& ,ftd)
;; pointer isn't received as a result, but instead passed
;; to the function as its first argument (or simulated as such)
(toC)]
[else
(Scheme->C type toC t)])))
(define C->Scheme
; ASSUMPTIONS: ac0, ac1, and xp are not C argument registers
(lambda (type fromC lvalue)
@ -10538,6 +10566,15 @@
,(e1 `(goto ,Lbig))
(seq (label ,Lbig) ,e2)))))
(e1 e2))))))
(define (alloc-fptr ftd)
(%seq
(set! ,%xp
,(%constant-alloc type-typed-object (fx* (constant ptr-bytes) 2) #f))
(set!
,(%mref ,%xp ,(constant record-type-disp))
(literal ,(make-info-literal #f 'object ftd 0)))
(set! ,(%mref ,%xp ,(constant record-data-disp)) ,%ac0)
(set! ,lvalue ,%xp)))
(nanopass-case (Ltype Type) type
[(fp-void) `(set! ,lvalue ,(%constant svoid))]
[(fp-scheme-object) (fromC lvalue)]
@ -10585,15 +10622,17 @@
(set! ,lvalue ,%xp))]
[(fp-ftd ,ftd)
(%seq
,(fromC %ac0) ; C integer return might be wiped out by alloc
(set! ,%xp
,(%constant-alloc type-typed-object (fx* (constant ptr-bytes) 2) #f))
(set!
,(%mref ,%xp ,(constant record-type-disp))
(literal ,(make-info-literal #f 'object ftd 0)))
(set! ,(%mref ,%xp ,(constant record-data-disp)) ,%ac0)
(set! ,lvalue ,%xp))]
,(fromC %ac0) ; C integer return might be wiped out by alloc
,(alloc-fptr ftd))]
[(fp-ftd& ,ftd)
(%seq
,(fromC %ac0)
,(alloc-fptr ftd))]
[else ($oops who "invalid result type specifier ~s" type)]))))
(define (pick-Scall result-type)
(nanopass-case (Ltype Type) result-type
[(fp-void) (lookup-c-entry Scall-any-results)]
[else (lookup-c-entry Scall-one-result)]))
(define build-foreign-call
(with-output-language (L13 Effect)
(lambda (info t0 t1* maybe-lvalue new-frame?)
@ -10613,14 +10652,20 @@
(ccall t0) t1* arg-type* c-args))
,(let ([e (deallocate)])
(if maybe-lvalue
`(seq ,(C->Scheme result-type c-res maybe-lvalue) ,e)
(nanopass-case (Ltype Type) result-type
[(fp-ftd& ,ftd)
;; Don't actually return a value, because the result
;; was instead installed in the first argument.
`(seq (set! ,maybe-lvalue ,(%constant svoid)) ,e)]
[else
`(seq ,(C->Scheme result-type c-res maybe-lvalue) ,e)])
e))))])
(if new-frame?
(sorry! who "can't handle nontail foreign calls")
e))))))
(define build-fcallable
(with-output-language (L13 Tail)
(lambda (info)
(lambda (info self-label)
(define set-locs
(lambda (loc* t* ebody)
(fold-right
@ -10638,14 +10683,11 @@
(cons (get-fv i) (f (cdr frame-x*) i)))))])
; add 2 for the old RA and cchain
(set! max-fv (fx+ max-fv 2))
(let-values ([(c-init c-args c-scall) (asm-foreign-callable info)])
; c-init save C callee-save registers and restores tc
(let-values ([(c-init c-args c-result c-return) (asm-foreign-callable info)])
; c-init saves C callee-save registers and restores tc
; each of c-args sets a variable to one of the C arguments
; c-scall restores callee-save registers and tail-calls C
; Three reasons to tail call:
; (1) let C deal with return value conversion
; (2) avoid need to lock target code object
; (3) let C deal with longjmp & cchain
; c-result converts C results to Scheme values
; c-return restores callee-save registers and returns to C
(%seq
,(c-init)
,(restore-scheme-state
@ -10664,31 +10706,19 @@
; cookie (0) will be replaced by the procedure, so this
; needs to be a quote, not an immediate
(set! ,(ref-reg %ac1) (literal ,(make-info-literal #f 'object 0 0)))
(set! ,(ref-reg %ts) (label-ref ,self-label 0)) ; for locking
,(save-scheme-state
(in %ac0 %ac1)
(out %cp %xp %yp %ts %td scheme-args extra-regs))
,(c-scall fv*
(nanopass-case (Ltype Type) result-type
[(fp-scheme-object) (lookup-c-entry Scall->ptr)]
[(fp-void) (lookup-c-entry Scall->void)]
[(fp-fixnum) (lookup-c-entry Scall->fixnum)]
[(fp-integer ,bits)
(case bits
[(8 16 32) (lookup-c-entry Scall->int32)]
[(64) (lookup-c-entry Scall->int64)]
[else ($oops 'foreign-callable "unsupported result type specifier integer-~s" bits)])]
[(fp-unsigned ,bits)
(case bits
[(8 16 32) (lookup-c-entry Scall->uns32)]
[(64) (lookup-c-entry Scall->uns64)]
[else ($oops 'foreign-callable "unsupported result type specifier unsigned-~s" bits)])]
[(fp-double-float) (lookup-c-entry Scall->double)]
[(fp-single-float) (lookup-c-entry Scall->single)]
[(fp-u8*) (lookup-c-entry Scall->bytevector)]
[(fp-u16*) (lookup-c-entry Scall->bytevector)]
[(fp-u32*) (lookup-c-entry Scall->bytevector)]
[(fp-ftd ,ftd) (lookup-c-entry Scall->fptr)]
[else ($oops 'compiler-internal "invalid result type specifier ~s" result-type)]))))))))))))
(in %ac0 %ac1 %ts)
(out %cp %xp %yp %td scheme-args extra-regs))
; Scall-{any,one}-results calls the Scheme implementation of the
; callable, locking this callable wrapper (as communicated in %ts)
; until just before returning
(inline ,(make-info-c-simple-call fv* #f (pick-Scall result-type)) ,%c-simple-call)
,(restore-scheme-state
(in %ac0)
(out %ac1 %cp %xp %yp %ts %td scheme-args extra-regs))
,(Scheme->C-for-result result-type c-result %ac0)
,(c-return)))))))))))
(define handle-do-rest
(lambda (fixed-args offset save-asm-ra?)
(with-output-language (L13 Effect)
@ -11000,11 +11030,11 @@
(safe-assert (nodups local*))
(for-each (lambda (local) (uvar-location-set! local #f)) local*)
`(lambda ,info ,max-fv (,local* ...) ,tlbody))))]
[(fcallable ,info)
[(fcallable ,info ,l)
(let ([lambda-info (make-info-lambda #f #f #f (list (length (info-foreign-arg-type* info)))
(info-foreign-name info))])
(fluid-let ([max-fv 0] [local* '()])
(let ([tlbody (build-fcallable info)])
(let ([tlbody (build-fcallable info l)])
`(lambda ,lambda-info ,max-fv (,local* ...) ,tlbody))))]
[(hand-coded ,sym)
(case sym
@ -12495,6 +12525,10 @@
(let ([block (make-tail-block)])
(tail-block-tail-set! block (with-output-language (L15a Tail) `(asm-return ,reg* ...)))
(values block (cons block block*)))]
[(asm-c-return ,info ,reg* ...)
(let ([block (make-tail-block)])
(tail-block-tail-set! block (with-output-language (L15a Tail) `(asm-c-return ,info ,reg* ...)))
(values block (cons block block*)))]
[else ($oops who "unexpected Tail ~s" ir)])
(Effect : Effect (ir target block*) -> * (target block*)
[(nop) (values target block*)]
@ -13808,6 +13842,7 @@
[else (sorry! who "unrecognized block ~s" block)]))))
(Tail : Tail (ir chunk* offset) -> * (code* chunk* offset)
[(asm-return) (values (asm-return) chunk* offset)]
[(asm-c-return ,info) (values (asm-c-return info) chunk* offset)]
[(jump (label-ref ,l ,offset0))
(values (asm-direct-jump l offset0) chunk* offset)]
[(jump (literal ,info))
@ -14093,6 +14128,9 @@
[(asm-return ,reg* ...)
(safe-assert (eq? out no-live*))
(fold-left add-var no-live* reg*)]
[(asm-c-return ,info ,reg* ...)
(safe-assert (eq? out no-live*))
(fold-left add-var no-live* reg*)]
[(jump ,live-info ,t (,var* ...))
(let ([out (fold-left add-var out var*)])
(live-info-live-set! live-info out)
@ -14663,7 +14701,8 @@
(Pred : Pred (ir) -> Pred ())
(Tail : Tail (ir) -> Tail ()
[(jump ,live-info ,[t] (,var* ...)) `(jump ,live-info ,t)]
[(asm-return ,reg* ...) `(asm-return)])
[(asm-return ,reg* ...) `(asm-return)]
[(asm-c-return ,info ,reg* ...) `(asm-c-return ,info)])
(Effect : Effect (ir) -> Effect ())
(foldable-Effect : Effect (ir new-effect*) -> * (new-effect*)
[(return-point ,info ,rpl ,mrvl (,cnfv* ...))
@ -15062,7 +15101,8 @@
(Tail : Tail (ir) -> Tail ()
[(jump ,live-info ,t) (handle-jump t (live-info-live live-info))]
[(goto ,l) (values '() `(goto ,l))]
[(asm-return) (values '() `(asm-return))])
[(asm-return) (values '() `(asm-return))]
[(asm-c-return ,info) (values '() `(asm-c-return ,info))])
(Effect : Effect (ir new-effect*) -> * (new-effect*)
[(set! ,live-info ,lvalue ,rhs) (Rhs rhs lvalue new-effect* (live-info-live live-info))]
[(inline ,live-info ,info ,effect-prim ,t* ...)

70
s/cprep.ss
View File

@ -26,8 +26,8 @@
(Inner : Inner (ir) -> * (val)
[,lsrc (go lsrc)]
[(program ,uid ,body) (go ($build-invoke-program uid body))]
[(library/ct ,uid ,import-code ,visit-code)
(go ($build-install-library/ct-code uid import-code visit-code))]
[(library/ct ,uid (,export-id* ...) ,import-code ,visit-code)
(go ($build-install-library/ct-code uid export-id* import-code visit-code))]
[(library/rt ,uid (,dl* ...) (,db* ...) (,dv* ...) (,de* ...) ,body)
(go ($build-install-library/rt-code uid dl* db* dv* de* body))]
[,linfo/ct `(library/ct-info ,(library-info-uid linfo/ct) ,(library/ct-info-import-req* linfo/ct)
@ -115,7 +115,8 @@
[(fp-fixnum) 'fixnum]
[(fp-double-float) 'double-float]
[(fp-single-float) 'single-float]
[(fp-ftd ,ftd) 'ftype])))
[(fp-ftd ,ftd) 'ftype]
[(fp-ftd& ,ftd) 'ftype])))
(define uncprep
(lambda (x)
(define keyword?
@ -215,14 +216,15 @@
(lambda (who cte? x env)
(define (go x)
($uncprep
($cpcheck
(let ([cpletrec-ran? #f])
(let ([x ((run-cp0)
(lambda (x)
(set! cpletrec-ran? #t)
($cpletrec ($cp0 x $compiler-is-loaded?)))
($cpvalid x))])
(if cpletrec-ran? x ($cpletrec x)))))))
($cpcommonize
($cpcheck
(let ([cpletrec-ran? #f])
(let ([x ((run-cp0)
(lambda (x)
(set! cpletrec-ran? #t)
($cpletrec ($cp0 x $compiler-is-loaded?)))
($cpvalid x))])
(if cpletrec-ran? x ($cpletrec x))))))))
(unless (environment? env)
($oops who "~s is not an environment" env))
; claim compiling-a-file to get cte as well as run-time code
@ -243,4 +245,48 @@
(unless (environment? env)
($oops who "~s is not an environment" env))
; claim compiling-a-file to get cte as well as run-time code
($uncprep (expand x env #t #t))])))))
($uncprep (expand x env #t #t))]))))
(set-who! $cpcheck-prelex-flags
(lambda (x after-pass)
(import (nanopass))
(include "base-lang.ss")
(define-pass cpcheck-prelex-flags : Lsrc (ir) -> Lsrc ()
(definitions
(define sorry!
(lambda (who str . arg*)
(apply fprintf (console-output-port) str arg*)
(newline (console-output-port))))
(define initialize-id!
(lambda (id)
(prelex-flags-set! id
(let ([flags (prelex-flags id)])
(fxlogor
(fxlogand flags (constant prelex-sticky-mask))
(fxsll (fxlogand flags (constant prelex-is-mask))
(constant prelex-was-flags-offset))))))))
(Expr : Expr (ir) -> Expr ()
[(ref ,maybe-src ,x)
(when (prelex-operand x) (sorry! who "~s has an operand after ~s (src ~s)" x after-pass maybe-src))
(unless (prelex-was-referenced x) (sorry! who "~s referenced but not so marked after ~s (src ~s)" x after-pass maybe-src))
(when (prelex-referenced x)
(unless (prelex-was-multiply-referenced x) (sorry! who "~s multiply referenced but not so marked after ~s (src ~s)" x after-pass maybe-src))
(set-prelex-multiply-referenced! x #t))
(set-prelex-referenced! x #t)
`(ref ,maybe-src ,x)]
[(set! ,maybe-src ,x ,[e])
(unless (prelex-was-assigned x) (sorry! who "~s assigned but not so marked after ~s (src ~s)" x after-pass maybe-src))
(set-prelex-assigned! x #t)
`(set! ,maybe-src ,x ,e)]
[(letrec ([,x* ,e*] ...) ,body)
(for-each initialize-id! x*)
`(letrec ([,x* ,(map Expr e*)] ...) ,(Expr body))]
[(letrec* ([,x* ,e*] ...) ,body)
(for-each initialize-id! x*)
`(letrec* ([,x* ,(map Expr e*)] ...) ,(Expr body))])
(CaseLambdaClause : CaseLambdaClause (ir) -> CaseLambdaClause ()
[(clause (,x* ...) ,interface ,body)
(for-each initialize-id! x*)
`(clause (,x* ...) ,interface ,(Expr body))]))
(Lexpand-to-go x cpcheck-prelex-flags))))

6
s/expand-lang.ss
View File

@ -80,10 +80,10 @@
(define maybe-label? (lambda (x) (or (not x) (gensym? x))))
(define-language Lexpand
(nongenerative-id #{Lexpand fgy7v2wrvj0so4ro8kvhqo-1})
(nongenerative-id #{Lexpand fgy7v2wrvj0so4ro8kvhqo-2})
(terminals
(maybe-label (dl))
(gensym (uid))
(gensym (uid export-id))
(library-path (path))
(library-version (version))
(maybe-optimization-loc (db))
@ -110,7 +110,7 @@
prog
lsrc)
(ctLibrary (ctlib)
(library/ct uid import-code visit-code))
(library/ct uid (export-id* ...) import-code visit-code))
(rtLibrary (rtlib)
(library/rt uid
(dl* ...)

127
s/ftype.ss
View File

@ -560,21 +560,32 @@ ftype operators:
(define expand-fp-ftype
(lambda (who what r ftype def-alist)
(syntax-case ftype ()
[(*-kwd ftype-name)
(and (eq? (datum *-kwd) '*) (identifier? #'ftype-name))
(let ([stype (syntax->datum ftype)])
(cond
[(assp (lambda (x) (bound-identifier=? #'ftype-name x)) def-alist) =>
(lambda (a)
(if (ftd? (cdr a))
(make-ftd-pointer rtd/fptr #f stype pointer-size pointer-alignment (cdr a))
(let ([ftd (make-ftd-pointer rtd/fptr #f stype pointer-size pointer-alignment #f)])
(set-cdr! a (cons ftd (cdr a)))
ftd)))]
[(expand-ftype-name r #'ftype-name #f) =>
(lambda (ftd)
(make-ftd-pointer rtd/fptr #f stype pointer-size pointer-alignment ftd))]
[else (syntax-error #'ftype-name (format "unrecognized ~s ~s ftype name" who what))]))]
[(*/&-kwd ftype-name)
(and (or (eq? (datum */&-kwd) '*)
(eq? (datum */&-kwd) '&))
(identifier? #'ftype-name))
(let* ([stype (syntax->datum ftype)]
[ftd
(cond
[(assp (lambda (x) (bound-identifier=? #'ftype-name x)) def-alist) =>
(lambda (a)
(if (ftd? (cdr a))
(make-ftd-pointer rtd/fptr #f stype pointer-size pointer-alignment (cdr a))
(let ([ftd (make-ftd-pointer rtd/fptr #f stype pointer-size pointer-alignment #f)])
(set-cdr! a (cons ftd (cdr a)))
ftd)))]
[(expand-ftype-name r #'ftype-name #f) =>
(lambda (ftd)
(make-ftd-pointer rtd/fptr #f stype pointer-size pointer-alignment ftd))]
[else (syntax-error #'ftype-name (format "unrecognized ~s ~s ftype name" who what))])])
;; Scheme-side argument is a pointer to a value, but foreign side has two variants:
(if (eq? (datum */&-kwd) '&)
(cond
[(ftd-array? (ftd-pointer-ftd ftd))
(syntax-error ftype (format "array value invalid as ~a ~s" who what))]
[else
(box ftd)]) ; boxed ftd => pass/receive the value (as opposed to a pointer to the value)
ftd))] ; plain ftd => pass/receive a pointer to the value
[_ (cond
[(and (identifier? ftype) (expand-ftype-name r ftype #f)) =>
(lambda (ftd)
@ -586,11 +597,14 @@ ftype operators:
[else (syntax->datum ftype)])])))
(define-who indirect-ftd-pointer
(lambda (x)
(if (ftd? x)
(if (ftd-pointer? x)
(ftd-pointer-ftd x)
($oops who "~s is not an ftd-pointer" x))
x)))
(cond
[(ftd? x)
(if (ftd-pointer? x)
(ftd-pointer-ftd x)
($oops who "~s is not an ftd-pointer" x))]
[(box? x)
(box (indirect-ftd-pointer (unbox x)))]
[else x])))
(define-who expand-ftype-defns
(lambda (r defid* ftype*)
(define patch-pointer-ftds!
@ -728,7 +742,10 @@ ftype operators:
[else x]))
#'?addr)])
#`($make-fptr '#,ftd
#,(if (fx= (optimize-level) 3)
#,(if (or (fx= (optimize-level) 3)
(syntax-case #'addr-expr (ftype-pointer-address)
[(ftype-pointer-address x) #t]
[else #f]))
#'addr-expr
#'(let ([addr addr-expr])
($verify-ftype-address 'make-ftype addr)
@ -926,6 +943,74 @@ ftype operators:
(set! $ftd?
(lambda (x)
(ftd? x)))
(set! $ftd-as-box? ; represents `(& <ftype>)` from `$expand-fp-ftype`
(lambda (x)
(and (box? x) (ftd? (unbox x)))))
(set! $ftd-size
(lambda (x)
(ftd-size x)))
(set! $ftd-alignment
(lambda (x)
(ftd-alignment x)))
(set! $ftd-compound?
(lambda (x)
(or (ftd-struct? x)
(ftd-union? x)
(ftd-array? x))))
(set! $ftd->members
(lambda (x)
;; Currently used for x86_64 and arm32 ABI: Returns a list of
;; (list 'integer/'float size offset)
(let loop ([x x] [offset 0] [accum '()])
(cond
[(ftd-base? x)
(cons (list (case (ftd-base-type x)
[(double double-float float single-float)
'float]
[else 'integer])
(ftd-size x)
offset)
accum)]
[(ftd-struct? x)
(let struct-loop ([field* (ftd-struct-field* x)] [accum accum])
(cond
[(null? field*) accum]
[else (let* ([fld (car field*)]
[sub-ftd (caddr fld)]
[sub-offset (cadr fld)])
(struct-loop (cdr field*)
(loop sub-ftd (+ offset sub-offset) accum)))]))]
[(ftd-union? x)
(let union-loop ([field* (ftd-union-field* x)] [accum accum])
(cond
[(null? field*) accum]
[else (let* ([fld (car field*)]
[sub-ftd (cdr fld)])
(union-loop (cdr field*)
(loop sub-ftd offset accum)))]))]
[(ftd-array? x)
(let ([elem-ftd (ftd-array-ftd x)])
(let array-loop ([len (ftd-array-length x)] [offset offset] [accum accum])
(cond
[(fx= len 0) accum]
[else (array-loop (fx- len 1)
(+ offset (ftd-size elem-ftd))
(loop elem-ftd offset accum))])))]
[else (cons (list 'integer (ftd-size x) offset) accum)]))))
(set! $ftd-atomic-category
(lambda (x)
;; Currently used for PowerPC32 ABI
(cond
[(ftd-base? x)
(case (ftd-base-type x)
[(double double-float float single-float)
'float]
[(unsigned-short unsigned unsigned-int
unsigned-long unsigned-long-long
unsigned-8 unsigned-16 unsigned-32 unsigned-64)
'unsigned]
[else 'integer])]
[else 'integer])))
(set! $expand-fp-ftype ; for foreign-procedure, foreign-callable
(lambda (who what r ftype)
(indirect-ftd-pointer

7
s/interpret.ss
View File

@ -657,7 +657,8 @@
($cpletrec ($cp0 x #f)))
x2)])
(if cpletrec-ran? x ($cpletrec x))))]
[x2b ($cpcheck x2a)])
[x2b ($cpcheck x2a)]
[x2b ($cpcommonize x2b)])
(when eoo (pretty-print ($uncprep x2b) eoo))
(ip2 (ip1 x2b))))
([a0 0] [a1 0] [fp 0] [cp 0]))))
@ -665,8 +666,8 @@
[,lsrc (ibeval lsrc)]
[(program ,uid ,body)
(ibeval ($build-invoke-program uid body))]
[(library/ct ,uid ,import-code ,visit-code)
(ibeval ($build-install-library/ct-code uid import-code visit-code))]
[(library/ct ,uid (,export-id* ...) ,import-code ,visit-code)
(ibeval ($build-install-library/ct-code uid export-id* import-code visit-code))]
[(library/rt ,uid (,dl* ...) (,db* ...) (,dv* ...) (,de* ...) ,body)
(ibeval ($build-install-library/rt-code uid dl* db* dv* de* body))]
[,linfo/rt ($install-library/rt-desc linfo/rt for-import? ofn)]

21
s/newhash.ss
View File

@ -1145,14 +1145,15 @@ Documentation notes:
(let ()
(define (lookup-equal-procedure record1 record2)
(let ([e/h (lookup-equal/hash record1 'equal-proc)])
(and e/h
(let ([proc (equal/hash-maybe-proc e/h)])
(and proc
(let ([rtd (equal/hash-rtd e/h)])
(let ([e/h (lookup-equal/hash record2 'equal-proc)])
(and e/h
(eq? (equal/hash-rtd e/h) rtd)
proc))))))))
(let ([proc (equal/hash-maybe-proc e/h)])
(if proc
(and
(eq? (equal/hash-rtd (lookup-equal/hash record2 'equal-proc)) (equal/hash-rtd e/h))
proc)
(let ([default-proc (default-record-equal-procedure)])
(and default-proc
(not (equal/hash-maybe-proc (lookup-equal/hash record2 'equal-proc)))
default-proc))))))
(set-who! $record-equal-procedure
(lambda (record1 record2)
(lookup-equal-procedure record1 record2)))
@ -1163,8 +1164,8 @@ Documentation notes:
(lookup-equal-procedure record1 record2))))
(let ()
(define (lookup-hash-procedure record)
(let ([e/h (lookup-equal/hash record 'hash-proc)])
(and e/h (equal/hash-maybe-proc e/h))))
(or (equal/hash-maybe-proc (lookup-equal/hash record 'hash-proc))
(default-record-hash-procedure)))
(set-who! $record-hash-procedure
(lambda (record)
(lookup-hash-procedure record)))

16
s/np-languages.ss
View File

@ -416,7 +416,7 @@
(Program (prog)
(+ (labels ([l* le*] ...) l) => (labels ([l* le*] ...) (l))))
(CaseLambdaExpr (le)
(+ (fcallable info) => (fcallable info)))
(+ (fcallable info l) => (fcallable info l)))
(Lvalue (lvalue)
(+ x
(mref e1 e2 imm)))
@ -488,10 +488,13 @@
(declare-primitive asmlibcall! effect #f)
(declare-primitive c-call effect #f)
(declare-primitive c-simple-call effect #f)
(declare-primitive c-simple-return effect #f)
(declare-primitive fl* effect #f)
(declare-primitive fl+ effect #f)
(declare-primitive fl- effect #f)
(declare-primitive fl/ effect #f)
(declare-primitive fldl effect #f) ; x86
(declare-primitive flds effect #f) ; x86
(declare-primitive flsqrt effect #f) ; not implemented for some ppc32 (so we don't use it)
(declare-primitive flt effect #f)
(declare-primitive inc-cc-counter effect #f)
@ -544,6 +547,7 @@
(declare-primitive -/eq value #f)
(declare-primitive asmlibcall value #f)
(declare-primitive fstpl value #f) ; x86 only
(declare-primitive fstps value #f) ; x86 only
(declare-primitive get-double value #t) ; x86_64
(declare-primitive get-tc value #f) ; threaded version only
(declare-primitive lea1 value #t)
@ -849,6 +853,7 @@
(jump t (var* ...))
(joto l (nfv* ...))
(asm-return reg* ...)
(asm-c-return info reg* ...)
(if p0 tl1 tl2)
(seq e0 tl1)
(goto l)))
@ -961,7 +966,8 @@
(Tail (tl)
(goto l)
(jump live-info t (var* ...))
(asm-return reg* ...)))
(asm-return reg* ...)
(asm-c-return info reg* ...)))
(define-language L15b (extends L15a)
(terminals
@ -979,9 +985,11 @@
(+ (fp-offset live-info imm)))
(Tail (tl)
(- (jump live-info t (var* ...))
(asm-return reg* ...))
(asm-return reg* ...)
(asm-c-return info reg* ...))
(+ (jump live-info t)
(asm-return))))
(asm-return)
(asm-c-return info))))
(define ur?
(lambda (x)

484
s/ppc32.ss
View File

@ -810,7 +810,7 @@
asm-lock asm-lock+/-
asm-fl-load/store
asm-flop-2 asm-c-simple-call
asm-save-flrv asm-restore-flrv asm-return asm-size
asm-save-flrv asm-restore-flrv asm-return asm-c-return asm-size
asm-enter asm-foreign-call asm-foreign-callable
asm-read-counter
asm-read-time-base
@ -2077,6 +2077,10 @@
(lambda ()
(emit blr '())))
(define asm-c-return
(lambda (info)
(emit blr '())))
(define asm-lognot
(lambda (code* dest src)
(Trivit (dest src)
@ -2129,19 +2133,27 @@
(define align (lambda (b x) (let ([k (- b 1)]) (fxlogand (fx+ x k) (fxlognot k)))))
(define gp-parameter-regs (lambda () (list %Carg1 %Carg2 %Carg3 %Carg4 %Carg5 %Carg6 %Carg7 %Carg8)))
(define fp-parameter-regs (lambda () (list %Cfparg1 %Cfparg2 %Cfparg3 %Cfparg4 %Cfparg5 %Cfparg6 %Cfparg7 %Cfparg8)))
(define (indirect-result-that-fits-in-registers? result-type)
(nanopass-case (Ltype Type) result-type
[(fp-ftd& ,ftd) (not ($ftd-compound? ftd))]
[else #f]))
(define (indirect-result-to-pointer? result-type)
(nanopass-case (Ltype Type) result-type
[(fp-ftd& ,ftd) ($ftd-compound? ftd)]
[else #f]))
(define-who asm-foreign-call
(with-output-language (L13 Effect)
(define load-double-stack
(lambda (offset)
(lambda (offset fp-disp)
(lambda (x) ; requires var
(%seq
(inline ,(make-info-loadfl %flreg1) ,%load-double ,x ,%zero ,(%constant flonum-data-disp))
(inline ,(make-info-loadfl %flreg1) ,%load-double ,x ,%zero (immediate ,fp-disp))
(inline ,(make-info-loadfl %flreg1) ,%store-double ,%sp ,%zero (immediate ,offset))))))
(define load-single-stack
(lambda (offset)
(lambda (offset fp-disp single?)
(lambda (x) ; requires var
(%seq
(inline ,(make-info-loadfl %flreg1) ,%load-double->single ,x ,%zero ,(%constant flonum-data-disp))
(inline ,(make-info-loadfl %flreg1) ,(if single? %load-single %load-double->single) ,x ,%zero (immediate ,fp-disp))
(inline ,(make-info-loadfl %flreg1) ,%store-single ,%sp ,%zero (immediate ,offset))))))
(define load-int-stack
(lambda (offset)
@ -2153,25 +2165,39 @@
(%seq
(set! ,(%mref ,%sp ,(fx+ offset 4)) ,lorhs)
(set! ,(%mref ,%sp ,offset) ,hirhs)))))
(define load-double-reg
(lambda (fpreg)
(define load-indirect-int-stack
(lambda (offset size)
(lambda (rhs) ; requires rhs
(let ([int-type (case size
[(1) 'integer-8]
[(2) 'integer-16]
[else 'integer-32])])
`(set! ,(%mref ,%sp ,offset) (inline ,(make-info-load int-type #f) ,%load ,rhs ,%zero (immediate ,0)))))))
(define load-indirect-int64-stack
(lambda (offset)
(lambda (x) ; requires var
`(inline ,(make-info-loadfl fpreg) ,%load-double ,x ,%zero ,(%constant flonum-data-disp)))))
`(seq
(set! ,(%mref ,%sp ,offset) ,(%mref ,x 0))
(set! ,(%mref ,%sp ,(fx+ offset 4)) ,(%mref ,x 4))))))
(define load-double-reg
(lambda (fpreg fp-disp)
(lambda (x) ; requires var
`(inline ,(make-info-loadfl fpreg) ,%load-double ,x ,%zero (immediate ,fp-disp)))))
(define load-soft-double-reg
(lambda (loreg hireg)
(lambda (loreg hireg fp-disp)
(lambda (x)
(%seq
(set! ,loreg ,(%mref ,x ,(fx+ (constant flonum-data-disp) 4)))
(set! ,hireg ,(%mref ,x ,(constant flonum-data-disp)))))))
(set! ,loreg ,(%mref ,x ,(fx+ fp-disp 4)))
(set! ,hireg ,(%mref ,x ,fp-disp))))))
(define load-single-reg
(lambda (fpreg)
(lambda (fpreg fp-disp single?)
(lambda (x) ; requires var
`(inline ,(make-info-loadfl fpreg) ,%load-double->single ,x ,%zero ,(%constant flonum-data-disp)))))
`(inline ,(make-info-loadfl fpreg) ,(if single? %load-single %load-double->single) ,x ,%zero (immediate ,fp-disp)))))
(define load-soft-single-reg
(lambda (ireg)
(lambda (ireg fp-disp single?)
(lambda (x)
(%seq
(inline ,(make-info-loadfl %flreg1) ,%load-double->single ,x ,%zero ,(%constant flonum-data-disp))
(inline ,(make-info-loadfl %flreg1) ,(if single? %load-single %load-double->single) ,x ,%zero (immediate ,fp-disp))
(inline ,(make-info-loadfl %flreg1) ,%store-single ,%tc ,%zero (immediate ,(constant tc-ac0-disp)))
(set! ,ireg ,(%tc-ref ac0))))))
(define load-int-reg
@ -2184,10 +2210,31 @@
(%seq
(set! ,loreg ,lo)
(set! ,hireg ,hi)))))
(define load-indirect-int-reg
(lambda (ireg size category)
(lambda (rhs) ; requires var
(let ([int-type (case category
[(unsigned) (case size
[(1) 'unsigned-8]
[(2) 'unsigned-16]
[else 'unsigned-32])]
[else (case size
[(1) 'integer-8]
[(2) 'integer-16]
[else 'integer-32])])])
`(set! ,ireg (inline ,(make-info-load int-type #f) ,%load ,rhs ,%zero (immediate ,0)))))))
(define load-indirect-int64-reg
(lambda (loreg hireg)
(lambda (x) ; requires var
`(seq
(set! ,hireg ,(%mref ,x 0))
(set! ,loreg ,(%mref ,x 4))))))
(define do-args
(lambda (types)
;; NB: start stack pointer at 8 to put arguments above the linkage area
(let loop ([types types] [locs '()] [live* '()] [int* (gp-parameter-regs)] [flt* (fp-parameter-regs)] [isp 8])
(let loop ([types types] [locs '()] [live* '()] [int* (gp-parameter-regs)] [flt* (fp-parameter-regs)] [isp 8]
;; configured for `ftd-fp&` unpacking of floats:
[fp-disp (constant flonum-data-disp)] [single? #f])
(if (null? types)
(values isp locs live*)
(nanopass-case (Ltype Type) (car types)
@ -2197,38 +2244,91 @@
(if (null? int*)
(let ([isp (align 8 isp)])
(loop (cdr types)
(cons (load-double-stack isp) locs)
live* '() flt* (fx+ isp 8)))
(cons (load-double-stack isp fp-disp) locs)
live* '() flt* (fx+ isp 8)
(constant flonum-data-disp) #f))
(loop (cdr types)
(cons (load-soft-double-reg (cadr int*) (car int*)) locs)
(cons* (car int*) (cadr int*) live*) (cddr int*) flt* isp)))
(cons (load-soft-double-reg (cadr int*) (car int*) fp-disp) locs)
(cons* (car int*) (cadr int*) live*) (cddr int*) flt* isp
(constant flonum-data-disp) #f)))
(if (null? flt*)
(let ([isp (align 8 isp)])
(loop (cdr types)
(cons (load-double-stack isp) locs)
live* int* '() (fx+ isp 8)))
(cons (load-double-stack isp fp-disp) locs)
live* int* '() (fx+ isp 8)
(constant flonum-data-disp) #f))
(loop (cdr types)
(cons (load-double-reg (car flt*)) locs)
live* int* (cdr flt*) isp)))]
(cons (load-double-reg (car flt*) fp-disp) locs)
live* int* (cdr flt*) isp
(constant flonum-data-disp) #f)))]
[(fp-single-float)
(if (constant software-floating-point)
(if (null? int*)
; NB: ABI says singles are passed as doubles on the stack, but gcc/linux doesn't
(loop (cdr types)
(cons (load-single-stack isp) locs)
live* '() flt* (fx+ isp 4))
(cons (load-single-stack isp fp-disp single?) locs)
live* '() flt* (fx+ isp 4)
(constant flonum-data-disp) #f)
(loop (cdr types)
(cons (load-soft-single-reg (car int*)) locs)
(cons (car int*) live*) (cdr int*) flt* isp))
(cons (load-soft-single-reg (car int*) fp-disp single?) locs)
(cons (car int*) live*) (cdr int*) flt* isp
(constant flonum-data-disp) #f))
(if (null? flt*)
; NB: ABI says singles are passed as doubles on the stack, but gcc/linux doesn't
(let ([isp (align 4 isp)])
(loop (cdr types)
(cons (load-single-stack isp) locs)
live* int* '() (fx+ isp 4)))
(cons (load-single-stack isp fp-disp single?) locs)
live* int* '() (fx+ isp 4)
(constant flonum-data-disp) #f))
(loop (cdr types)
(cons (load-single-reg (car flt*)) locs)
live* int* (cdr flt*) isp)))]
(cons (load-single-reg (car flt*) fp-disp single?) locs)
live* int* (cdr flt*) isp
(constant flonum-data-disp) #f)))]
[(fp-ftd& ,ftd)
(cond
[($ftd-compound? ftd)
;; pass as pointer
(let ([pointer-type (with-output-language (Ltype Type) `(fp-integer 32))])
(loop (cons pointer-type (cdr types)) locs live* int* flt* isp
(constant flonum-data-disp) #f))]
[else
;; extract content and pass that content
(let ([category ($ftd-atomic-category ftd)])
(cond
[(eq? category 'float)
;; piggy-back on unboxed handler
(let ([unpacked-type (with-output-language (Ltype Type)
(case ($ftd-size ftd)
[(4) `(fp-single-float)]
[else `(fp-double-float)]))])
(loop (cons unpacked-type (cdr types)) locs live* int* flt* isp
;; no floating displacement within pointer:
0
;; in case of float, load as single-float:
(= ($ftd-size ftd) 4)))]
[(and (memq category '(integer unsigned))
(fx= 8 ($ftd-size ftd)))
(let ([int* (if (even? (length int*)) int* (cdr int*))])
(if (null? int*)
(let ([isp (align 8 isp)])
(loop (cdr types)
(cons (load-indirect-int64-stack isp) locs)
live* '() flt* (fx+ isp 8)
(constant flonum-data-disp) #f))
(loop (cdr types)
(cons (load-indirect-int64-reg (cadr int*) (car int*)) locs)
(cons* (car int*) (cadr int*) live*) (cddr int*) flt* isp
(constant flonum-data-disp) #f)))]
[else
(if (null? int*)
(loop (cdr types)
(cons (load-indirect-int-stack isp ($ftd-size ftd)) locs)
live* '() flt* (fx+ isp 4)
(constant flonum-data-disp) #f)
(loop (cdr types)
(cons (load-indirect-int-reg (car int*) ($ftd-size ftd) category) locs)
(cons (car int*) live*) (cdr int*) flt* isp
(constant flonum-data-disp) #f))]))])]
[else
(if (nanopass-case (Ltype Type) (car types)
[(fp-integer ,bits) (fx= bits 64)]
@ -2239,28 +2339,59 @@
(let ([isp (align 8 isp)])
(loop (cdr types)
(cons (load-int64-stack isp) locs)
live* '() flt* (fx+ isp 8)))
live* '() flt* (fx+ isp 8)
(constant flonum-data-disp) #f))
(loop (cdr types)
(cons (load-int64-reg (cadr int*) (car int*)) locs)
(cons* (car int*) (cadr int*) live*) (cddr int*) flt* isp)))
(cons* (car int*) (cadr int*) live*) (cddr int*) flt* isp
(constant flonum-data-disp) #f)))
(if (null? int*)
(loop (cdr types)
(cons (load-int-stack isp) locs)
live* '() flt* (fx+ isp 4))
live* '() flt* (fx+ isp 4)
(constant flonum-data-disp) #f)
(loop (cdr types)
(cons (load-int-reg (car int*)) locs)
(cons (car int*) live*) (cdr int*) flt* isp)))])))))
(cons (car int*) live*) (cdr int*) flt* isp
(constant flonum-data-disp) #f)))])))))
(define do-indirect-result-from-registers
(lambda (ftd offset)
(let ([tmp %Carg8])
(%seq
(set! ,tmp ,(%mref ,%sp ,offset))
,(cond
[(and (not (constant software-floating-point))
(eq? 'float ($ftd-atomic-category ftd)))
`(inline ,(make-info-loadfl %Cfpretval) ,(if (= 4 ($ftd-size ftd)) %store-single %store-double)
,tmp ,%zero (immediate 0))]
[else
(case ($ftd-size ftd)
[(1) `(inline ,(make-info-load 'integer-8 #f) ,%store ,tmp ,%zero (immediate 0) ,%Cretval)]
[(2) `(inline ,(make-info-load 'integer-16 #f) ,%store ,tmp ,%zero (immediate 0) ,%Cretval)]
[(4) `(inline ,(make-info-load 'integer-32 #f) ,%store ,tmp ,%zero (immediate 0) ,%Cretval)]
[(8)
(%seq
(inline ,(make-info-load 'integer-32 #f) ,%store ,tmp ,%zero (immediate 0) ,%Cretval-high)
(inline ,(make-info-load 'integer-32 #f) ,%store ,tmp ,%zero (immediate 4) ,%Cretval-low))]
[else (sorry! who "unexpected result size")])])))))
(lambda (info)
(safe-assert (reg-callee-save? %tc)) ; no need to save-restore
(let ([arg-type* (info-foreign-arg-type* info)]
[result-type (info-foreign-result-type info)])
(with-values (do-args arg-type*)
(lambda (frame-size locs live*)
(let* ([arg-type* (info-foreign-arg-type* info)]
[result-type (info-foreign-result-type info)]
[fill-result-here? (indirect-result-that-fits-in-registers? result-type)])
(with-values (do-args (if fill-result-here? (cdr arg-type*) arg-type*))
(lambda (orig-frame-size locs live*)
;; NB: add 4 to frame size for CR save word
(let ([frame-size (align 16 (fx+ frame-size 4))])
(let ([fill-stash-offset orig-frame-size]
[frame-size (align 16 (fx+ orig-frame-size 4 (if fill-result-here? 4 0)))])
(values
(lambda () (%inline store-with-update ,%Csp ,%Csp (immediate ,(fx- frame-size))))
(reverse locs)
(let ([locs (reverse locs)])
(cond
[fill-result-here?
;; stash extra argument on the stack to be retrieved after call and filled with the result:
(cons (load-int-stack fill-stash-offset) locs)]
[else locs]))
(lambda (t0)
(if (constant software-floating-point)
(let ()
@ -2276,11 +2407,21 @@
[(8 16 32) (handle-32-bit)]
[(64) (handle-64-bit)]
[else (sorry! who "unexpected asm-foriegn-procedures fp-integer size ~s" bits)])))
(define (handle-ftd&-case ftd)
(cond
[fill-result-here?
(%seq
,(if (> ($ftd-size ftd) 4)
(handle-64-bit)
(handle-32-bit))
,(do-indirect-result-from-registers ftd fill-stash-offset))]
[else `(inline ,(make-info-kill*-live* (reg-list) live*) ,%c-call ,t0)]))
(nanopass-case (Ltype Type) result-type
[(fp-double-float) (handle-64-bit)]
[(fp-single-float) (handle-32-bit)]
[(fp-integer ,bits) (handle-integer-cases bits)]
[(fp-integer ,bits) (handle-integer-cases bits)]
[(fp-ftd& ,ftd) (handle-ftd&-case ftd)]
[else `(inline ,(make-info-kill*-live* (reg-list %Cretval) live*) ,%c-call ,t0)]))
(let ()
(define handle-integer-cases
@ -2288,12 +2429,22 @@
(case bits
[(8 16 32) `(inline ,(make-info-kill*-live* (reg-list %Cretval) live*) ,%c-call ,t0)]
[(64) `(inline ,(make-info-kill*-live* (reg-list %Cretval-high %Cretval-low) live*) ,%c-call ,t0)]
[else (sorry! who "unexpected asm-foreign-procedures fp-integer size ~s" bits)])))
[else (sorry! who "unexpected asm-foreign-procedures fp-integer size ~s" bits)])))
(define (handle-ftd&-case ftd)
(cond
[fill-result-here?
(%seq
,(if (not (eq? 'float ($ftd-atomic-category ftd)))
(handle-integer-cases (* 8 ($ftd-size ftd)))
`(inline ,(make-info-kill*-live* (reg-list) live*) ,%c-call ,t0))
,(do-indirect-result-from-registers ftd fill-stash-offset))]
[else `(inline ,(make-info-kill*-live* (reg-list) live*) ,%c-call ,t0)]))
(nanopass-case (Ltype Type) result-type
[(fp-double-float) `(inline ,(make-info-kill*-live* (reg-list) live*) ,%c-call ,t0)]
[(fp-single-float) `(inline ,(make-info-kill*-live* (reg-list) live*) ,%c-call ,t0)]
[(fp-integer ,bits) (handle-integer-cases bits)]
[(fp-unsigned ,bits) (handle-integer-cases bits)]
[(fp-ftd& ,ftd) (handle-ftd&-case ftd)]
[else `(inline ,(make-info-kill*-live* (reg-list %Cretval) live*) ,%c-call ,t0)]))))
(nanopass-case (Ltype Type) result-type
[(fp-double-float)
@ -2396,40 +2547,36 @@
+---------------------------+
| |
| lr | 1 word
sp+184: | |
sp+X+4: | |
+---------------------------+
| |
| back chain | 1 word
sp+180: | |
sp+X: | |
+---------------------------+
+---------------------------+ <- 16-byte aligned
| |
| &-return space | 2 words, if needed
| |
+---------------------------+ <- 8-byte aligned
| |
| callee-save regs |
| |
+---------------------------+
| |
| floating-point regs | 0 words
sp+180: | |
+---------------------------+
| floating-point arg regs |
| |
| integer regs | 18 words
sp+108: | |
+---------------------------+
+---------------------------+ <- 8-byte aligned
| |
| control register | 1 word
sp+104: | |
+---------------------------+
| integer argument regs |
| |
| local variable space | 24 words: 8 words for gp arg regs, 8 double words for fp arg regs, 0 for padding
sp+8: | (and padding) |
+---------------------------+
| |
| parameter list | 0 words
sp+8: | |
+---------------------------+
sp+8: +---------------------------+ <-- 8-byte aligned
| |
| lr | 1 word (place for get-thread-context to store lr)
sp+4: | |
| |
+---------------------------+
| |
| back chain | 1 word
sp+0: | [sp+176] |
sp+0: | [sp+X-4] |
+---------------------------+
FOR foreign callable (nb: assuming flreg1 & flreg2 are caller-save):
@ -2438,14 +2585,14 @@
save fp arg regs (based on number declared by foreign-callable form) at sp+40
don't bother saving cr
save callee-save gp registers at sp+108 (could avoid those we don't use during argument conversion, if we knew what they were)
save lr at sp[180] (actually sp 4, before sp is moved)
save lr at sp[188] (actually sp 4, before sp is moved)
if threaded:
call get-thread-context
else
tc <- thread-context
endif
...
restore lr from sp[180]
restore lr from sp[188]
INVARIANTS
stack grows down
@ -2488,9 +2635,22 @@
(%seq
(set! ,lolvalue ,(%mref ,%sp ,(fx+ offset 4)))
(set! ,hilvalue ,(%mref ,%sp ,offset))))))
(define load-stack-address
(lambda (offset)
(lambda (lvalue)
`(set! ,lvalue ,(%inline + ,%sp (immediate ,offset))))))
(define load-stack-address/convert-float
(lambda (offset)
(lambda (lvalue)
(%seq
;; Overwrite argument on stack with single-precision version
;; FIXME: is the callee allowed to do this if the argument is passed on the stack?
(inline ,(make-info-loadfl %flreg1) ,%load-double->single ,%sp ,%zero (immediate ,offset))
(inline ,(make-info-loadfl %flreg1) ,%store-single ,%sp ,%zero (immediate ,offset))
(set! ,lvalue ,(%inline + ,%sp (immediate ,offset)))))))
(define count-reg-args
(lambda (types gp-reg-count fp-reg-count)
(let f ([types types] [iint 0] [iflt 0])
(lambda (types gp-reg-count fp-reg-count synthesize-first-argument?)
(let f ([types types] [iint (if synthesize-first-argument? -1 0)] [iflt 0])
(if (null? types)
(values iint iflt)
(cond
@ -2498,11 +2658,14 @@
(nanopass-case (Ltype Type) (car types)
[(fp-double-float) #t]
[(fp-single-float) #t]
[(fp-ftd& ,ftd) (eq? 'float ($ftd-atomic-category ftd))]
[else #f]))
(f (cdr types) iint (if (fx< iflt fp-reg-count) (fx+ iflt 1) iflt))]
[(or (nanopass-case (Ltype Type) (car types)
[(fp-integer ,bits) (fx= bits 64)]
[(fp-unsigned ,bits) (fx= bits 64)]
[(fp-ftd& ,ftd) (and (not ($ftd-compound? ftd))
(fx= 8 ($ftd-size ftd)))]
[else #f])
(and (constant software-floating-point)
(nanopass-case (Ltype Type) (car types)
@ -2515,8 +2678,9 @@
; all of the args are on the stack at this point, though not contiguous since
; we push all of the int reg args with one push instruction and all of the
; float reg args with another (v)push instruction
(lambda (types gp-reg-count fp-reg-count int-reg-offset float-reg-offset stack-arg-offset)
(let loop ([types types]
(lambda (types gp-reg-count fp-reg-count int-reg-offset float-reg-offset stack-arg-offset
synthesize-first-argument? return-space-offset)
(let loop ([types (if synthesize-first-argument? (cdr types) types)]
[locs '()]
[iint 0]
[iflt 0]
@ -2524,7 +2688,11 @@
[float-reg-offset float-reg-offset]
[stack-arg-offset stack-arg-offset])
(if (null? types)
(reverse locs)
(let ([locs (reverse locs)])
(if synthesize-first-argument?
(cons (load-stack-address return-space-offset)
locs)
locs))
(cond
[(and (not (constant software-floating-point))
(nanopass-case (Ltype Type) (car types)
@ -2564,7 +2732,49 @@
(loop (cdr types)
(cons (load-soft-single-stack stack-arg-offset) locs)
iint iflt int-reg-offset float-reg-offset (fx+ stack-arg-offset 4)))]
[(nanopass-case (Ltype Type) (car types)
[(nanopass-case (Ltype Type) (car types)
[(fp-ftd& ,ftd) (not ($ftd-compound? ftd))]
[else #f])
;; load pointer to address on the stack
(let ([ftd (nanopass-case (Ltype Type) (car types)
[(fp-ftd& ,ftd) ftd])])
(case (and (not (constant software-floating-point))
($ftd-atomic-category ftd))
[(float)
(let ([load-address (case ($ftd-size ftd)
[(4) load-stack-address/convert-float]
[else load-stack-address])])
(if (fx< iflt fp-reg-count)
(loop (cdr types)
(cons (load-address float-reg-offset) locs)
iint (fx+ iflt 1) int-reg-offset (fx+ float-reg-offset 8) stack-arg-offset)
(let ([stack-arg-offset (align 8 stack-arg-offset)])
(loop (cdr types)
(cons (load-address stack-arg-offset) locs)
iint iflt int-reg-offset float-reg-offset (fx+ stack-arg-offset 8)))))]
[else
(case ($ftd-size ftd)
[(8)
(let ([iint (align 2 iint)])
(if (fx< iint gp-reg-count)
(let ([int-reg-offset (align 8 int-reg-offset)])
(loop (cdr types)
(cons (load-stack-address int-reg-offset) locs)
(fx+ iint 2) iflt (fx+ int-reg-offset 8) float-reg-offset stack-arg-offset))
(let ([stack-arg-offset (align 8 stack-arg-offset)])
(loop (cdr types)
(cons (load-stack-address stack-arg-offset) locs)
iint iflt int-reg-offset float-reg-offset (fx+ stack-arg-offset 8)))))]
[else
(let ([byte-offset (- 4 ($ftd-size ftd))])
(if (fx< iint gp-reg-count)
(loop (cdr types)
(cons (load-stack-address (+ int-reg-offset byte-offset)) locs)
(fx+ iint 1) iflt (fx+ int-reg-offset 4) float-reg-offset stack-arg-offset)
(loop (cdr types)
(cons (load-stack-address (+ stack-arg-offset byte-offset)) locs)
iint iflt int-reg-offset float-reg-offset (fx+ stack-arg-offset 4))))])]))]
[(nanopass-case (Ltype Type) (car types)
[(fp-integer ,bits) (fx= bits 64)]
[(fp-unsigned ,bits) (fx= bits 64)]
[else #f])
@ -2616,48 +2826,114 @@
(if (null? regs)
inline
(%seq ,inline ,(f regs (fx+ offset 4))))))))))
(define do-result
(lambda (result-type return-space-offset int-reg-offset)
(nanopass-case (Ltype Type) result-type
[(fp-ftd& ,ftd)
(case ($ftd-atomic-category ftd)
[(float)
(values
(lambda ()
(case ($ftd-size ftd)
[(4) `(inline ,(make-info-loadfl %Cfpretval) ,%load-single ,%sp ,%zero (immediate ,return-space-offset))]
[else `(inline ,(make-info-loadfl %Cfpretval) ,%load-double ,%sp ,%zero (immediate ,return-space-offset))]))
'())]
[else
(cond
[($ftd-compound? ftd)
;; return pointer
(values
(lambda () `(set! ,%Cretval ,(%mref ,%sp ,int-reg-offset)))
(list %Cretval))]
[(fx= 8 ($ftd-size ftd))
(values (lambda ()
(%seq
(set! ,%Cretval-high ,(%mref ,%sp ,return-space-offset))
(set! ,%Cretval-low ,(%mref ,%sp ,(fx+ return-space-offset 4)))))
(list %Cretval-high %Cretval-low))]
[else
(values
(lambda ()
(case ($ftd-size ftd)
[(1) `(set! ,%Cretval (inline ,(make-info-load 'integer-8 #f) ,%load ,%sp ,%zero (immediate ,return-space-offset)))]
[(2) `(set! ,%Cretval (inline ,(make-info-load 'integer-16 #f) ,%load ,%sp ,%zero (immediate ,return-space-offset)))]
[else `(set! ,%Cretval ,(%mref ,%sp ,return-space-offset))]))
(list %Cretval))])])]
[(fp-double-float)
(values (lambda (x)
`(inline ,(make-info-loadfl %Cfpretval) ,%load-double ,x ,%zero ,(%constant flonum-data-disp)))
'())]
[(fp-single-float)
(values (lambda (x)
`(inline ,(make-info-loadfl %Cfpretval) ,%load-double->single ,x ,%zero ,(%constant flonum-data-disp)))
'())]
[(fp-void)
(values (lambda () `(nop))
'())]
[else
(cond
[(nanopass-case (Ltype Type) result-type
[(fp-integer ,bits) (fx= bits 64)]
[(fp-unsigned ,bits) (fx= bits 64)]
[else #f])
(values (lambda (lo-rhs hi-rhs)
(%seq
(set! ,%Cretval-low ,lo-rhs)
(set! ,%Cretval-high ,hi-rhs)))
(list %Cretval-high %Cretval-low))]
[else
(values (lambda (rhs)
`(set! ,%Cretval ,rhs))
(list %Cretval))])])))
(lambda (info)
(define callee-save-regs (list %r14 %r15 %r16 %r17 %r18 %r19 %r20 %r21 %r22 %r23 %r24 %r25 %r26 %r27 %r28 %r29 %r30 %r31))
(define isaved (length callee-save-regs))
(let ([arg-type* (info-foreign-arg-type* info)]
[result-type (info-foreign-result-type info)]
[gp-reg-count (length (gp-parameter-regs))]
[fp-reg-count (length (fp-parameter-regs))])
(let-values ([(iint iflt) (count-reg-args arg-type* gp-reg-count fp-reg-count)])
(let-values ([(iint iflt) (count-reg-args arg-type* gp-reg-count fp-reg-count (indirect-result-that-fits-in-registers? result-type))])
(let* ([int-reg-offset 8] ; initial offset for calling conventions
[float-reg-offset (fx+ (fx* gp-reg-count 4) int-reg-offset)]
[float-reg-offset (align 8 (fx+ (fx* gp-reg-count 4) int-reg-offset))]
[callee-save-offset (if (constant software-floating-point)
float-reg-offset
(fx+ (fx* fp-reg-count 8) float-reg-offset))]
[stack-size (align 16 (fx+ (fx* isaved 4) callee-save-offset))]
[synthesize-first-argument? (indirect-result-that-fits-in-registers? result-type)]
[return-space-offset (align 8 (fx+ (fx* isaved 4) callee-save-offset))]
[stack-size (align 16 (if synthesize-first-argument?
(fx+ return-space-offset 8)
return-space-offset))]
[stack-arg-offset (fx+ stack-size 8)])
(values
(lambda ()
(%seq
,(%inline save-lr (immediate 4))
,(%inline store-with-update ,%Csp ,%Csp (immediate ,(fx- stack-size)))
,(save-regs (list-head (gp-parameter-regs) iint) int-reg-offset)
,(save-fp-regs (list-head (fp-parameter-regs) iflt) float-reg-offset)
; not bothering with callee-save floating point regs right now
; not bothering with cr, because we don't update nonvolatile fields
,(save-regs callee-save-regs callee-save-offset)
,(if-feature pthreads
(%seq
(set! ,%Cretval ,(%inline get-tc))
(set! ,%tc ,%Cretval))
`(set! ,%tc (literal ,(make-info-literal #f 'entry (lookup-c-entry thread-context) 0))))))
; list of procedures that marshal arguments from their C stack locations
; to the Scheme argument locations
(do-stack arg-type* gp-reg-count fp-reg-count int-reg-offset float-reg-offset stack-arg-offset)
(lambda (fv* Scall->result-type)
(in-context Tail
(%seq
; restore the lr
(inline ,null-info ,%restore-lr (immediate ,(fx+ stack-size 4)))
; restore the callee save registers
,(restore-regs callee-save-regs callee-save-offset)
; deallocate space for pad & arg reg values
(set! ,%Csp ,(%inline + ,%Csp (immediate ,stack-size)))
; tail call the C helper that calls the Scheme procedure
(jump (literal ,(make-info-literal #f 'entry Scall->result-type 0))
(,callee-save-regs ... ,fv* ...))))))))))))))
(let-values ([(get-result result-regs) (do-result result-type return-space-offset int-reg-offset)])
(values
(lambda ()
(%seq
,(%inline save-lr (immediate 4))
,(%inline store-with-update ,%Csp ,%Csp (immediate ,(fx- stack-size)))
,(save-regs (list-head (gp-parameter-regs) iint) int-reg-offset)
,(save-fp-regs (list-head (fp-parameter-regs) iflt) float-reg-offset)
; not bothering with callee-save floating point regs right now
; not bothering with cr, because we don't update nonvolatile fields
,(save-regs callee-save-regs callee-save-offset)
,(if-feature pthreads
(%seq
(set! ,%Cretval ,(%inline get-tc))
(set! ,%tc ,%Cretval))
`(set! ,%tc (literal ,(make-info-literal #f 'entry (lookup-c-entry thread-context) 0))))))
; list of procedures that marshal arguments from their C stack locations
; to the Scheme argument locations
(do-stack arg-type* gp-reg-count fp-reg-count int-reg-offset float-reg-offset stack-arg-offset
synthesize-first-argument? return-space-offset)
get-result
(lambda ()
(in-context Tail
(%seq
; restore the lr
(inline ,null-info ,%restore-lr (immediate ,(fx+ stack-size 4)))
; restore the callee save registers
,(restore-regs callee-save-regs callee-save-offset)
; deallocate space for pad & arg reg values
(set! ,%Csp ,(%inline + ,%Csp (immediate ,stack-size)))
; done
(asm-c-return ,null-info ,callee-save-regs ... ,result-regs ...))))))))))))))
)

25
s/primdata.ss
View File

@ -329,7 +329,7 @@
(vector [sig [(ptr ...) -> (vector)]] [flags unrestricted alloc ieee r5rs cp02])
(vector-length [sig [(vector) -> (length)]] [flags pure true ieee r5rs mifoldable discard])
(vector-ref [sig [(vector sub-index) -> (ptr)]] [flags ieee r5rs mifoldable discard cp02])
(vector-set! [sig [(vector sub-index ptr) -> (ptr)]] [flags true ieee r5rs])
(vector-set! [sig [(vector sub-index ptr) -> (void)]] [flags true ieee r5rs])
(vector->list [sig [(vector) -> (list)]] [flags alloc ieee r5rs])
(list->vector [sig [(list) -> (vector)]] [flags alloc ieee r5rs])
(vector-fill! [sig [(vector ptr) -> (void)]] [flags true ieee r5rs])
@ -839,9 +839,9 @@
(define-symbol-flags* ([libraries (chezscheme csv7)] [flags primitive proc]) ; csv7 compatibility
((csv7: record-field-accessible?) [sig [(rtd sub-ptr) -> (boolean)]] [flags pure mifoldable discard cp02])
((csv7: record-field-accessor) [sig [(rtd sub-ptr) -> (boolean)]] [flags pure alloc cp02])
((csv7: record-field-accessor) [sig [(rtd sub-ptr) -> (procedure)]] [flags pure alloc cp02])
((csv7: record-field-mutable?) [sig [(rtd sub-ptr) -> (boolean)]] [flags pure mifoldable discard cp02])
((csv7: record-field-mutator) [sig [(rtd sub-ptr) -> (boolean)]] [flags pure alloc cp02])
((csv7: record-field-mutator) [sig [(rtd sub-ptr) -> (procedure)]] [flags pure alloc cp02])
((csv7: record-type-descriptor) [sig [(record) -> (rtd)]] [flags pure mifoldable discard true cp02])
((csv7: record-type-field-decls) [sig [(rtd) -> (list)]] [flags pure mifoldable discard true cp02])
((csv7: record-type-field-names) [sig [(rtd) -> (list)]] [flags pure mifoldable discard true cp02])
@ -917,6 +917,7 @@
(collect-trip-bytes [sig [() -> (ufixnum)] [(ufixnum) -> (void)]] [flags])
(command-line [sig [() -> (list)] [(sub-list) -> (void)]] [flags]) ; not restricted to 1 argument
(command-line-arguments [sig [() -> (list)] [(sub-list) -> (void)]] [flags])
(commonization-level [sig [() -> (ufixnum)] [(sub-ufixnum) -> (void)]] [flags])
(compile-compressed [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted])
(compile-file-message [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted])
(compile-interpret-simple [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted])
@ -943,6 +944,8 @@
(custom-port-buffer-size [sig [() -> (ufixnum)] [(sub-fixnum) -> (void)]] [flags])
(debug-level [sig [() -> (ufixnum)] [(sub-ufixnum) -> (void)]] [flags])
(debug-on-exception [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted])
(default-record-equal-procedure [sig [() -> (maybe-procedure)] [(maybe-procedure) -> (void)]] [flags])
(default-record-hash-procedure [sig [() -> (maybe-procedure)] [(maybe-procedure) -> (void)]] [flags])
(enable-cross-library-optimization [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted])
(enable-object-counts [sig [() -> (boolean)] [(ptr) -> (void)]] [flags])
(eval-syntax-expanders-when [sig [() -> (list)] [(sub-list) -> (void)]] [flags])
@ -1194,6 +1197,7 @@
(clear-input-port [sig [() (input-port) -> (void)]] [flags true])
(clear-output-port [sig [() (output-port) -> (void)]] [flags true])
(collect [sig [() (sub-ufixnum) (sub-ufixnum ptr) -> (void)]] [flags true])
(collect-rendezvous [sig [() -> (void)]] [flags])
(collections [sig [() -> (uint)]] [flags unrestricted alloc])
(compile [sig [(sub-ptr) (sub-ptr environment) -> (ptr ...)]] [flags])
(compile-file [sig [(pathname) (pathname pathname) (pathname pathname sub-symbol) -> (void)]] [flags true])
@ -1520,7 +1524,7 @@
(put-string-some [sig [(textual-output-port string) (textual-output-port string length) (textual-output-port string length length) -> (uint)]] [flags true])
(putprop [sig [(symbol ptr ptr) -> (void)]] [flags true])
(putenv [sig [(string string) -> (void)]] [flags true])
(profile-query-weight [sig [(ptr) -> (maybe-flonum)]] [flags discard true])
(profile-query-weight [sig [(ptr) -> (maybe-flonum)]] [flags unrestricted discard])
(random [sig [(sub-number) -> (number)]] [flags alloc])
(ratnum? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
(read-token [sig [() (textual-input-port) (textual-input-port sfd) -> (symbol ptr maybe-uint maybe-uint)]] [flags])
@ -1761,6 +1765,8 @@
($continuation-winders [flags])
($cp0 [flags])
($cpcheck [flags])
($cpcheck-prelex-flags [flags])
($cpcommonize [flags])
($cpletrec [flags])
($cpvalid [flags])
($c-stlv! [flags])
@ -1773,6 +1779,7 @@
($do-wind [flags])
($dynamic-closure-counts [flags alloc]) ; added for closure instrumentation
($enum-set-members [flags])
($eol-style? [flags])
($eq-hashtable-clear! [flags true])
($eq-hashtable-copy [flags true discard])
($eq-hashtable-entries [flags discard])
@ -1780,6 +1787,7 @@
($eq-hashtable-values [flags true discard])
($errno [flags])
($errno->string [flags])
($error-handling-mode? [flags])
($event [flags])
($exactnum? [flags])
($exactnum-imag-part [flags])
@ -1967,6 +1975,12 @@
($fptr-unlock! [flags])
($fp-type->pred [flags])
($ftd? [flags])
($ftd-alignment [flags])
($ftd-as-box? [flags])
($ftd-atomic-category [flags])
($ftd-compound? [flags])
($ftd-size [flags])
($ftd->members [flags])
($ftype-pointer? [flags])
($fxaddress [flags unrestricted alloc])
($fx-? [flags])
@ -2240,6 +2254,7 @@
($cp0-polyvariant #;[sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted])
($current-mso [flags])
($enable-check-heap [flags])
($enable-check-prelex-flags [flags])
($enable-expeditor [feature expeditor] [flags])
($enable-pass-timing [flags])
($expeditor-history-file [feature expeditor] [flags])
@ -2259,9 +2274,7 @@
($console-error-port [flags])
($console-input-port [flags])
($console-output-port [flags])
($eol-style? [flags])
($eq-ht-rtd [flags])
($error-handling-mode? [flags])
($heap-reserve-ratio [flags])
($interrupt [flags])
($nuate [flags])

2
s/prims.ss
View File

@ -1647,6 +1647,8 @@
(define-tc-parameter optimize-level (lambda (x) (and (fixnum? x) (fx<= 0 x 3))) "valid optimize level" 0)
(define-tc-parameter $compile-profile (lambda (x) (memq x '(#f source block))) "valid compile-profile flag" #f)
(define-tc-parameter subset-mode (lambda (mode) (memq mode '(#f system))) "valid subset mode" #f)
(define-tc-parameter default-record-equal-procedure (lambda (x) (or (eq? x #f) (procedure? x))) "a procedure or #f" #f)
(define-tc-parameter default-record-hash-procedure (lambda (x) (or (eq? x #f) (procedure? x))) "a procedure or #f" #f)
)
(define-who compile-profile

218
s/syntax.ss
View File

@ -582,9 +582,9 @@
(define build-lexical-reference
(lambda (ae prelex)
(when (prelex-referenced prelex)
(set-prelex-multiply-referenced! prelex #t))
(set-prelex-referenced! prelex #t)
(if (prelex-referenced prelex)
(set-prelex-multiply-referenced! prelex #t)
(set-prelex-referenced! prelex #t))
(build-profile ae `(ref ,(ae->src ae) ,prelex))))
(define build-lexical-assignment
@ -679,7 +679,11 @@
[(integer-40 integer-48 integer-56 integer-64) `(fp-integer 64)]
[(unsigned-40 unsigned-48 unsigned-56 unsigned-64) `(fp-unsigned 64)]
[(void) (and void-okay? `(fp-void))]
[else (and ($ftd? x) `(fp-ftd ,x))])
[else
(cond
[($ftd? x) `(fp-ftd ,x)]
[($ftd-as-box? x) `(fp-ftd& ,(unbox x))]
[else #f])])
($oops #f "invalid ~a ~a specifier ~s" who what x)))))
(define build-foreign-procedure
@ -824,9 +828,10 @@
,(build-sequence no-source init*)))))
(define build-top-library/ct
(lambda (uid import-code* visit-code*)
(lambda (uid export-id* import-code* visit-code*)
(with-output-language (Lexpand ctLibrary)
`(library/ct ,uid
(,export-id* ...)
,(build-lambda no-source '()
(build-sequence no-source import-code*))
,(if (null? visit-code*)
@ -2353,9 +2358,10 @@
(mutable clo*) ; cross-library optimization information
(mutable loaded-import-reqs)
(mutable loaded-visit-reqs)
(mutable export-id*) ; ids that need to be reset when visit-code raises an exception
(mutable import-code)
(mutable visit-code))
(nongenerative #{ctdesc bthma8spr7lds76z4hlmr9-1})
(nongenerative #{ctdesc bthma8spr7lds76z4hlmr9-2})
(sealed #t))
(define-record-type rtdesc
@ -2371,6 +2377,7 @@
libdesc-loaded-visit-reqs libdesc-loaded-visit-reqs-set!
libdesc-import-code libdesc-import-code-set!
libdesc-visit-code libdesc-visit-code-set!
libdesc-visit-id* libdesc-visit-id*-set!
libdesc-clo* libdesc-clo*-set!)
(define get-ctdesc
(lambda (desc)
@ -2412,6 +2419,12 @@
(define libdesc-visit-code-set!
(lambda (desc x)
(ctdesc-visit-code-set! (get-ctdesc desc) x)))
(define libdesc-visit-id*
(lambda (desc)
(ctdesc-export-id* (get-ctdesc desc))))
(define libdesc-visit-id*-set!
(lambda (desc x)
(ctdesc-export-id*-set! (get-ctdesc desc) x)))
(define libdesc-clo*
(lambda (desc)
(ctdesc-clo* (get-ctdesc desc))))
@ -2456,10 +2469,15 @@
(when (eq? p 'pending)
($oops #f "cyclic dependency involving visit of library ~s" (libdesc-path desc)))
(libdesc-visit-code-set! desc 'pending)
(for-each (lambda (req) (visit-library (libreq-uid req))) (libdesc-visit-visit-req* desc))
(for-each (lambda (req) (invoke-library (libreq-uid req))) (libdesc-visit-req* desc))
(p)
(libdesc-visit-code-set! desc #f))]))]
(on-reset
(begin
(for-each (lambda (id) ($sc-put-cte id (make-binding 'visit uid) #f)) (libdesc-visit-id* desc))
(libdesc-visit-code-set! desc p))
(for-each (lambda (req) (visit-library (libreq-uid req))) (libdesc-visit-visit-req* desc))
(for-each (lambda (req) (invoke-library (libreq-uid req))) (libdesc-visit-req* desc))
(p))
(libdesc-visit-code-set! desc #f)
(libdesc-visit-id*-set! desc '()))]))]
[else ($oops #f "library ~:s is not defined" uid)])))
(define invoke-library
@ -2476,8 +2494,9 @@
(when (eq? p 'pending)
($oops #f "cyclic dependency involving invocation of library ~s" (libdesc-path desc)))
(libdesc-invoke-code-set! desc 'pending)
(for-each (lambda (req) (invoke-library (libreq-uid req))) (libdesc-invoke-req* desc))
(p)
(on-reset (libdesc-invoke-code-set! desc p)
(for-each (lambda (req) (invoke-library (libreq-uid req))) (libdesc-invoke-req* desc))
(p))
(libdesc-invoke-code-set! desc #f))]))]
[else ($oops #f "library ~:s is not defined" uid)])))
@ -2521,8 +2540,9 @@
(when (eq? p 'pending)
($oops #f "cyclic dependency involving invocation of library ~s" (libdesc-path desc)))
(libdesc-invoke-code-set! desc 'pending)
(for-each (lambda (req) (invoke-library (libreq-uid req))) (libdesc-invoke-req* desc))
(p)
(on-reset (libdesc-invoke-code-set! desc p)
(for-each (lambda (req) (invoke-library (libreq-uid req))) (libdesc-invoke-req* desc))
(p))
(libdesc-invoke-code-set! desc #f))]))
(unless (memp (lambda (x) (eq? (libreq-uid x) uid)) req*)
(set! req* (cons (make-libreq (libdesc-path desc) (libdesc-version desc) uid) req*))))]
@ -2622,7 +2642,7 @@
(install-library library-path library-uid
; import-code & visit-code is #f because vthunk invocation has already set up compile-time environment
(make-libdesc library-path library-version outfn #f
(make-ctdesc include-req* import-req* visit-visit-req* visit-req* '() #t #t #f #f)
(make-ctdesc include-req* import-req* visit-visit-req* visit-req* '() #t #t '() #f #f)
(make-rtdesc invoke-req* #t
(top-level-eval-hook
(build-lambda no-source '()
@ -2662,6 +2682,13 @@
build-void
(lambda ()
(build-top-library/ct library-uid
; visit-time exports (making them available for reset on visit-code failure)
(fold-left (lambda (ls x)
(let ([label (car x)] [exp (cdr x)])
(if (and (pair? exp) (eq? (car exp) 'visit))
(cons label ls)
ls)))
'() env*)
; setup code
`(,(build-cte-install bound-id (build-data no-source interface-binding) '*system*)
,@(if (null? env*)
@ -4276,14 +4303,18 @@
(append #'(old-id ...) exports)
(append #'(old-id ...) exports-to-check)
(fold-right resolve&add-id new-exports #'(old-id ...) #'(new-id ...)))]
[(?import impspec)
[(?import impspec ...)
(sym-kwd? ?import import)
(let-values ([(mid tid imps) (help-determine-imports #'impspec r #f)])
(let ([imps (if (import-interface? imps) (module-exports imps) imps)])
(values
(append (map car imps) exports)
exports-to-check
(fold-right add-id new-exports (map cdr imps)))))]
(let process-impspecs ([impspec* #'(impspec ...)])
(if (null? impspec*)
(values exports exports-to-check new-exports)
(let-values ([(_mid _tid imps) (help-determine-imports (car impspec*) r #f)]
[(exports exports-to-check new-exports) (process-impspecs (cdr impspec*))])
(let ([imps (if (import-interface? imps) (module-exports imps) imps)])
(values
(append (map car imps) exports)
exports-to-check
(fold-right add-id new-exports (map cdr imps)))))))]
[_ (syntax-error x "invalid export spec")])))))])
(g (cdr expspec**) exports exports-to-check new-exports))))))
)
@ -4624,11 +4655,12 @@
(when desc (put-library-descriptor uid desc)))))
(define-who install-library/ct-code
(lambda (uid import-code visit-code)
(lambda (uid export-id* import-code visit-code)
(let ([desc (get-library-descriptor uid)])
(unless desc (sorry! who "unable to install visit code for non-existent library ~s" uid))
(let ([ctdesc (libdesc-ctdesc desc)])
(unless ctdesc (sorry! who "unable to install visit code for revisit-only library ~s" uid))
(ctdesc-export-id*-set! ctdesc export-id*)
(ctdesc-import-code-set! ctdesc import-code)
(ctdesc-visit-code-set! ctdesc visit-code)))))
@ -5069,7 +5101,8 @@
[(#t) (void)]
[(#f)
(libdesc-loaded-invoke-reqs-set! desc 'pending)
(for-each (make-load-req load-invoke-library path) (libdesc-invoke-req* desc))
(on-reset (libdesc-loaded-invoke-reqs-set! desc #f)
(for-each (make-load-req load-invoke-library path) (libdesc-invoke-req* desc)))
(libdesc-loaded-invoke-reqs-set! desc #t)]
[(pending) ($oops #f "cyclic dependency involving invocation of library ~s" (libdesc-path desc))]))))))
(define load-visit-library
@ -5083,8 +5116,9 @@
[(#t) (void)]
[(#f)
(libdesc-loaded-visit-reqs-set! desc 'pending)
(for-each (make-load-req load-visit-library path) (libdesc-visit-visit-req* desc))
(for-each (make-load-req load-invoke-library path) (libdesc-visit-req* desc))
(on-reset (libdesc-loaded-visit-reqs-set! desc #f)
(for-each (make-load-req load-visit-library path) (libdesc-visit-visit-req* desc))
(for-each (make-load-req load-invoke-library path) (libdesc-visit-req* desc)))
(libdesc-loaded-visit-reqs-set! desc #t)]
[(pending) ($oops #f "cyclic dependency involving visit of library ~s" (libdesc-path desc))]))))))
(define load-import-library
@ -5098,7 +5132,8 @@
[(#t) (void)]
[(#f)
(libdesc-loaded-import-reqs-set! desc 'pending)
(for-each (make-load-req load-import-library path) (libdesc-import-req* desc))
(on-reset (libdesc-loaded-import-reqs-set! desc #f)
(for-each (make-load-req load-import-library path) (libdesc-import-req* desc)))
(libdesc-loaded-import-reqs-set! desc #t)]
[(pending) ($oops #f "cyclic dependency involving import of library ~s" (libdesc-path desc))]))))))
(define import-library
@ -5253,9 +5288,10 @@
(build-lambda no-source '() body))))
(set-who! $build-install-library/ct-code
(lambda (uid import-code visit-code)
(lambda (uid export-id* import-code visit-code)
(build-primcall no-source 3 '$install-library/ct-code
(build-data no-source uid)
(build-data no-source export-id*)
import-code
visit-code)))
@ -5385,7 +5421,7 @@
(library/ct-info-visit-visit-req* linfo/ct)
(library/ct-info-visit-req* linfo/ct)
(library/ct-info-clo* linfo/ct)
#f #f 'loading 'loading)))))
#f #f '() 'loading 'loading)))))
(set! $install-library/rt-desc
(lambda (linfo/rt for-import? ofn)
@ -5397,8 +5433,8 @@
uid ofn (make-rtdesc (library/rt-info-invoke-req* linfo/rt) #f 'loading)))))
(set! $install-library/ct-code
(lambda (uid import-code visit-code)
(install-library/ct-code uid import-code visit-code)))
(lambda (uid export-id* import-code visit-code)
(install-library/ct-code uid export-id* import-code visit-code)))
(set! $install-library/rt-code
(lambda (uid invoke-code)
@ -5474,7 +5510,7 @@
(lambda (path uid)
(install-library path uid
(make-libdesc path (if (eq? (car path) 'rnrs) '(6) '()) #f #t
(make-ctdesc '() '() '() '() '() #t #t #f #f)
(make-ctdesc '() '() '() '() '() #t #t '() #f #f)
(make-rtdesc '() #t #f)))))
(set! $make-base-modules
(lambda ()
@ -8508,7 +8544,9 @@
(constant-case native-endianness
[(little) 'utf-32le]
[(big) 'utf-32be])])]
[else (and ($ftd? type) type)])))
[else
(and (or ($ftd? type) ($ftd-as-box? type))
type)])))
(define $fp-type->pred
(lambda (type)
@ -8649,10 +8687,11 @@
(err ($moi) x)))))
(u32*))]
[else #f])
(if ($ftd? type)
#`(#,(if unsafe? #'() #`((unless (record? x '#,type) (err ($moi) x))))
(x)
(#,type))
(if (or ($ftd? type) ($ftd-as-box? type))
(let ([ftd (if ($ftd? type) type (unbox type))])
#`(#,(if unsafe? #'() #`((unless (record? x '#,ftd) (err ($moi) x))))
(x)
(#,type)))
(with-syntax ([pred (datum->syntax #'foreign-procedure ($fp-type->pred type))]
[type (datum->syntax #'foreign-procedure type)])
#`(#,(if unsafe? #'() #'((unless (pred x) (err ($moi) x))))
@ -8684,15 +8723,36 @@
[(unsigned-48) #`((lambda (x) (mod x #x1000000000000)) unsigned-64)]
[(integer-56) #`((lambda (x) (mod0 x #x100000000000000)) integer-64)]
[(unsigned-56) #`((lambda (x) (mod x #x100000000000000)) unsigned-64)]
[else #`(values #,(datum->syntax #'foreign-procedure result-type))])])
#`(let ([p ($foreign-procedure conv foreign-name ?foreign-addr (arg ... ...) result)]
[else
(cond
[($ftd-as-box? result-type)
;; Return void, since an extra first argument receives the result,
;; but tell `$foreign-procedure` that the result is actually an & form
#`((lambda (r) (void)) #,(datum->syntax #'foreign-procedure result-type))]
[else
#`(values #,(datum->syntax #'foreign-procedure result-type))])])]
[([extra ...] [extra-arg ...] [extra-check ...])
;; When the result type is `(& <ftype>)`, the `$foreign-procedure` result
;; expects an extra argument as a `(* <ftype>)` that it uses to store the
;; foreign-procedure result, and it returns void. The extra argument is made
;; explicit for `$foreign-procedure`, and the return type is preserved as-is
;; to let `$foreign-procedure` know that it needs to fill the first argument.
(cond
[($ftd-as-box? result-type)
#`([&-result]
[#,(unbox result-type)]
#,(if unsafe?
#`[]
#`[(unless (record? &-result '#,(unbox result-type)) (err ($moi) &-result))]))]
[else #'([] [] [])])])
#`(let ([p ($foreign-procedure conv foreign-name ?foreign-addr (extra-arg ... arg ... ...) result)]
#,@(if unsafe?
#'()
#'([err (lambda (who x)
($oops (or who foreign-name)
"invalid foreign-procedure argument ~s"
x))])))
(lambda (t ...) check ... ... (result-filter (p actual ... ...)))))))))
(lambda (extra ... t ...) extra-check ... check ... ... (result-filter (p extra ... actual ... ...)))))))))
(define-syntax foreign-procedure
(lambda (x)
@ -8810,12 +8870,13 @@
(with-syntax ([(x) (generate-temporaries #'(*))])
#`(x (x) (#,(datum->syntax #'foreign-callable type))))))
type*)]
[(result-filter result)
[(result-filter result [extra-arg ...] [extra ...])
(case result-type
[(boolean) #`((lambda (x) (if x 1 0))
#,(constant-case int-bits
[(32) #'integer-32]
[(64) #'integer-64]))]
[(64) #'integer-64])
[] [])]
[(char)
#`((lambda (x)
#,(if unsafe?
@ -8824,7 +8885,8 @@
(let ([x (char->integer x)])
(and (fx<= x #xff) x)))
(err x))))
unsigned-8)]
unsigned-8
[] [])]
[(wchar)
(constant-case wchar-bits
[(16) #`((lambda (x)
@ -8834,14 +8896,16 @@
(let ([x (char->integer x)])
(and (fx<= x #xffff) x)))
(err x))))
unsigned-16)]
unsigned-16
[] [])]
[(32) #`((lambda (x)
#,(if unsafe?
#'(char->integer x)
#'(if (char? x)
(char->integer x)
(err x))))
unsigned-16)])]
unsigned-16
[] [])])]
[(utf-8)
#`((lambda (x)
(if (eq? x #f)
@ -8851,7 +8915,8 @@
#'(if (string? x)
($fp-string->utf8 x)
(err x)))))
u8*)]
u8*
[] [])]
[(utf-16le)
#`((lambda (x)
(if (eq? x #f)
@ -8861,7 +8926,8 @@
#'(if (string? x)
($fp-string->utf16 x 'little)
(err x)))))
u16*)]
u16*
[] [])]
[(utf-16be)
#`((lambda (x)
(if (eq? x #f)
@ -8871,7 +8937,8 @@
#'(if (string? x)
($fp-string->utf16 x 'big)
(err x)))))
u16*)]
u16*
[] [])]
[(utf-32le)
#`((lambda (x)
(if (eq? x #f)
@ -8881,7 +8948,8 @@
#'(if (string? x)
($fp-string->utf32 x 'little)
(err x)))))
u32*)]
u32*
[] [])]
[(utf-32be)
#`((lambda (x)
(if (eq? x #f)
@ -8891,21 +8959,37 @@
#'(if (string? x)
($fp-string->utf32 x 'big)
(err x)))))
u32*)]
u32*
[] [])]
[else
(if ($ftd? result-type)
(with-syntax ([type (datum->syntax #'foreign-callable result-type)])
#`((lambda (x)
#,@(if unsafe? #'() #'((unless (record? x 'type) (err x))))
x)
type))
(with-syntax ([pred (datum->syntax #'foreign-callable ($fp-type->pred result-type))]
[type (datum->syntax #'foreign-callable result-type)])
#`((lambda (x)
#,@(if unsafe? #'() #'((unless (pred x) (err x))))
x)
type)))])])
; use a gensym to avoid giving the procedure a confusing namej
(cond
[($ftd? result-type)
(with-syntax ([type (datum->syntax #'foreign-callable result-type)])
#`((lambda (x)
#,@(if unsafe? #'() #'((unless (record? x 'type) (err x))))
x)
type
[] []))]
[($ftd-as-box? result-type)
;; callable receives an extra pointer argument to fill with the result;
;; we add this type to `$foreign-callable` as an initial address argument,
;; which may be actually provided by the caller or synthesized by the
;; back end, depending on the type and architecture
(with-syntax ([type (datum->syntax #'foreign-callable result-type)]
[ftd (datum->syntax #'foreign-callable (unbox result-type))])
#`((lambda (x) (void)) ; callable result is ignored
type
[ftd]
[&-result]))]
[else
(with-syntax ([pred (datum->syntax #'foreign-callable ($fp-type->pred result-type))]
[type (datum->syntax #'foreign-callable result-type)])
#`((lambda (x)
#,@(if unsafe? #'() #'((unless (pred x) (err x))))
x)
type
[] []))])])])
; use a gensym to avoid giving the procedure a confusing name
(with-syntax ([p (datum->syntax #'foreign-callable (gensym))])
#`($foreign-callable conv
(let ([p ?proc])
@ -8914,8 +8998,8 @@
"invalid return value ~s from ~s"
x p))
#,@(if unsafe? #'() #'((unless (procedure? p) ($oops 'foreign-callable "~s is not a procedure" p))))
(lambda (t ... ...) (result-filter (p actual ...))))
(arg ... ...)
(lambda (extra ... t ... ...) (result-filter (p extra ... actual ...))))
(extra-arg ... arg ... ...)
result)))))))
(define-syntax foreign-callable
@ -9243,6 +9327,7 @@
(define (parse-field x i)
(syntax-case x (immutable mutable)
[(immutable field-name accessor-name)
(and (identifier? #'field-name) (identifier? #'accessor-name))
(make-field-desc
(datum field-name)
i
@ -9250,6 +9335,7 @@
#'accessor-name
#f)]
[(mutable field-name accessor-name mutator-name)
(and (identifier? #'field-name) (identifier? #'accessor-name) (identifier? #'mutator-name))
(make-field-desc
(datum field-name)
i
@ -9257,10 +9343,12 @@
#'accessor-name
#'mutator-name)]
[(immutable field-name)
(identifier? #'field-name)
(make-field-desc (datum field-name) i x
(construct-name name name "-" #'field-name)
#f)]
[(mutable field-name)
(identifier? #'field-name)
(make-field-desc (datum field-name) i x
(construct-name name name "-" #'field-name)
(construct-name name name "-" #'field-name "-set!"))]

397
s/x86.ss
View File

@ -733,6 +733,15 @@
(define-instruction value (fstpl)
[(op (z mem)) `(set! ,(make-live-info) ,z (asm ,info ,asm-fstpl))])
(define-instruction value (fstps)
[(op (z mem)) `(set! ,(make-live-info) ,z (asm ,info ,asm-fstps))])
(define-instruction effect (fldl)
[(op (z mem)) `(asm ,info ,asm-fldl ,z)])
(define-instruction effect (flds)
[(op (z mem)) `(asm ,info ,asm-flds ,z)])
(define-instruction effect (load-single->double load-double->single)
[(op (x ur) (y ur) (z imm32))
`(asm ,info ,(asm-fl-cvt op (info-loadfl-flreg info)) ,x ,y ,z)])
@ -907,11 +916,11 @@
asm-pop asm-shiftop asm-sll asm-logand asm-lognot
asm-logtest asm-fl-relop asm-relop asm-push asm-indirect-jump asm-literal-jump
asm-direct-jump asm-return-address asm-jump asm-conditional-jump asm-data-label asm-rp-header
asm-lea1 asm-lea2 asm-indirect-call asm-fstpl asm-condition-code
asm-lea1 asm-lea2 asm-indirect-call asm-fstpl asm-fstps asm-fldl asm-flds asm-condition-code
asm-fl-cvt asm-fl-store asm-fl-load asm-flt asm-trunc asm-div
asm-exchange asm-pause asm-locked-incr asm-locked-decr
asm-flop-2 asm-flsqrt asm-c-simple-call
asm-save-flrv asm-restore-flrv asm-return asm-size
asm-save-flrv asm-restore-flrv asm-return asm-c-return asm-size
asm-enter asm-foreign-call asm-foreign-callable
asm-inc-profile-counter
asm-inc-cc-counter asm-read-time-stamp-counter asm-read-performance-monitoring-counter
@ -1039,6 +1048,7 @@
(define-op popf byte-op #b10011101)
(define-op nop byte-op #b10010000)
(define-op ret byte-op #b11000011)
(define-op retl byte+short-op #b11000010)
(define-op sahf byte-op #b10011110)
(define-op extad byte-op #b10011001) ; extend eax to edx
@ -1076,7 +1086,9 @@
; coprocessor ops required to handle calling conventions
(define-op fldl float-op2 #b101 #b000) ; double memory push => ST[0]
(define-op flds float-op2 #b001 #b000) ; single memory push => ST[0]
(define-op fstpl float-op2 #b101 #b011) ; ST[0] => double memory, pop
(define-op fstps float-op2 #b001 #b011) ; ST[0] => single memory, pop
; SSE2 instructions (pulled from x86_64macros.ss)
(define-op sse.addsd sse-op1 #xF2 #x58)
@ -1434,6 +1446,13 @@
(build byte op-code1)
(build byte op-code2))))
(define byte+short-op
(lambda (op op-code1 t code*)
(emit-code (op code*)
(build byte op-code1)
(build byte (fxand (cadr t) #xFF))
(build byte (fxsrl (cadr t) 16)))))
(define byte-reg-op1
(lambda (op op-code1 reg code*)
(begin
@ -1629,6 +1648,21 @@
(Trivit (dest)
(emit fstpl dest code*))))
(define asm-fstps
(lambda (code* dest)
(Trivit (dest)
(emit fstps dest code*))))
(define asm-fldl
(lambda (code* src)
(Trivit (src)
(emit fldl src code*))))
(define asm-flds
(lambda (code* src)
(Trivit (src)
(emit flds src code*))))
(define asm-fl-cvt
(lambda (op flreg)
(lambda (code* base index offset)
@ -1849,6 +1883,14 @@
[(i3osx ti3osx) (emit addi '(imm 12) (cons 'reg %sp) (emit ret '()))]
[else (emit ret '())])))
(define asm-c-return
(lambda (info)
(if (info-c-return? info)
(let ([offset (info-c-return-offset info)])
(safe-assert (<= 0 offset #xFFFF))
(emit retl `(imm ,offset) '()))
(emit ret '()))))
(define asm-locked-incr
(lambda (code* base index offset)
(let ([dest (build-mem-opnd base index offset)])
@ -2220,6 +2262,25 @@
,e))])))]
[else (define asm-enter values)])
(define callee-expects-result-pointer?
(lambda (result-type)
(nanopass-case (Ltype Type) result-type
[(fp-ftd& ,ftd) (constant-case machine-type-name
[(i3osx ti3osx i3nt ti3nt)
(case ($ftd-size ftd)
[(1 2 4 8) #f]
[else #t])]
[else ($ftd-compound? ftd)])]
[else #f])))
(define callee-pops-result-pointer?
(lambda (result-type)
(callee-expects-result-pointer? result-type)))
(define fill-result-pointer-from-registers?
(lambda (result-type)
(nanopass-case (Ltype Type) result-type
[(fp-ftd& ,ftd) (not (callee-expects-result-pointer? result-type))]
[else #f])))
(define asm-foreign-call
(with-output-language (L13 Effect)
(letrec ([load-double-stack
@ -2244,19 +2305,74 @@
(%seq
(set! ,(%mref ,%sp ,offset) ,lorhs)
(set! ,(%mref ,%sp ,(fx+ offset 4)) ,hirhs))))]
[load-content
(lambda (offset len)
(lambda (x) ; requires var
(let loop ([offset offset] [x-offset 0] [len len])
(cond
[(= len 0) `(nop)]
[(>= len 4)
`(seq
(set! ,(%mref ,%sp ,offset) (inline ,(make-info-load 'integer-32 #f)
,%load ,x ,%zero (immediate ,x-offset)))
,(loop (fx+ offset 4) (fx+ x-offset 4) (fx- len 4)))]
[(>= len 2)
(%seq
(set! ,%eax (inline ,(make-info-load 'integer-16 #f)
,%load ,x ,%zero (immediate ,x-offset)))
(inline ,(make-info-load 'integer-16 #f)
,%store ,%sp ,%zero (immediate ,offset)
,%eax)
,(loop (fx+ offset 2) (fx+ x-offset 2) (fx- len 2)))]
[else
(%seq
(set! ,%eax (inline ,(make-info-load 'integer-8 #f)
,%load ,x ,%zero (immediate ,x-offset)))
(inline ,(make-info-load 'integer-8 #f)
,%store ,%sp ,%zero (immediate ,offset)
,%eax))]))))]
[do-stack
(lambda (types locs n)
(lambda (types locs n result-type)
(if (null? types)
(values n locs)
(nanopass-case (Ltype Type) (car types)
[(fp-double-float)
(do-stack (cdr types)
(cons (load-double-stack n) locs)
(fx+ n 8))]
(fx+ n 8)
#f)]
[(fp-single-float)
(do-stack (cdr types)
(cons (load-single-stack n) locs)
(fx+ n 4))]
(fx+ n 4)
#f)]
[(fp-ftd& ,ftd)
(do-stack (cdr types)
(cons (load-content n ($ftd-size ftd)) locs)
(fx+ n (fxlogand (fx+ ($ftd-size ftd) 3) -4))
#f)]
[(fp-ftd ,ftd)
(cond
[(and result-type
(fill-result-pointer-from-registers? result-type))
;; Callee doesn't expect this argument; move
;; it to the end just to save it for filling
;; when the callee returns
(let ([end-n 0])
(with-values (do-stack (cdr types)
(cons (lambda (rhs)
((load-stack end-n) rhs))
locs)
n
#f)
(lambda (frame-size locs)
(set! end-n frame-size)
(values (fx+ frame-size 4) locs))))]
[else
(do-stack (cdr types)
(cons (load-stack n) locs)
(fx+ n 4)
#f)])]
[else
(if (nanopass-case (Ltype Type) (car types)
[(fp-integer ,bits) (fx= bits 64)]
@ -2264,17 +2380,19 @@
[else #f])
(do-stack (cdr types)
(cons (load-stack64 n) locs)
(fx+ n 8))
(fx+ n 8)
#f)
(do-stack (cdr types)
(cons (load-stack n) locs)
(fx+ n 4)))])))])
(fx+ n 4)
#f))])))])
(define returnem
(lambda (conv frame-size locs ccall r-loc)
(lambda (conv orig-frame-size locs result-type ccall r-loc)
(let ([frame-size (constant-case machine-type-name
; maintain 16-byte alignment not including the return address pushed
; by the call instruction, which counts as part of callee's frame
[(i3osx ti3osx) (fxlogand (fx+ frame-size 15) -16)]
[else frame-size])])
[(i3osx ti3osx) (fxlogand (fx+ orig-frame-size 15) -16)]
[else orig-frame-size])])
(values (lambda ()
(if (fx= frame-size 0)
`(nop)
@ -2286,28 +2404,64 @@
(lambda ()
(if (or (fx= frame-size 0) (memq conv '(i3nt-stdcall i3nt-com)))
`(nop)
`(set! ,%sp ,(%inline + ,%sp (immediate ,frame-size)))))))))
(let ([frame-size (if (callee-pops-result-pointer? result-type)
(fx- frame-size (constant ptr-bytes))
frame-size)])
`(set! ,%sp ,(%inline + ,%sp (immediate ,frame-size))))))))))
(lambda (info)
(safe-assert (reg-callee-save? %tc)) ; no need to save-restore
(let ([conv (info-foreign-conv info)]
[arg-type* (info-foreign-arg-type* info)]
[result-type (info-foreign-result-type info)])
(with-values (do-stack arg-type* '() 0)
(with-values (do-stack arg-type* '() 0 result-type)
(lambda (frame-size locs)
(returnem conv frame-size locs
(returnem conv frame-size locs result-type
(lambda (t0)
(case conv
[(i3nt-com)
(when (null? arg-type*)
($oops 'foreign-procedure
"__com convention requires instance argument"))
; jump indirect
(%seq
(set! ,%eax ,(%mref ,%sp 0))
(set! ,%eax ,(%mref ,%eax 0))
(set! ,%eax ,(%inline + ,%eax ,t0))
(inline ,(make-info-kill*-live* (reg-list %eax %edx) '()) ,%c-call ,(%mref ,%eax 0)))]
[else `(inline ,(make-info-kill*-live* (reg-list %eax %edx) '()) ,%c-call ,t0)]))
(let ([call
(case conv
[(i3nt-com)
(when (null? arg-type*)
($oops 'foreign-procedure
"__com convention requires instance argument"))
; jump indirect
(%seq
(set! ,%eax ,(%mref ,%sp 0))
(set! ,%eax ,(%mref ,%eax 0))
(set! ,%eax ,(%inline + ,%eax ,t0))
(inline ,(make-info-kill*-live* (reg-list %eax %edx) '()) ,%c-call ,(%mref ,%eax 0)))]
[else `(inline ,(make-info-kill*-live* (reg-list %eax %edx) '()) ,%c-call ,t0)])])
(cond
[(fill-result-pointer-from-registers? result-type)
(let* ([ftd (nanopass-case (Ltype Type) result-type
[(fp-ftd& ,ftd) ftd])]
[size ($ftd-size ftd)])
(%seq
,call
(set! ,%ecx ,(%mref ,%sp ,(fx- frame-size (constant ptr-bytes))))
,(case size
[(1)
`(inline ,(make-info-load 'integer-8 #f) ,%store
,%ecx ,%zero (immediate ,0) ,%eax)]
[(2)
`(inline ,(make-info-load 'integer-16 #f) ,%store
,%ecx ,%zero (immediate ,0) ,%eax)]
[(4)
(cond
[(and (if-feature windows (not ($ftd-compound? ftd)) #t)
(equal? '((float 4 0)) ($ftd->members ftd)))
`(set! ,(%mref ,%ecx 0) ,(%inline fstps))]
[else
`(set! ,(%mref ,%ecx 0) ,%eax)])]
[(8)
(cond
[(and (if-feature windows (not ($ftd-compound? ftd)) #t)
(equal? '((float 8 0)) ($ftd->members ftd)))
`(set! ,(%mref ,%ecx 0) ,(%inline fstpl))]
[else
`(seq
(set! ,(%mref ,%ecx 0) ,%eax)
(set! ,(%mref ,%ecx 4) ,%edx))])])))]
[else call])))
(nanopass-case (Ltype Type) result-type
[(fp-double-float)
(lambda (x)
@ -2350,6 +2504,25 @@
[else (lambda (lvalue) `(set! ,lvalue ,%eax))])))))))))
(define asm-foreign-callable
#|
Frame Layout
+---------------------------+
| |
| incoming stack args |
sp+X+Y: | |
+---------------------------+ <- i3osx: 16-byte boundary
| incoming return address | one word
+---------------------------+
| |
| callee-save registers | EBP, ESI, EDI, EBX (4 words)
sp+X: | |
+---------------------------+
| indirect result space | i3osx: 3 words
| (for & results via regs) | other: 2 words
sp+0: +---------------------------+<- i3osx: 16-byte boundary
|#
(with-output-language (L13 Effect)
(let ()
(define load-double-stack
@ -2389,6 +2562,10 @@
"unexpected load-int-stack fp-unsigned size ~s"
bits)])]
[else `(set! ,lvalue ,(%mref ,%sp ,offset))]))))
(define load-stack-address
(lambda (offset)
(lambda (lvalue) ; requires lvalue
`(set! ,lvalue ,(%inline + ,%sp (immediate ,offset))))))
(define load-stack64
(lambda (type offset)
(lambda (lolvalue hilvalue) ; requires lvalue
@ -2408,6 +2585,10 @@
(do-stack (cdr types)
(cons (load-single-stack n) locs)
(fx+ n 4))]
[(fp-ftd& ,ftd)
(do-stack (cdr types)
(cons (load-stack-address n) locs)
(fx+ n (fxlogand (fx+ ($ftd-size ftd) 3) -4)))]
[else
(if (nanopass-case (Ltype Type) (car types)
[(fp-integer ,bits) (fx= bits 64)]
@ -2419,61 +2600,127 @@
(do-stack (cdr types)
(cons (load-stack (car types) n) locs)
(fx+ n 4)))]))))
(define (do-result result-type init-stack-offset indirect-result-to-registers?)
(nanopass-case (Ltype Type) result-type
[(fp-ftd& ,ftd)
(cond
[indirect-result-to-registers?
(cond
[(and (if-feature windows (not ($ftd-compound? ftd)) #t)
(equal? '((float 4 0)) ($ftd->members ftd)))
(values (lambda ()
(%inline flds ,(%mref ,%sp 0)))
'())]
[(and (if-feature windows (not ($ftd-compound? ftd)) #t)
(equal? '((float 8 0)) ($ftd->members ftd)))
(values (lambda ()
(%inline fldl ,(%mref ,%sp 0)))
'())]
[(fx= ($ftd-size ftd) 8)
(values (lambda ()
`(seq
(set! ,%eax ,(%mref ,%sp 0))
(set! ,%edx ,(%mref ,%sp 4))))
(list %eax %edx))]
[else
(values (lambda ()
`(set! ,%eax ,(%mref ,%sp 0)))
(list %eax))])]
[else
(values (lambda ()
;; Return pointer that was filled; destination was the first argument
`(set! ,%eax ,(%mref ,%sp ,init-stack-offset)))
(list %eax))])]
[(fp-double-float)
(values (lambda (x)
(%inline fldl ,(%mref ,x ,(constant flonum-data-disp))))
'())]
[(fp-single-float)
(values (lambda (x)
(%inline fldl ,(%mref ,x ,(constant flonum-data-disp))))
'())]
[(fp-void)
(values (lambda () `(nop))
'())]
[else
(cond
[(nanopass-case (Ltype Type) result-type
[(fp-integer ,bits) (fx= bits 64)]
[(fp-unsigned ,bits) (fx= bits 64)]
[else #f])
(values (lambda (lorhs hirhs) ; requires rhs
(%seq
(set! ,%eax ,lorhs)
(set! ,%edx ,hirhs)))
(list %eax %edx))]
[else
(values (lambda (x)
`(set! ,%eax ,x))
(list %eax))])]))
(lambda (info)
(let ([conv (info-foreign-conv info)]
[arg-type* (info-foreign-arg-type* info)]
[result-type (info-foreign-result-type info)])
(with-values (do-stack arg-type* '()
(constant-case machine-type-name [(i3osx ti3osx) 32] [else 20]))
(lambda (frame-size locs)
(values
(lambda ()
(%seq
,(%inline push ,%ebp)
,(%inline push ,%esi)
,(%inline push ,%edi)
,(%inline push ,%ebx)
,((lambda (e)
(constant-case machine-type-name
[(i3osx ti3osx)
; maintain 16-bit alignment for i3osx, taking into account
; 16 bytes pushed below + 4 for RA pushed by asmCcall
(%seq
(set! ,%sp ,(%inline - ,%sp (immediate 12)))
,e)]
[else e]))
(if-feature pthreads
`(seq
(set! ,%eax ,(%inline get-tc))
(set! ,%tc ,%eax))
`(set! ,%tc (literal ,(make-info-literal #f 'entry (lookup-c-entry thread-context) 0)))))))
(reverse locs)
(lambda (fv* Scall->result-type)
(in-context Tail
((lambda (e)
(constant-case machine-type-name
[(i3osx ti3osx)
(%seq
(set! ,%sp ,(%inline + ,%sp (immediate 12)))
,e)]
[else e]))
[result-type (info-foreign-result-type info)]
[init-stack-offset (constant-case machine-type-name [(i3osx ti3osx) 32] [else 28])]
[indirect-result-space (constant-case machine-type-name
[(i3osx ti3osx)
;; maintain 16-bit alignment for i3osx, taking into account
;; 16 bytes pushed above + 4 for RA pushed by asmCcall;
;; 8 of these bytes are used for &-return space, if needed
12]
[else 8])])
(let ([indirect-result-to-registers? (fill-result-pointer-from-registers? result-type)])
(let-values ([(get-result result-regs) (do-result result-type init-stack-offset indirect-result-to-registers?)])
(with-values (do-stack (if indirect-result-to-registers?
(cdr arg-type*)
arg-type*)
'()
init-stack-offset)
(lambda (frame-size locs)
(values
(lambda ()
(%seq
(set! ,%ebx ,(%inline pop))
(set! ,%edi ,(%inline pop))
(set! ,%esi ,(%inline pop))
(set! ,%ebp ,(%inline pop))
; Windows __stdcall convention requires callee to clean up
,((lambda (e)
(if (memq conv '(i3nt-stdcall i3nt-com))
(let ([arg-size (fx- frame-size 20)])
,(%inline push ,%ebp)
,(%inline push ,%esi)
,(%inline push ,%edi)
,(%inline push ,%ebx)
(set! ,%sp ,(%inline - ,%sp (immediate ,indirect-result-space)))
,(if-feature pthreads
`(seq
(set! ,%eax ,(%inline get-tc))
(set! ,%tc ,%eax))
`(set! ,%tc (literal ,(make-info-literal #f 'entry (lookup-c-entry thread-context) 0))))))
(let ([locs (reverse locs)])
(if indirect-result-to-registers?
(cons (load-stack-address 0) ; use the &-return space
locs)
locs))
get-result
(lambda ()
(in-context Tail
(%seq
(set! ,%sp ,(%inline + ,%sp (immediate ,indirect-result-space)))
(set! ,%ebx ,(%inline pop))
(set! ,%edi ,(%inline pop))
(set! ,%esi ,(%inline pop))
(set! ,%ebp ,(%inline pop))
; Windows __stdcall convention requires callee to clean up
,((lambda (e)
(if (memq conv '(i3nt-stdcall i3nt-com))
(let ([arg-size (fx- frame-size init-stack-offset)])
(if (fx> arg-size 0)
(%seq
(set!
,(%mref ,%sp ,arg-size)
,(%mref ,%sp 0))
(set! ,%sp ,(%inline + ,%sp (immediate ,arg-size)))
,e)
(set!
,(%mref ,%sp ,arg-size)
,(%mref ,%sp 0))
(set! ,%sp ,(%inline + ,%sp (immediate ,arg-size)))
,e)
e))
e))
`(jump (literal ,(make-info-literal #f 'entry Scall->result-type 0))
(,%ebx ,%edi ,%esi ,%ebp ,fv* ...))))))))))))))))
`(asm-c-return ,(if (callee-pops-result-pointer? result-type)
;; remove the pointer argument provided by the caller
;; after popping the return address
(make-info-c-return 4)
null-info)
,result-regs ...)))))))))))))))
)

535
s/x86_64.ss
View File

@ -977,7 +977,7 @@
asm-fl-cvt asm-fl-store asm-fl-load asm-flt asm-trunc asm-div
asm-exchange asm-pause asm-locked-incr asm-locked-decr
asm-flop-2 asm-flsqrt asm-c-simple-call
asm-save-flrv asm-restore-flrv asm-return asm-size
asm-save-flrv asm-restore-flrv asm-return asm-c-return asm-size
asm-enter asm-foreign-call asm-foreign-callable
asm-inc-profile-counter
asm-inc-cc-counter asm-read-time-stamp-counter asm-read-performance-monitoring-counter
@ -1991,6 +1991,10 @@
(emit addi '(imm 8) (cons 'reg %sp)
(emit ret '()))))
(define asm-c-return
(lambda (info)
(emit ret '())))
(define asm-locked-incr
(lambda (code* base index offset)
(let ([dest (build-mem-opnd base index offset)])
@ -2408,6 +2412,88 @@
(define make-vint (lambda () (vector %Carg1 %Carg2 %Carg3 %Carg4 %Carg5 %Carg6)))
(define make-vfp (lambda () (vector %Cfparg1 %Cfparg2 %Cfparg3 %Cfparg4 %Cfparg5 %Cfparg6 %Cfparg7 %Cfparg8)))))
(define (align n size)
(fxlogand (fx+ n (fx- size 1)) (fx- size)))
(define (classify-type type)
(nanopass-case (Ltype Type) type
[(fp-ftd& ,ftd) (classify-eightbytes ftd)]
[else #f]))
;; classify-eightbytes: returns '(memory) or a nonemtpy list of 'integer/'sse
(if-feature windows
;; Windows: either passed in one register or not
(define (classify-eightbytes ftd)
(cond
[($ftd-compound? ftd)
(if (memv ($ftd-size ftd) '(1 2 4 8))
'(integer)
'(memory))]
[(eq? 'float (caar ($ftd->members ftd)))
'(sse)]
[else '(integer)]))
;; Non-Windows: SYSV ABI is a more general classification of
;; 8-byte segments into 'integer, 'sse, or 'memory modes
(define (classify-eightbytes ftd)
(define (merge t1 t2)
(cond
[(eq? t1 t2) t1]
[(eq? t1 'no-class) t2]
[(eq? t2 'no-class) t1]
[(eq? t1 'memory) 'memory]
[(eq? t2 'memory) 'memory]
[else 'integer]))
(cond
[(or (> ($ftd-size ftd) 16) ; more than 2 eightbytes => passed in memory
(fx= 0 ($ftd-size ftd)))
'(memory)]
[else
(let ([classes (make-vector (fxsrl (align ($ftd-size ftd) 8) 3) 'no-class)])
(let loop ([mbrs ($ftd->members ftd)])
(cond
[(null? mbrs)
(vector->list classes)]
[else
(let ([kind (caar mbrs)]
[size (cadar mbrs)]
[offset (caddar mbrs)])
(cond
[(not (fx= offset (align offset size)))
;; misaligned
'(memory)]
[else
(let* ([pos (fxsrl offset 3)]
[class (vector-ref classes pos)]
[new-class (merge class (if (eq? kind 'float) 'sse 'integer))])
(cond
[(eq? new-class 'memory)
'(memory)]
[else
(vector-set! classes pos new-class)
(loop (cdr mbrs))]))]))])))])))
(define (count v l)
(cond
[(null? l) 0]
[(eq? (car l) v) (fx+ 1 (count v (cdr l)))]
[else (count v (cdr l))]))
;; A result is put in registers if it has up to two
;; eightbytes, each 'integer or 'sse. On Windows,
;; `result-classes` always has only one item.
(define (result-fits-in-registers? result-classes)
(and result-classes
(not (eq? 'memory (car result-classes)))
(or (null? (cdr result-classes))
(null? (cddr result-classes)))))
;; An argument is put in registeres depending on how many
;; registers are left
(define (pass-here-by-stack? classes iint ints ifp fps)
(or (eq? 'memory (car classes))
(fx> (fx+ iint ints) 6)
(fx> (fx+ ifp fps) 8)))
(define asm-foreign-call
(with-output-language (L13 Effect)
(letrec ([load-double-stack
@ -2452,6 +2538,87 @@
; x is a non-triv right-hand-side
[else (%seq (set! ,ireg ,x) (set! ,ireg ,(%inline zext32 ,ireg)))])]
[else `(set! ,ireg ,x)])))]
[load-content-stack
(lambda (offset len)
(lambda (x) ; requires var
(let loop ([offset offset] [x-offset 0] [len len])
(cond
[(= len 0) `(nop)]
[(>= len 8)
`(seq
(set! ,(%mref ,%sp ,offset) (inline ,(make-info-load 'integer-64 #f)
,%load ,x ,%zero (immediate ,x-offset)))
,(loop (fx+ offset 8) (fx+ x-offset 8) (fx- len 8)))]
[(>= len 4)
`(seq
(set! ,(%mref ,%sp ,offset) (inline ,(make-info-load 'integer-32 #f)
,%load ,x ,%zero (immediate ,x-offset)))
,(loop (fx+ offset 4) (fx+ x-offset 4) (fx- len 4)))]
[(>= len 2)
`(seq
(set! ,(%mref ,%sp ,offset) (inline ,(make-info-load 'integer-16 #f)
,%load ,x ,%zero (immediate ,x-offset)))
,(loop (fx+ offset 2) (fx+ x-offset 2) (fx- len 2)))]
[else
`(set! ,(%mref ,%sp ,offset) (inline ,(make-info-load 'integer-8 #f)
,%load ,x ,%zero (immediate ,x-offset)))]))))]
[load-content-regs
(lambda (classes size iint ifp vint vfp)
(lambda (x) ; requires var
(let loop ([size size] [iint iint] [ifp ifp] [classes classes] [x-offset 0])
(cond
[(null? classes) `(nop)]
[(eq? 'sse (car classes))
(cond
[(fx= size 4)
;; Must be the last element
`(inline ,(make-info-loadfl (vector-ref vfp ifp)) ,%load-single ,x ,%zero (immediate ,x-offset))]
[else
`(seq
(inline ,(make-info-loadfl (vector-ref vfp ifp)) ,%load-double ,x ,%zero (immediate ,x-offset))
,(loop (fx- size 8) iint (fx+ ifp 1) (cdr classes) (fx+ x-offset 8)))])]
;; Remaining cases are integers:
[(>= size 8)
`(seq
(set! ,(vector-ref vint iint) (inline ,(make-info-load 'integer-64 #f)
,%load ,x ,%zero (immediate ,x-offset)))
,(loop (fx- size 8) (fx+ iint 1) ifp (cdr classes) (fx+ x-offset 8)))]
;; Remaining cases must be the last element
[else
(let loop ([reg (vector-ref vint iint)] [size size] [x-offset x-offset])
(cond
[(= size 4)
`(set! ,reg (inline ,(make-info-load 'unsigned-32 #f)
,%load ,x ,%zero (immediate ,x-offset)))]
[(= size 2)
`(set! ,reg (inline ,(make-info-load 'unsigned-16 #f)
,%load ,x ,%zero (immediate ,x-offset)))]
[(= size 1)
`(set! ,reg (inline ,(make-info-load 'unsigned-8 #f)
,%load ,x ,%zero (immediate ,x-offset)))]
[(> size 4)
;; 5, 6, or 7: multiple steps to avoid reading too many bytes
(let ([tmp %rax]) ;; ?? ok to use %rax?
(%seq
,(loop reg (fx- size 4) (fx+ x-offset 4))
(set! ,reg ,(%inline sll ,reg (immediate 32)))
,(loop tmp 4 x-offset)
(set! ,reg ,(%inline + ,reg ,tmp))))]
[else
;; 3: multiple steps to avoid reading too many bytes
(let ([tmp %rax]) ;; ?? ok to use %rax?
(%seq
,(loop reg (fx- size 2) (fx+ x-offset 2))
(set! ,reg ,(%inline sll ,reg (immediate 16)))
,(loop tmp 2 x-offset)
(set! ,reg ,(%inline + ,reg ,tmp))))]))]))))]
[add-int-regs
(lambda (ints iint vint regs)
(cond
[(fx= 0 ints) regs]
[else
(add-int-regs (fx- ints 1) (fx+ iint 1) vint
(cons (vector-ref vint iint) regs))]))]
[do-args
(lambda (types vint vfp)
(if-feature windows
@ -2476,6 +2643,44 @@
(loop (cdr types)
(cons (load-single-stack isp) locs)
regs i (fx+ isp 8)))]
[(fp-ftd& ,ftd)
(cond
[(memv ($ftd-size ftd) '(1 2 4 8))
;; pass as value in register or as value on the stack
(cond
[(< i 4)
;; pass as value in register
(cond
[(and (not ($ftd-compound? ftd))
(eq? 'float (caar ($ftd->members ftd))))
;; float or double
(loop (cdr types)
(cons (load-content-regs '(sse) ($ftd-size ftd) i i vint vfp) locs)
(add-int-regs 1 i vint regs) (fx+ i 1) isp)]
[else
;; integer
(loop (cdr types)
(cons (load-content-regs '(integer) ($ftd-size ftd) i i vint vfp) locs)
(add-int-regs 1 i vint regs) (fx+ i 1) isp)])]
[else
;; pass as value on the stack
(loop (cdr types)
(cons (load-content-stack isp ($ftd-size ftd)) locs)
regs i (fx+ isp (align ($ftd-size ftd) 8)))])]
[else
;; pass by reference in register or by reference on the stack
(cond
[(< i 4)
;; pass by reference in a register
(let ([reg (vector-ref vint i)])
(loop (cdr types)
(cons (load-int-reg (car types) reg) locs)
(cons reg regs) (fx+ i 1) isp))]
[else
;; pass by reference on the stack
(loop (cdr types)
(cons (load-int-stack isp) locs)
regs i (fx+ isp 8))])])]
[else
(if (< i 4)
(let ([reg (vector-ref vint i)])
@ -2506,6 +2711,22 @@
(loop (cdr types)
(cons (load-single-stack isp) locs)
regs iint ifp (fx+ isp 8)))]
[(fp-ftd& ,ftd)
(let* ([classes (classify-eightbytes ftd)]
[ints (count 'integer classes)]
[fps (count 'sse classes)])
(cond
[(pass-here-by-stack? classes iint ints ifp fps)
;; pass on the stack
(loop (cdr types)
(cons (load-content-stack isp ($ftd-size ftd)) locs)
regs iint ifp (fx+ isp (align ($ftd-size ftd) 8)))]
[else
;; pass in registers
(loop (cdr types)
(cons (load-content-regs classes ($ftd-size ftd) iint ifp vint vfp) locs)
(add-int-regs ints iint vint regs)
(fx+ iint ints) (fx+ ifp fps) isp)]))]
[else
(if (< iint 6)
(let ([reg (vector-ref vint iint)])
@ -2516,6 +2737,35 @@
(loop (cdr types)
(cons (load-int-stack isp) locs)
regs iint ifp (fx+ isp 8)))])))))])
(define (add-save-fill-target fill-result-here? frame-size locs)
(cond
[fill-result-here?
;; The callee isn't expecting a pointer to fill with the result.
;; Stash the pointer as an extra argument, and then when the
;; function returns, we'll move register content for the result
;; into the pointer's target
(values (fx+ frame-size (constant ptr-bytes))
(append locs
(list
(lambda (x) ; requires var
`(set! ,(%mref ,%sp ,frame-size) ,x)))))]
[else
(values frame-size locs)]))
(define (add-fill-result c-call saved-offset classes)
(let loop ([classes classes] [offset 0] [iregs (reg-list %rax %rdx)] [fpregs (reg-list %Cfparg1 %Cfparg2)])
(cond
[(null? classes)
`(seq
,c-call
(set! ,%rcx ,(%mref ,%sp ,saved-offset)))]
[(eq? 'sse (car classes))
`(seq
,(loop (cdr classes) (fx+ offset 8) iregs (cdr fpregs))
(inline ,(make-info-loadfl (car fpregs)) ,%store-double ,%rcx ,%zero (immediate ,offset)))]
[else
`(seq
,(loop (cdr classes) (fx+ offset 8) (cdr iregs) fpregs)
(set! ,(%mref ,%rcx ,offset) ,(car iregs)))])))
(define returnem
(lambda (frame-size locs ccall r-loc)
; need to maintain 16-byte alignment, ignoring the return address
@ -2535,51 +2785,60 @@
`(set! ,%sp ,(%inline + ,%sp (immediate ,frame-size)))))))))
(lambda (info)
(safe-assert (reg-callee-save? %tc)) ; no need to save-restore
(let ([conv (info-foreign-conv info)]
[arg-type* (info-foreign-arg-type* info)]
[result-type (info-foreign-result-type info)])
(with-values (do-args arg-type* (make-vint) (make-vfp))
(let* ([conv (info-foreign-conv info)]
[arg-type* (info-foreign-arg-type* info)]
[result-type (info-foreign-result-type info)]
[result-classes (classify-type result-type)]
[fill-result-here? (result-fits-in-registers? result-classes)])
(with-values (do-args (if fill-result-here? (cdr arg-type*) arg-type*) (make-vint) (make-vfp))
(lambda (frame-size nfp locs live*)
(returnem frame-size locs
(lambda (t0)
(if-feature windows
(%seq
(set! ,%sp ,(%inline - ,%sp (immediate 32)))
(inline ,(make-info-kill*-live* (reg-list %rax) live*) ,%c-call ,t0)
(set! ,%sp ,(%inline + ,%sp (immediate 32))))
(%seq
; System V ABI varargs functions require count of fp regs used in %al register.
; since we don't know if the callee is a varargs function, we always set it.
(set! ,%rax (immediate ,nfp))
(inline ,(make-info-kill*-live* (reg-list %rax) (cons %rax live*)) ,%c-call ,t0))))
(nanopass-case (Ltype Type) result-type
[(fp-double-float)
(lambda (lvalue)
`(inline ,(make-info-loadfl %Cfpretval) ,%store-double ,lvalue ,%zero
,(%constant flonum-data-disp)))]
[(fp-single-float)
(lambda (lvalue)
`(inline ,(make-info-loadfl %Cfpretval) ,%store-single->double ,lvalue ,%zero
,(%constant flonum-data-disp)))]
[(fp-integer ,bits)
(case bits
[(8) (lambda (lvalue) `(set! ,lvalue ,(%inline sext8 ,%rax)))]
[(16) (lambda (lvalue) `(set! ,lvalue ,(%inline sext16 ,%rax)))]
[(32) (lambda (lvalue) `(set! ,lvalue ,(%inline sext32 ,%rax)))]
[(64) (lambda (lvalue) `(set! ,lvalue ,%rax))]
[else ($oops 'assembler-internal
"unexpected asm-foreign-procedures fp-integer size ~s"
bits)])]
[(fp-unsigned ,bits)
(case bits
[(8) (lambda (lvalue) `(set! ,lvalue ,(%inline zext8 ,%rax)))]
[(16) (lambda (lvalue) `(set! ,lvalue ,(%inline zext16 ,%rax)))]
[(32) (lambda (lvalue) `(set! ,lvalue ,(%inline zext32 ,%rax)))]
[(64) (lambda (lvalue) `(set! ,lvalue ,%rax))]
[else ($oops 'assembler-internal
"unexpected asm-foreign-procedures fp-unsigned size ~s"
bits)])]
[else (lambda (lvalue) `(set! ,lvalue ,%rax))])))))))))
(with-values (add-save-fill-target fill-result-here? frame-size locs)
(lambda (frame-size locs)
(returnem frame-size locs
(lambda (t0)
(let ([c-call
(if-feature windows
(%seq
(set! ,%sp ,(%inline - ,%sp (immediate 32)))
(inline ,(make-info-kill*-live* (reg-list %rax) live*) ,%c-call ,t0)
(set! ,%sp ,(%inline + ,%sp (immediate 32))))
(%seq
;; System V ABI varargs functions require count of fp regs used in %al register.
;; since we don't know if the callee is a varargs function, we always set it.
(set! ,%rax (immediate ,nfp))
(inline ,(make-info-kill*-live* (reg-list %rax) (cons %rax live*)) ,%c-call ,t0)))])
(cond
[fill-result-here?
(add-fill-result c-call (fx- frame-size (constant ptr-bytes)) result-classes)]
[else c-call])))
(nanopass-case (Ltype Type) result-type
[(fp-double-float)
(lambda (lvalue)
`(inline ,(make-info-loadfl %Cfpretval) ,%store-double ,lvalue ,%zero
,(%constant flonum-data-disp)))]
[(fp-single-float)
(lambda (lvalue)
`(inline ,(make-info-loadfl %Cfpretval) ,%store-single->double ,lvalue ,%zero
,(%constant flonum-data-disp)))]
[(fp-integer ,bits)
(case bits
[(8) (lambda (lvalue) `(set! ,lvalue ,(%inline sext8 ,%rax)))]
[(16) (lambda (lvalue) `(set! ,lvalue ,(%inline sext16 ,%rax)))]
[(32) (lambda (lvalue) `(set! ,lvalue ,(%inline sext32 ,%rax)))]
[(64) (lambda (lvalue) `(set! ,lvalue ,%rax))]
[else ($oops 'assembler-internal
"unexpected asm-foreign-procedures fp-integer size ~s"
bits)])]
[(fp-unsigned ,bits)
(case bits
[(8) (lambda (lvalue) `(set! ,lvalue ,(%inline zext8 ,%rax)))]
[(16) (lambda (lvalue) `(set! ,lvalue ,(%inline zext16 ,%rax)))]
[(32) (lambda (lvalue) `(set! ,lvalue ,(%inline zext32 ,%rax)))]
[(64) (lambda (lvalue) `(set! ,lvalue ,%rax))]
[else ($oops 'assembler-internal
"unexpected asm-foreign-procedures fp-unsigned size ~s"
bits)])]
[else (lambda (lvalue) `(set! ,lvalue ,%rax))])))))))))))
(define asm-foreign-callable
#|
@ -2600,7 +2859,7 @@
| callee-save registers | RBX, RBP, RDI, RSI, R12, R13, R14, R15 (8 quads)
| |
+---------------------------+
| pad word | one quad
| pad word / indirect space | one quad
sp+0: +---------------------------+<- 16-byte boundary
@ -2609,11 +2868,14 @@
+---------------------------+
| |
| incoming stack args |
sp+176: | |
sp+192: | |
+---------------------------+ <- 16-byte boundary
| incoming return address | one quad
+---------------------------+
| pad word | one quad
+---------------------------+
| indirect result space | two quads
sp+160 | (for & results via regs) |
+---------------------------+<- 16-byte boundary
| |
| saved register args | space for Carg*, Cfparg* (14 quads)
@ -2661,6 +2923,10 @@
"unexpected load-int-stack fp-unsigned size ~s"
bits)])]
[else `(set! ,lvalue ,(%mref ,%sp ,offset))]))))
(define load-stack-address
(lambda (offset)
(lambda (lvalue) ; requires lvalue
`(set! ,lvalue ,(%inline + ,%sp (immediate ,offset))))))
(define save-arg-regs
(lambda (types)
(define vint (make-vint))
@ -2684,6 +2950,40 @@
,%sp ,%zero (immediate ,isp))
,(f (cdr types) (fx+ i 1) (fx+ isp 8)))
(f (cdr types) i isp))]
[(fp-ftd& ,ftd)
(cond
[(memv ($ftd-size ftd) '(1 2 4 8))
;; receive as value in register or on the stack
(cond
[(< i 4)
;; receive in register
(cond
[(and (not ($ftd-compound? ftd))
(eq? 'float (caar ($ftd->members ftd))))
;; float or double
`(seq
(inline ,(make-info-loadfl (vector-ref vfp i)) ,%store-double
,%sp ,%zero (immediate ,isp))
,(f (cdr types) (fx+ i 1) (fx+ isp 8)))]
[else
;; integer
`(seq
(set! ,(%mref ,%sp ,isp) ,(vector-ref vint i))
,(f (cdr types) (fx+ i 1) (fx+ isp 8)))])]
[else
;; receive by value on the stack
(f (cdr types) i isp)])]
[else
;; receive by reference in register or on the stack
(cond
[(< i 4)
;; receive by reference in register
`(seq
(set! ,(%mref ,%sp ,isp) ,(vector-ref vint i))
,(f (cdr types) (fx+ i 1) (fx+ isp 8)))]
[else
;; receive by reference on the stack
(f (cdr types) i isp)])])]
[else
(if (< i 4)
(%seq
@ -2708,6 +3008,29 @@
,%sp ,%zero (immediate ,isp))
,(f (cdr types) iint (fx+ ifp 1) (fx+ isp 8)))
(f (cdr types) iint ifp isp))]
[(fp-ftd& ,ftd)
(let* ([classes (classify-eightbytes ftd)]
[ints (count 'integer classes)]
[fps (count 'sse classes)])
(cond
[(pass-here-by-stack? classes iint ints ifp fps)
;; receive on the stack
(f (cdr types) iint ifp isp)]
[else
;; receive via registers
(let reg-loop ([classes classes] [iint iint] [ifp ifp] [isp isp])
(cond
[(null? classes)
(f (cdr types) iint ifp isp)]
[(eq? (car classes) 'sse)
`(seq
(inline ,(make-info-loadfl (vector-ref vfp ifp)) ,%store-double
,%sp ,%zero (immediate ,isp))
,(reg-loop (cdr classes) iint (fx+ ifp 1) (+ isp 8)))]
[else
`(seq
(set! ,(%mref ,%sp ,isp) ,(vector-ref vint iint))
,(reg-loop (cdr classes) (fx+ iint 1) ifp (+ isp 8)))]))]))]
[else
(if (< iint 6)
(%seq
@ -2727,10 +3050,23 @@
(nanopass-case (Ltype Type) (car types)
[(fp-double-float) (load-double-stack isp)]
[(fp-single-float) (load-single-stack isp)]
[(fp-ftd& ,ftd)
(cond
[(memq ($ftd-size ftd) '(1 2 4 8))
;; passed by value
(load-stack-address isp)]
[else
;; passed by reference
(load-int-stack (car types) isp)])]
[else (load-int-stack (car types) isp)])
locs)
(fx+ isp 8))))
(let f ([types types] [locs '()] [iint 0] [ifp 0] [risp 48] [sisp 176])
(let f ([types types]
[locs '()]
[iint 0]
[ifp 0]
[risp 48]
[sisp 192])
(if (null? types)
locs
(nanopass-case (Ltype Type) (car types)
@ -2750,6 +3086,23 @@
(f (cdr types)
(cons (load-single-stack risp) locs)
iint (fx+ ifp 1) (fx+ risp 8) sisp))]
[(fp-ftd& ,ftd)
(let* ([classes (classify-eightbytes ftd)]
[ints (count 'integer classes)]
[fps (count 'sse classes)])
(cond
[(pass-here-by-stack? classes iint ints ifp fps)
;; receive on the stack
(f (cdr types)
(cons (load-stack-address sisp) locs)
iint ifp risp (fx+ sisp ($ftd-size ftd)))]
[else
;; receive via registers; `save-args-regs` has saved
;; the registers in a suitable order so that the data
;; is contiguous on the stack
(f (cdr types)
(cons (load-stack-address risp) locs)
(fx+ iint ints) (fx+ ifp fps) (fx+ risp (fx* 8 (fx+ ints fps))) sisp)]))]
[else
(if (= iint 6)
(f (cdr types)
@ -2758,14 +3111,74 @@
(f (cdr types)
(cons (load-int-stack (car types) risp) locs)
(fx+ iint 1) ifp (fx+ risp 8) sisp))]))))))
(define (do-result result-type result-classes)
(nanopass-case (Ltype Type) result-type
[(fp-ftd& ,ftd)
(cond
[(result-fits-in-registers? result-classes)
;; Copy content of result area on stack into
;; the integer and floating-point registers
(let loop ([result-classes result-classes]
[offset (if-feature windows 0 160)]
[int* (list %rax %rdx)]
[fp* (list %Cfpretval %Cfparg2)]
[accum '()]
[live* '()])
(cond
[(null? result-classes)
(values (lambda ()
(if (pair? (cdr accum)) `(seq ,(car accum) ,(cadr accum)) (car accum)))
live*)]
[(eq? (car result-classes) 'integer)
(loop (cdr result-classes)
(fx+ offset 8)
(cdr int*)
fp*
(cons `(set! ,(car int*) ,(%mref ,%sp ,offset))
accum)
(cons (car int*) live*))]
[(eq? (car result-classes) 'sse)
(loop (cdr result-classes)
(fx+ offset 8)
int*
(cdr fp*)
(cons `(inline ,(make-info-loadfl (car fp*)) ,%load-double ,%sp ,%zero (immediate ,offset))
accum)
live*)]))]
[else
(values (lambda ()
;; Return pointer that was filled; destination was the first argument
`(set! ,%Cretval ,(%mref ,%sp ,(if-feature windows 80 48))))
(list %Cretval))])]
[(fp-double-float)
(values
(lambda (x)
`(inline ,(make-info-loadfl %Cfpretval) ,%load-double ,x ,%zero ,(%constant flonum-data-disp)))
'())]
[(fp-single-float)
(values
(lambda (x)
`(inline ,(make-info-loadfl %Cfpretval) ,%load-double->single ,x ,%zero ,(%constant flonum-data-disp)))
'())]
[(fp-void)
(values (lambda () `(nop))
'())]
[else
(values(lambda (x)
`(set! ,%Cretval ,x))
(list %Cretval))]))
(lambda (info)
(let ([conv (info-foreign-conv info)]
[arg-type* (info-foreign-arg-type* info)]
[result-type (info-foreign-result-type info)])
(let ([locs (do-stack arg-type*)])
(values
(lambda ()
(%seq
(let* ([result-classes (classify-type result-type)]
[synthesize-first? (and result-classes
(result-fits-in-registers? result-classes))]
[locs (do-stack (if synthesize-first? (cdr arg-type*) arg-type*))])
(let-values ([(get-result result-regs) (do-result result-type result-classes)])
(values
(lambda ()
(%seq
,(if-feature windows
(%seq
,(save-arg-regs arg-type*)
@ -2779,7 +3192,7 @@
,(%inline push ,%r15)
(set! ,%sp ,(%inline - ,%sp (immediate 8))))
(%seq
(set! ,%sp ,(%inline - ,%sp (immediate 120)))
(set! ,%sp ,(%inline - ,%sp (immediate 136)))
,(%inline push ,%rbx)
,(%inline push ,%rbp)
,(%inline push ,%r12)
@ -2792,9 +3205,14 @@
(set! ,%rax ,(%inline get-tc))
(set! ,%tc ,%rax))
`(set! ,%tc (literal ,(make-info-literal #f 'entry (lookup-c-entry thread-context) 0))))))
(reverse locs)
(lambda (fv* Scall->result-type)
(in-context Tail
(let ([locs (reverse locs)])
(if synthesize-first?
(cons (load-stack-address (if-feature windows 0 160)) ; space on stack for results to be returned via registers
locs)
locs))
get-result
(lambda ()
(in-context Tail
(%seq
,(if-feature windows
(%seq
@ -2814,7 +3232,6 @@
(set! ,%r12 ,(%inline pop))
(set! ,%rbp ,(%inline pop))
(set! ,%rbx ,(%inline pop))
(set! ,%sp ,(%inline + ,%sp (immediate 120)))))
(jump (literal ,(make-info-literal #f 'entry Scall->result-type 0))
(,%rbx ,%rbp ,%r12 ,%r13 ,%r14 ,%r15 ,fv* ...)))))))))))))
(set! ,%sp ,(%inline + ,%sp (immediate 136)))))
(asm-c-return ,null-info ,result-regs ...)))))))))))))
)