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

Merge branch 'pthread' of https://github.com/mflatt/ChezScheme into mflatt-pthread-2

Browse Source 
original commit: 2230e5adcb61ac8b27c9deee682270f4e17fbafb
This commit is contained in:
Andy Keep 2018-04-21 22:09:05 -04:00
commit 1f0e42f0ec
40 changed files with 1195 additions and 342 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
LOG
View File

@ -924,3 +924,10 @@
- add newline to (import-notify) message in compile-whole-library and - add newline to (import-notify) message in compile-whole-library and
compile-whole-program compile-whole-program
compile.ss compile.ss
- add a __collect_safe convention for foreign procedures and callables
to automate thread [de]activation
syntax.ss, ftype.ss, x86.ss, x86_64.ss, ppc32.ss,
cmacros.ss, base-lang.ss, np-languages.ss, cprep.ss, cpcommonize.ss,
cp0.ss, cpcheck.ss, cpvalid.ss, interpret.ss, cpletrec.ss,
thread.c, prim.c, externs.h, foreign.stex, release_notes.stex,
mats/Mf-t*, foreign.ms, foreign4.c

2
c/externs.h
View File

@ -216,6 +216,8 @@ extern void S_mutex_release PROTO((scheme_mutex_t *m));
extern s_thread_cond_t *S_make_condition PROTO((void)); extern s_thread_cond_t *S_make_condition PROTO((void));
extern void S_condition_free PROTO((s_thread_cond_t *c)); extern void S_condition_free PROTO((s_thread_cond_t *c));
extern IBOOL S_condition_wait PROTO((s_thread_cond_t *c, scheme_mutex_t *m, ptr t)); extern IBOOL S_condition_wait PROTO((s_thread_cond_t *c, scheme_mutex_t *m, ptr t));
extern INT S_activate_thread PROTO((void));
extern void S_unactivate_thread PROTO((int mode));
#endif #endif
/* scheme.c */ /* scheme.c */

8
c/prim.c
View File

@ -124,6 +124,9 @@ static void create_c_entry_vector() {
#ifdef PTHREADS #ifdef PTHREADS
install_c_entry(CENTRY_raw_collect_cond, (ptr)&S_collect_cond); install_c_entry(CENTRY_raw_collect_cond, (ptr)&S_collect_cond);
install_c_entry(CENTRY_raw_tc_mutex, (ptr)&S_tc_mutex); install_c_entry(CENTRY_raw_tc_mutex, (ptr)&S_tc_mutex);
install_c_entry(CENTRY_activate_thread, proc2ptr(S_activate_thread));
install_c_entry(CENTRY_deactivate_thread, proc2ptr(Sdeactivate_thread));
install_c_entry(CENTRY_unactivate_thread, proc2ptr(S_unactivate_thread));
#endif /* PTHREADS */ #endif /* PTHREADS */
install_c_entry(CENTRY_handle_values_error, proc2ptr(S_handle_values_error)); install_c_entry(CENTRY_handle_values_error, proc2ptr(S_handle_values_error));
install_c_entry(CENTRY_handle_mvlet_error, proc2ptr(S_handle_mvlet_error)); install_c_entry(CENTRY_handle_mvlet_error, proc2ptr(S_handle_mvlet_error));
@ -139,7 +142,10 @@ static void create_c_entry_vector() {
for (i = 0; i < c_entry_vector_size; i++) { for (i = 0; i < c_entry_vector_size; i++) {
#ifndef PTHREADS #ifndef PTHREADS
if (i == CENTRY_raw_collect_cond || i == CENTRY_raw_tc_mutex) continue; if (i == CENTRY_raw_collect_cond || i == CENTRY_raw_tc_mutex
|| i == CENTRY_activate_thread || i == CENTRY_deactivate_thread
|| i == CENTRY_unactivate_thread)
continue;
#endif /* NOT PTHREADS */ #endif /* NOT PTHREADS */
if (Svector_ref(S_G.c_entry_vector, i) == Sfalse) { if (Svector_ref(S_G.c_entry_vector, i) == Sfalse) {
fprintf(stderr, "c_entry_vector entry %d is uninitialized\n", i); fprintf(stderr, "c_entry_vector entry %d is uninitialized\n", i);

27
c/thread.c
View File

@ -143,6 +143,33 @@ IBOOL Sactivate_thread() { /* create or reactivate current thread */
} }
} }
int S_activate_thread() { /* Like Sactivate_thread(), but returns a mode to revert the effect */
ptr tc = get_thread_context();
if (tc == (ptr)0) {
Sactivate_thread();
return unactivate_mode_destroy;
} else if (!ACTIVE(tc)) {
reactivate_thread(tc);
return unactivate_mode_deactivate;
} else
return unactivate_mode_noop;
}
void S_unactivate_thread(int mode) { /* Reverts a previous S_activate_thread() effect */
switch (mode) {
case unactivate_mode_deactivate:
Sdeactivate_thread();
break;
case unactivate_mode_destroy:
Sdestroy_thread();
break;
case unactivate_mode_noop:
default:
break;
}
}
void Sdeactivate_thread() { /* deactivate current thread */ void Sdeactivate_thread() { /* deactivate current thread */
ptr tc = get_thread_context(); ptr tc = get_thread_context();
if (tc != (ptr)0) deactivate_thread(tc) if (tc != (ptr)0) deactivate_thread(tc)

117
csug/foreign.stex
View File

@ -192,8 +192,7 @@ Scheme-callable wrappers for foreign procedures can also be created via
%---------------------------------------------------------------------------- %----------------------------------------------------------------------------
\entryheader \entryheader
\formdef{foreign-procedure}{\categorysyntax}{(foreign-procedure \var{entry-exp} (\var{param-type} \dots) \var{res-type})} \formdef{foreign-procedure}{\categorysyntax}{(foreign-procedure \var{conv} \dots \var{entry-exp} (\var{param-type} \dots) \var{res-type})}
\formdef{foreign-procedure}{\categorysyntax}{(foreign-procedure \var{conv} \var{entry-exp} (\var{param-type} \dots) \var{res-type})}
\returns a procedure \returns a procedure
\listlibraries \listlibraries
\endentryheader \endentryheader
@ -213,13 +212,15 @@ by the \var{res-type}.
Multiple procedures may be created for the same \index{foreign entry}foreign entry. Multiple procedures may be created for the same \index{foreign entry}foreign entry.
\label{page:conv-description}% \label{page:conv-description}%
If \var{conv} is present, it specifies the calling convention to be used. Each \var{conv} adjusts specifies the calling convention to be used.
The default is \scheme{#f}, which specifies the default calling convention A \scheme{#f} is allowed as \var{conv} to indicate the default calling convention
on the target machine. on the target machine (so the \scheme{#f} has no effect).
Three other conventions are currently supported, all only under Three other conventions are currently supported under
Windows: \scheme{__stdcall}, \scheme{__cdecl}, and \scheme{__com}. Windows: \scheme{__stdcall}, \scheme{__cdecl}, and \scheme{__com} (32-bit only).
Since \scheme{__cdecl} is the default, specifying \scheme{__cdecl} is Since \scheme{__cdecl} is the default, specifying \scheme{__cdecl} is
equivalent to specifying \scheme{#f} or no convention. equivalent to specifying \scheme{#f} or no convention.
Finally, \var{conv} can be \scheme{__collect_safe} to indicate that garbage
collection is allowed concurrent to a call of the foreign procedure.
Use \scheme{__stdcall} to access most Windows API procedures. Use \scheme{__stdcall} to access most Windows API procedures.
Use \scheme{__cdecl} for Windows API varargs procedures, Use \scheme{__cdecl} for Windows API varargs procedures,
@ -250,7 +251,37 @@ encapsulated within the COM instance passed as the first argument,
with the second argument being a double float and the return with the second argument being a double float and the return
value being an integer. value being an integer.
Complete type checking and conversion is performed on the parameters. Use \scheme{__collect_safe} to declare that garbage collection is
allowed concurrent to the foreign procedure. The
\scheme{__collect_safe} declaration allows concurrent collection by
deactivating the current thread (see \scheme{fork-thread}) when the
foreign procedure is called, and the thread is activated again when
the foreign procedure returns. The \scheme{__collect_safe} declaration
is useful, for example, when calling a blocking I/O call to allow
other Scheme threads to run normally. Refrain from passing collectable memory to a
\scheme{__collect_safe} foreign procedure, or use \scheme{lock-object}
to lock the memory in place; see also \scheme{Sdeactivate_thread}. The
\scheme{__collect_safe} declaration has no effect on a non-threaded
version of the system.
For example, calling the C \scheme{sleep} function with the default
convention will block other Scheme threads from performing a garbage
collection, but adding the \scheme{__collect_safe} declaration avoids that
problem:
\schemedisplay
(define c-sleep (foreign-procedure __collect_safe "sleep" (unsigned) unsigned))
(c-sleep 10) \var{; sleeps for 10 seconds without blocking other threads}
\endschemedisplay
\noindent
If a foreign procedure that is called with \scheme{__collect_safe} can
invoke callables, then each callable should also be declared with
\scheme{__collect_safe} so that the callable reactivates the thread.
Complete type checking and conversion is performed on the parameters
to a foreign procedure.
The types The types
\index{\scheme{scheme-object}}\scheme{scheme-object}, \index{\scheme{scheme-object}}\scheme{scheme-object},
\index{\scheme{string}}\scheme{string}, \index{\scheme{string}}\scheme{string},
@ -266,14 +297,29 @@ and
\index{\scheme{utf-32be}}\scheme{utf-32be}, \index{\scheme{utf-32be}}\scheme{utf-32be},
must be used with caution, however, since they allow allocated must be used with caution, however, since they allow allocated
Scheme objects to be used in places the Scheme memory management system Scheme objects to be used in places the Scheme memory management system
cannot control. cannot control. No problems will arise as long as such objects are not
No problems will arise as long as such objects are not retained in foreign variables or data structures while Scheme code is running,
retained in and as long as they are not passed as arguments to a \scheme{__collect_safe} procedure,
foreign variables or data structures while Scheme code is running, since garbage collection can occur only while Scheme code is running
since garbage collection can occur only while Scheme code is running. or when concurrent garbage collection is enabled.
All other parameter types are converted to equivalent foreign Other parameter types are converted to equivalent foreign
representations and consequently can be retained indefinitely in representations and consequently they can be retained indefinitely in
foreign variables and data structures. foreign variables and data structures.
For argument types \scheme{string}, \scheme{wstring},
\index{\scheme{utf-8}}\scheme{utf-8},
\index{\scheme{utf-16le}}\scheme{utf-16le},
\index{\scheme{utf-16be}}\scheme{utf-16be},
\index{\scheme{utf-32le}}\scheme{utf-32le}, and
\index{\scheme{utf-32be}}\scheme{utf-32be}, an argument is converted
to a fresh object that is passed to the foreign procedure. Since the
fresh object is not accessible for locking before the call, it can
never be treated correctly for a \scheme{__collect_safe} foreign
procedure, so those types are disallowed as argument types for
a \scheme{__collect_safe} foreign procedure. For analogous reasons,
those types are disallowed as the result of a \scheme{__collect_safe}
foreign callable.
Following are the valid parameter types: Following are the valid parameter types:
\foreigntype{\scheme{integer-8}} \foreigntype{\scheme{integer-8}}
@ -509,8 +555,9 @@ with an added null byte, and the address of the first byte of the
bytevector is passed to C. bytevector is passed to C.
The bytevector should not be retained in foreign variables or data The bytevector should not be retained in foreign variables or data
structures, since the memory management system may relocate or discard structures, since the memory management system may relocate or discard
them between foreign procedure calls, and use their storage for some them between foreign procedure calls and use their storage for some
other purpose. other purpose. The \scheme{utf-8} argument type is not allowed for a
\scheme{__collect_safe} foreign procedure.
\foreigntype{\scheme{utf-16le}} \foreigntype{\scheme{utf-16le}}
\index{\scheme{utf-16le}}Arguments of this type are treated like arguments \index{\scheme{utf-16le}}Arguments of this type are treated like arguments
@ -976,8 +1023,7 @@ function ftype (Section~\ref{SECTFOREIGNDATA}).
%---------------------------------------------------------------------------- %----------------------------------------------------------------------------
\entryheader \entryheader
\formdef{foreign-callable}{\categorysyntax}{(foreign-callable \var{proc-exp} (\var{param-type} \dots) \var{res-type})} \formdef{foreign-callable}{\categorysyntax}{(foreign-callable \var{conv} \dots \var{proc-exp} (\var{param-type} \dots) \var{res-type})}
\formdef{foreign-procedure}{\categorysyntax}{(foreign-callable \var{conv} \var{proc-exp} (\var{param-type} \dots) \var{res-type})}
\returns a code object \returns a code object
\listlibraries \listlibraries
\endentryheader \endentryheader
@ -1002,9 +1048,16 @@ since the parameter
values are provided by the foreign code and must be assumed to be values are provided by the foreign code and must be assumed to be
correct. correct.
If \var{conv} is present, it specifies the calling convention to be used. Each \var{conv} adjusts the calling convention to be used.
\scheme{foreign-callable} supports the same conventions as \scheme{foreign-callable} supports the same conventions as
\scheme{foreign-procedure} with the exception of \scheme{__com}. \scheme{foreign-procedure} with the exception of \scheme{__com}.
The \scheme{__collect_safe} convention for a callable activates a
calling thread if the thread is not already activated, and
the thread's activation state is reverted when the callable
returns. If a calling thread is not currently registered with
the Scheme system, then reverting the thread's activation state implies
destroying the thread's registration (see \scheme{Sdestroy_thread}).
The value produced by \scheme{foreign-callable} is a Scheme code object, The value produced by \scheme{foreign-callable} is a Scheme code object,
which contains some header information as well as code that performs which contains some header information as well as code that performs
@ -1092,7 +1145,7 @@ Interfaces to these functions may be defined in Scheme as follows.
(define register-callback (define register-callback
(foreign-procedure "register_callback" (char void*) void)) (foreign-procedure "register_callback" (char void*) void))
(define event-loop (define event-loop
(foreign-procedure "event_loop" () void)) (foreign-procedure __collect_safe "event_loop" () void))
\endschemedisplay \endschemedisplay
\noindent \noindent
@ -1101,7 +1154,7 @@ A callback for selected characters can then be defined.
\schemedisplay \schemedisplay
(define callback (define callback
(lambda (p) (lambda (p)
(let ([code (foreign-callable p (char) void)]) (let ([code (foreign-callable __collect_safe p (char) void)])
(lock-object code) (lock-object code)
(foreign-callable-entry-point code)))) (foreign-callable-entry-point code))))
(define ouch (define ouch
@ -1135,7 +1188,10 @@ Ouch! Hit by 'e'
\endschemedisplay \endschemedisplay
\noindent \noindent
A more well-behaved version of this example would save each code object The \scheme{__collect_safe} declarations in this example ensure that
other threads can continue working while \scheme{event-loop}
blocks waiting for input.
A more well-behaved version of the example would save each code object
returned by \scheme{foreign-callable} and unlock it when it is no longer returned by \scheme{foreign-callable} and unlock it when it is no longer
registered as a callback. registered as a callback.
@ -1440,8 +1496,7 @@ An \var{ftype} must take one of the following forms:
(array \var{length} \var{ftype}) (array \var{length} \var{ftype})
(* \var{ftype}) (* \var{ftype})
(bits (\var{field-name} \var{signedness} \var{bits}) \dots) (bits (\var{field-name} \var{signedness} \var{bits}) \dots)
(function (\var{ftype} \dots) \var{ftype}) (function \var{conv} \dots (\var{ftype} \dots) \var{ftype})
(function \var{conv} (\var{ftype} \dots) \var{ftype})
(packed \var{ftype}) (packed \var{ftype})
(unpacked \var{ftype}) (unpacked \var{ftype})
(endian \var{endianness} \var{ftype}) (endian \var{endianness} \var{ftype})
@ -3431,15 +3486,17 @@ in the active state and need not be activated.
Any thread that has been deactivated, and any Any thread that has been deactivated, and any
thread created by some mechanism other than \scheme{fork-thread} must, thread created by some mechanism other than \scheme{fork-thread} must,
however, be activated before before it can access Scheme data or execute however, be activated before before it can access Scheme data or execute
Scheme code. Scheme code. A foreign callable that is declared with \scheme{__collect_safe}
\scheme{Sactivate_thread} is used for this purpose. can activate a calling thread.
Otherwise, \scheme{Sactivate_thread} must be used to activate a thread.
It returns 1 the first time the thread is activated and 0 on each It returns 1 the first time the thread is activated and 0 on each
subsequent call. subsequent call until the activation is destroyed with \scheme{Sdestroy_thread}.
Since active threads operating in C code prevent the storage management Since active threads operating in C code prevent the storage management
system from garbage collecting, system from garbage collecting,
a thread should be deactivated via \scheme{Sdeactivate_thread} whenever a thread should be deactivated via \scheme{Sdeactivate_thread} or
it may spend a significant amount of time in C code. through a \scheme{foreign-procedure} \scheme{__collect_safe} declaration whenever
the thread may spend a significant amount of time in C code.
This is especially important whenever the thread calls a C library This is especially important whenever the thread calls a C library
function, like \scheme{read}, that may block indefinitely. function, like \scheme{read}, that may block indefinitely.
Once deactivated, the thread must not touch any Scheme data or Once deactivated, the thread must not touch any Scheme data or

2
mats/Mf-ta6fb
View File

@ -21,7 +21,7 @@ fobj = foreign1.so
include Mf-base include Mf-base
foreign1.so: ${fsrc} ../boot/$m/scheme.h foreign1.so: ${fsrc} ../boot/$m/scheme.h
cc -fPIC -shared -I${Include} -o foreign1.so ${fsrc} cc -pthread -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
cat_flush: cat_flush.c cat_flush: cat_flush.c
cc -o cat_flush cat_flush.c cc -o cat_flush cat_flush.c

2
mats/Mf-ta6le
View File

@ -21,7 +21,7 @@ fobj = foreign1.so
include Mf-base include Mf-base
foreign1.so: ${fsrc} ../boot/$m/scheme.h foreign1.so: ${fsrc} ../boot/$m/scheme.h
cc -m64 -fPIC -shared -I${Include} -o foreign1.so ${fsrc} cc -m64 -pthread -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
cat_flush: cat_flush.c cat_flush: cat_flush.c
cc -o cat_flush cat_flush.c cc -o cat_flush cat_flush.c

2
mats/Mf-ta6nb
View File

@ -21,7 +21,7 @@ fobj = foreign1.so
include Mf-base include Mf-base
foreign1.so: ${fsrc} ../boot/$m/scheme.h foreign1.so: ${fsrc} ../boot/$m/scheme.h
cc -fPIC -shared -I${Include} -o foreign1.so ${fsrc} cc -pthread -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
cat_flush: cat_flush.c cat_flush: cat_flush.c
cc -o cat_flush cat_flush.c cc -o cat_flush cat_flush.c

2
mats/Mf-ta6ob
View File

@ -21,7 +21,7 @@ fobj = foreign1.so
include Mf-base include Mf-base
foreign1.so: ${fsrc} ../boot/$m/scheme.h foreign1.so: ${fsrc} ../boot/$m/scheme.h
cc -fPIC -shared -I${Include} -o foreign1.so ${fsrc} cc -pthread -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
cat_flush: cat_flush.c cat_flush: cat_flush.c
cc -o cat_flush cat_flush.c cc -o cat_flush cat_flush.c

2
mats/Mf-ta6osx
View File

@ -21,7 +21,7 @@ fobj = foreign1.so
include Mf-base include Mf-base
foreign1.so: ${fsrc} ../boot/$m/scheme.h foreign1.so: ${fsrc} ../boot/$m/scheme.h
cc -m64 -dynamiclib -undefined dynamic_lookup -I${Include} -o foreign1.so ${fsrc} cc -m64 -pthread -dynamiclib -undefined dynamic_lookup -I${Include} -o foreign1.so ${fsrc}
cat_flush: cat_flush.c cat_flush: cat_flush.c
cc -o cat_flush cat_flush.c cc -o cat_flush cat_flush.c

2
mats/Mf-ta6s2
View File

@ -21,7 +21,7 @@ fobj = foreign1.so
include Mf-base include Mf-base
foreign1.so: ${fsrc} ../boot/$m/scheme.h foreign1.so: ${fsrc} ../boot/$m/scheme.h
gcc -m64 -fPIC -shared -I${Include} -o foreign1.so ${fsrc} gcc -m64 -D_REENTRANT -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
cat_flush: cat_flush.c cat_flush: cat_flush.c
gcc -o cat_flush cat_flush.c gcc -o cat_flush cat_flush.c

2
mats/Mf-ti3fb
View File

@ -21,7 +21,7 @@ fobj = foreign1.so
include Mf-base include Mf-base
foreign1.so: ${fsrc} ../boot/$m/scheme.h foreign1.so: ${fsrc} ../boot/$m/scheme.h
cc -fPIC -shared -I${Include} -o foreign1.so ${fsrc} cc -pthread -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
cat_flush: cat_flush.c cat_flush: cat_flush.c
cc -o cat_flush cat_flush.c cc -o cat_flush cat_flush.c

2
mats/Mf-ti3le
View File

@ -21,7 +21,7 @@ fobj = foreign1.so
include Mf-base include Mf-base
foreign1.so: ${fsrc} ../boot/$m/scheme.h foreign1.so: ${fsrc} ../boot/$m/scheme.h
cc -m32 -fPIC -shared -I${Include} -o foreign1.so ${fsrc} cc -m32 -pthread -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
cat_flush: cat_flush.c cat_flush: cat_flush.c
cc -o cat_flush cat_flush.c cc -o cat_flush cat_flush.c

2
mats/Mf-ti3nb
View File

@ -21,7 +21,7 @@ fobj = foreign1.so
include Mf-base include Mf-base
foreign1.so: ${fsrc} ../boot/$m/scheme.h foreign1.so: ${fsrc} ../boot/$m/scheme.h
cc -fPIC -shared -I${Include} -o foreign1.so ${fsrc} cc -pthread -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
cat_flush: cat_flush.c cat_flush: cat_flush.c
cc -o cat_flush cat_flush.c cc -o cat_flush cat_flush.c

2
mats/Mf-ti3ob
View File

@ -21,7 +21,7 @@ fobj = foreign1.so
include Mf-base include Mf-base
foreign1.so: ${fsrc} ../boot/$m/scheme.h foreign1.so: ${fsrc} ../boot/$m/scheme.h
cc -fPIC -shared -I${Include} -o foreign1.so ${fsrc} cc -pthread -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
cat_flush: cat_flush.c cat_flush: cat_flush.c
cc -o cat_flush cat_flush.c cc -o cat_flush cat_flush.c

2
mats/Mf-ti3osx
View File

@ -21,7 +21,7 @@ fobj = foreign1.so
include Mf-base include Mf-base
foreign1.so: ${fsrc} ../boot/$m/scheme.h foreign1.so: ${fsrc} ../boot/$m/scheme.h
cc -m32 -dynamiclib -undefined dynamic_lookup -I${Include} -o foreign1.so ${fsrc} cc -m32 -pthread -dynamiclib -undefined dynamic_lookup -I${Include} -o foreign1.so ${fsrc}
cat_flush: cat_flush.c cat_flush: cat_flush.c
cc -o cat_flush cat_flush.c cc -o cat_flush cat_flush.c

2
mats/Mf-ti3s2
View File

@ -21,7 +21,7 @@ fobj = foreign1.so
include Mf-base include Mf-base
foreign1.so: ${fsrc} ../boot/$m/scheme.h foreign1.so: ${fsrc} ../boot/$m/scheme.h
gcc -m32 -fPIC -shared -I${Include} -o foreign1.so ${fsrc} gcc -m32 -D_REENTRANT -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
cat_flush: cat_flush.c cat_flush: cat_flush.c
gcc -o cat_flush cat_flush.c gcc -o cat_flush cat_flush.c

2
mats/Mf-tppc32le
View File

@ -21,7 +21,7 @@ fobj = foreign1.so
include Mf-base include Mf-base
foreign1.so: ${fsrc} ../boot/$m/scheme.h foreign1.so: ${fsrc} ../boot/$m/scheme.h
cc -m32 -fPIC -shared -I${Include} -o foreign1.so ${fsrc} cc -m32 -pthread -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
cat_flush: cat_flush.c cat_flush: cat_flush.c
cc -o cat_flush cat_flush.c cc -o cat_flush cat_flush.c

231
mats/foreign.ms
View File

@ -2682,49 +2682,49 @@
(define-ftype i64 integer-64) (define-ftype i64 integer-64)
(define-syntax check* (define-syntax check*
(syntax-rules () (syntax-rules ()
[(_ T s [vi ...] [T-ref ...] [T-set! ...]) [(_ (conv ...) T s [vi ...] [T-ref ...] [T-set! ...])
(let () (let ()
(define-ftype callback (function ((& T)) double)) (define-ftype callback (function conv ... ((& T)) double))
(define-ftype callback-two (function ((& T) (& T)) double)) (define-ftype callback-two (function conv ... ((& T) (& T)) double))
(define-ftype pre-int-callback (function (int (& T)) double)) (define-ftype pre-int-callback (function conv ... (int (& T)) double))
(define-ftype pre-double-callback (function (double (& T)) double)) (define-ftype pre-double-callback (function conv ... (double (& T)) double))
(define-ftype callback-r (function () (& T))) (define-ftype callback-r (function conv ... () (& T)))
(define get (foreign-procedure (format "f4_get~a" s) (define get (foreign-procedure conv ... (format "f4_get~a" s)
() (& T))) () (& T)))
(define sum (foreign-procedure (format "f4_sum~a" s) (define sum (foreign-procedure conv ... (format "f4_sum~a" s)
((& T)) double)) ((& T)) double))
(define sum_two (foreign-procedure (format "f4_sum_two~a" s) (define sum_two (foreign-procedure conv ... (format "f4_sum_two~a" s)
((& T) (& T)) double)) ((& T) (& T)) double))
(define sum_pre_int (foreign-procedure (format "f4_sum_pre_int~a" s) (define sum_pre_int (foreign-procedure conv ... (format "f4_sum_pre_int~a" s)
(int (& T)) double)) (int (& T)) double))
(define sum_pre_int_int (foreign-procedure (format "f4_sum_pre_int_int~a" s) (define sum_pre_int_int (foreign-procedure conv ... (format "f4_sum_pre_int_int~a" s)
(int int (& T)) double)) (int int (& T)) double))
(define sum_pre_int_int_int_int (foreign-procedure (format "f4_sum_pre_int_int_int_int~a" s) (define sum_pre_int_int_int_int (foreign-procedure conv ... (format "f4_sum_pre_int_int_int_int~a" s)
(int int int int (& T)) double)) (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) (define sum_pre_int_int_int_int_int_int (foreign-procedure conv ... (format "f4_sum_pre_int_int_int_int_int_int~a" s)
(int int int int int int (& T)) double)) (int int int int int int (& T)) double))
(define sum_post_int (foreign-procedure (format "f4_sum~a_post_int" s) (define sum_post_int (foreign-procedure conv ... (format "f4_sum~a_post_int" s)
((& T) int) double)) ((& T) int) double))
(define sum_pre_double (foreign-procedure (format "f4_sum_pre_double~a" s) (define sum_pre_double (foreign-procedure conv ... (format "f4_sum_pre_double~a" s)
(double (& T)) double)) (double (& T)) double))
(define sum_pre_double_double (foreign-procedure (format "f4_sum_pre_double_double~a" s) (define sum_pre_double_double (foreign-procedure conv ... (format "f4_sum_pre_double_double~a" s)
(double double (& T)) double)) (double double (& T)) double))
(define sum_pre_double_double_double_double (foreign-procedure (format "f4_sum_pre_double_double_double_double~a" s) (define sum_pre_double_double_double_double (foreign-procedure conv ... (format "f4_sum_pre_double_double_double_double~a" s)
(double double double double (& T)) double)) (double double double double (& T)) double))
(define sum_pre_double_double_double_double_double_double_double_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) (foreign-procedure conv ... (format "f4_sum_pre_double_double_double_double_double_double_double_double~a" s)
(double double double double double double double double (& T)) double)) (double double double double double double double double (& T)) double))
(define sum_post_double (foreign-procedure (format "f4_sum~a_post_double" s) (define sum_post_double (foreign-procedure conv ... (format "f4_sum~a_post_double" s)
((& T) double) double)) ((& T) double) double))
(define cb_send (foreign-procedure (format "f4_cb_send~a" s) (define cb_send (foreign-procedure conv ... (format "f4_cb_send~a" s)
((* callback)) double)) ((* callback)) double))
(define cb_send_two (foreign-procedure (format "f4_cb_send_two~a" s) (define cb_send_two (foreign-procedure conv ... (format "f4_cb_send_two~a" s)
((* callback-two)) double)) ((* callback-two)) double))
(define cb_send_pre_int (foreign-procedure (format "f4_cb_send_pre_int~a" s) (define cb_send_pre_int (foreign-procedure conv ... (format "f4_cb_send_pre_int~a" s)
((* pre-int-callback)) double)) ((* pre-int-callback)) double))
(define cb_send_pre_double (foreign-procedure (format "f4_cb_send_pre_double~a" s) (define cb_send_pre_double (foreign-procedure conv ... (format "f4_cb_send_pre_double~a" s)
((* pre-double-callback)) double)) ((* pre-double-callback)) double))
(define sum_cb (foreign-procedure (format "f4_sum_cb~a" s) (define sum_cb (foreign-procedure conv ... (format "f4_sum_cb~a" s)
((* callback-r)) double)) ((* callback-r)) double))
(define-syntax with-callback (define-syntax with-callback
(syntax-rules () (syntax-rules ()
@ -2788,6 +2788,11 @@
(begin (begin
(free_at_boundary (ftype-pointer-address a)) (free_at_boundary (ftype-pointer-address a))
#t)))))])) #t)))))]))
(define-syntax check*t
(syntax-rules ()
[(_ arg ...)
(and (check* () arg ...)
(check* (__collect_safe) arg ...))]))
(define-syntax check-n (define-syntax check-n
(syntax-rules () (syntax-rules ()
[(_ [ni ti vi] ...) [(_ [ni ti vi] ...)
@ -2800,17 +2805,17 @@
[(null? l) '()] [(null? l) '()]
[else (cons (format "_~a" (car l)) [else (cons (format "_~a" (car l))
(loop (cdr l)))])))) (loop (cdr l)))]))))
(check* T s (check*t T s
[vi ...] [vi ...]
[(lambda (a) (ftype-ref T (ni) a)) ...] [(lambda (a) (ftype-ref T (ni) a)) ...]
[(lambda (a) (ftype-set! T (ni) a vi)) ...]))])) [(lambda (a) (ftype-set! T (ni) a vi)) ...]))]))
(define-syntax check (define-syntax check
(syntax-rules () (syntax-rules ()
[(_ t1 v1) [(_ t1 v1)
(check* t1 (format "_~a" 't1) (check*t t1 (format "_~a" 't1)
[v1] [v1]
[(lambda (a) (ftype-ref t1 () a))] [(lambda (a) (ftype-ref t1 () a))]
[(lambda (a) (ftype-set! t1 () a v1))])])) [(lambda (a) (ftype-set! t1 () a v1))])]))
(define-syntax check-union (define-syntax check-union
(syntax-rules () (syntax-rules ()
[(_ [n0 t0 v0] [ni ti vi] ...) [(_ [n0 t0 v0] [ni ti vi] ...)
@ -2823,10 +2828,10 @@
[(null? l) '()] [(null? l) '()]
[else (cons (format "_~a" (car l)) [else (cons (format "_~a" (car l))
(loop (cdr l)))])))) (loop (cdr l)))]))))
(check* T s (check*t T s
[v0] [v0]
[(lambda (a) (ftype-ref T (n0) a))] [(lambda (a) (ftype-ref T (n0) a))]
[(lambda (a) (ftype-set! T (n0) a v0))]))])) [(lambda (a) (ftype-set! T (n0) a v0))]))]))
(define-syntax check-1 (define-syntax check-1
(syntax-rules () (syntax-rules ()
[(_ t1 v1) [(_ t1 v1)
@ -2917,4 +2922,156 @@
(check-union [x int 48] [y int 0]) (check-union [x int 48] [y int 0])
(check-union [x i64 43] [y int 0]) (check-union [x i64 43] [y int 0])
(check-union [x float 58.0] [y int 0]) (check-union [x float 58.0] [y int 0])
(check-union [x double 68.0] [y int 0])) (check-union [x double 68.0] [y int 0])
)
(mat collect-safe
(error? (foreign-procedure __collect_safe "unknown" (utf-8) void))
(error? (foreign-procedure __collect_safe "unknown" (utf-16be) void))
(error? (foreign-procedure __collect_safe "unknown" (utf-16le) void))
(error? (foreign-procedure __collect_safe "unknown" (utf-32be) void))
(error? (foreign-procedure __collect_safe "unknown" (utf-32le) void))
(error? (foreign-procedure __collect_safe "unknown" (string) void))
(error? (foreign-procedure __collect_safe "unknown" (wstring) void))
(error? (foreign-callable __collect_safe (lambda () #f) () utf-8))
(error? (foreign-callable __collect_safe (lambda () #f) () utf-16le))
(error? (foreign-callable __collect_safe (lambda () #f) () utf-16be))
(error? (foreign-callable __collect_safe (lambda () #f) () utf-32le))
(error? (foreign-callable __collect_safe (lambda () #f) () utf-32be))
(error? (foreign-callable __collect_safe (lambda () #f) () string))
(error? (foreign-callable __collect_safe (lambda () #f) () wstring))
(begin
(define-ftype thread-callback-T (function __collect_safe (double) double))
(define (call-with-thread-callback cb-proc proc)
(let ([callback (make-ftype-pointer thread-callback-T cb-proc)])
(let ([r (proc callback)])
(unlock-object
(foreign-callable-code-object
(ftype-pointer-address callback)))
r)))
(define (call-in-unknown-thread-1 proc arg n-times)
;; Baseline implementation that uses the current thread
(let loop ([i 0] [arg arg])
(cond
[(= i n-times) arg]
[else (loop (fx+ i 1) (proc arg))])))
(define call-in-unknown-thread-2
;; Call in the current thread, but through the foreign procedure
(if (and (threaded?)
(foreign-entry? "call_in_unknown_thread"))
(let ([call (foreign-procedure "call_in_unknown_thread"
((* thread-callback-T) double int boolean boolean)
double)])
(lambda (proc arg n-times)
(call-with-thread-callback
proc
(lambda (callback) (call callback arg n-times #f #t)))))
call-in-unknown-thread-1))
(define call-in-unknown-thread-3
;; Call in a truly unknown thread:
(if (and (threaded?)
(foreign-entry? "call_in_unknown_thread"))
(let ([call (foreign-procedure "call_in_unknown_thread"
((* thread-callback-T) double int boolean boolean)
double)])
(lambda (proc arg n-times)
(call-with-thread-callback
proc
(lambda (callback) (call callback arg n-times #t #t)))))
call-in-unknown-thread-1))
(define call-in-unknown-thread-4
;; In an truly unknown thread, but also using `__collect_safe` to
;; deactivate the current thread instead of using `Sdeactivate_thread`
;; within the foreign function:
(if (and (threaded?)
(foreign-entry? "call_in_unknown_thread"))
(let ([call (foreign-procedure __collect_safe "call_in_unknown_thread"
((* thread-callback-T) double int boolean boolean)
double)])
(lambda (proc arg n-times)
(call-with-thread-callback
proc
(lambda (callback) (call callback arg n-times #t #f)))))
call-in-unknown-thread-1))
#t)
;; These tests will pass only if `collect` can run, where `collect`
;; can run only if a single thread is active
(equal? (call-in-unknown-thread-1 (lambda (n) (collect 0) (+ n 1.0)) 3.5 1)
4.5)
(equal? (call-in-unknown-thread-2 (lambda (n) (collect 0) (+ n 1.0)) 3.5 2)
5.5)
(equal? (call-in-unknown-thread-3 (lambda (n) (collect 0) (+ n 1.0)) 3.5 3)
6.5)
(equal? (call-in-unknown-thread-4 (lambda (n) (collect 0) (+ n 1.0)) 3.5 4)
7.5)
(equal? (let loop ([n 10.0])
(call-in-unknown-thread-4
(lambda (n)
(cond
[(zero? n) (collect) 0.5]
[else (+ 1.0 (loop (- n 1.0)))]))
n
1))
10.5)
;; Try to crash a `__collect_safe` foreign-procedure call by moving the
;; return address out from under the foreign procedure. This attempt
;; should fail, because deactivating a thread first locks the
;; current code object.
(or (not (threaded?))
(let ([m (make-mutex)]
[done? #f]
[ok? #t])
(define object->addr
(foreign-procedure "(cs)fxmul"
(scheme-object uptr)
uptr))
(fork-thread (lambda ()
(let loop ([i 10])
(unless (zero? i)
(let ([spin (eval '(foreign-procedure __collect_safe "spin_a_while" (int unsigned unsigned) unsigned))])
(spin 1000000 0 1))
(loop (sub1 i))))
(mutex-acquire m)
(set! done? #t)
(mutex-release m)))
(let loop ()
(mutex-acquire m)
(let ([done? done?])
(mutex-release m)
(unless done?
(let loop ([i 10])
(unless (zero? i)
(eval '(foreign-procedure "spin_a_while" () void))
(loop (sub1 i))))
(loop))))
ok?))
)
(machine-case
[(i3nt ti3nt)
(mat i3nt-stdcall-collect-safe
(equal?
(let ()
(define sum (foreign-procedure __collect_safe __stdcall "_sum_stdcall@8" (int int) int))
(sum 3 7))
10)
(equal?
(let ()
(define Sinvoke2
(foreign-procedure __collect_safe "Sinvoke2_stdcall"
(scheme-object scheme-object iptr)
scheme-object))
(define Fcons
(foreign-callable __collect_safe __stdcall
(lambda (x y) (cons x y))
(scheme-object iptr)
scheme-object))
(Sinvoke2 Fcons 41 51))
'(41 . 51)))
(mat i3nt-com-thread
(eqv?
(let ()
(define com-instance ((foreign-procedure "get_com_instance" () iptr)))
((foreign-procedure __collect_safe __com 0 (iptr int) int) com-instance 3)
((foreign-procedure __collect_safe __com 4 (iptr int) int) com-instance 17))
37))])

4
mats/foreign3.c
View File

@ -178,6 +178,10 @@ EXPORT char Srvtest_char(ptr code, ptr x1) {
} }
#ifdef WIN32 #ifdef WIN32
EXPORT int __stdcall sum_stdcall(int a, int b) {
return a + b;
}
EXPORT ptr Sinvoke2_stdcall(ptr code, ptr x1, iptr x2) { EXPORT ptr Sinvoke2_stdcall(ptr code, ptr x1, iptr x2) {
return (*((ptr (__stdcall *) PROTO((ptr, iptr)))Sforeign_callable_entry_point(code)))(x1, x2); return (*((ptr (__stdcall *) PROTO((ptr, iptr)))Sforeign_callable_entry_point(code)))(x1, x2);
} }

84
mats/foreign4.c
View File

@ -17,6 +17,18 @@
#include <stdio.h> #include <stdio.h>
#include <stdlib.h> #include <stdlib.h>
#if defined(_REENTRANT) || defined(_WIN32)
# ifdef _WIN32
# include <Windows.h>
# define SCHEME_IMPORT
# include "scheme.h"
# else
# include <pthread.h>
# include "scheme.h"
# endif
# undef EXPORT
#endif
typedef signed char i8; typedef signed char i8;
typedef unsigned char u8; typedef unsigned char u8;
typedef unsigned short u16; typedef unsigned short u16;
@ -63,6 +75,78 @@ EXPORT void free_at_boundary(void *p)
} }
#endif #endif
#if defined(_REENTRANT) || defined(_WIN32)
typedef struct in_thread_args_t {
double (*proc)(double arg);
double arg;
int n_times;
} in_thread_args_t;
void *in_thread(void *_proc_and_arg)
{
in_thread_args_t *proc_and_arg = _proc_and_arg;
int i;
for (i = 0; i < proc_and_arg->n_times; i++) {
proc_and_arg->arg = proc_and_arg->proc(proc_and_arg->arg);
}
return NULL;
}
#if defined(_WIN32)
# define os_thread_t unsigned
# define os_thread_create(addr, proc, arg) (((*(addr)) = _beginthread(proc, 0, arg)) == -1)
# define os_thread_join(t) WaitForSingleObject((HANDLE)(intptr_t)(t), INFINITE)
#else
# define os_thread_t pthread_t
# define os_thread_create(addr, proc, arg) pthread_create(addr, NULL, in_thread, proc_and_arg)
# define os_thread_join(t) pthread_join(t, NULL)
#endif
EXPORT double call_in_unknown_thread(double (*proc)(double arg), double arg, int n_times,
int do_fork, int do_deactivate) {
os_thread_t t;
in_thread_args_t *proc_and_arg = malloc(sizeof(in_thread_args_t));
proc_and_arg->proc = proc;
proc_and_arg->arg = arg;
proc_and_arg->n_times = n_times;
if (do_fork) {
if (!os_thread_create(&t, in_thread, proc_and_arg)) {
if (do_deactivate)
Sdeactivate_thread();
os_thread_join(t);
if (do_deactivate)
Sactivate_thread();
}
} else {
in_thread(proc_and_arg);
}
arg = proc_and_arg->arg;
free(proc_and_arg);
return arg;
}
#endif
EXPORT unsigned spin_a_while(int amt, unsigned a, unsigned b)
{
int i;
/* A loop that the compiler is unlikely to optimize away */
for (i = 0; i < amt; i++) {
a = a + 1;
b = b + a;
}
return a;
}
#define GEN(ts, init, sum) \ #define GEN(ts, init, sum) \
EXPORT ts f4_get_ ## ts () { \ EXPORT ts f4_get_ ## ts () { \
ts r = init; \ ts r = init; \

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

@ -9492,6 +9492,20 @@ foreign.mo:Expected error in mat foreign-ftype: "unexpected function ftype name
foreign.mo:Expected error in mat foreign-callable: "foreign-callable: spam is not a procedure". foreign.mo:Expected error in mat foreign-callable: "foreign-callable: spam is not a procedure".
foreign.mo:Expected error in mat foreign-callable: "foreign-callable: spam is not a procedure". foreign.mo:Expected error in mat foreign-callable: "foreign-callable: spam is not a procedure".
foreign.mo:Expected error in mat foreign-callable: "foreign-callable: spam is not a procedure". foreign.mo:Expected error in mat foreign-callable: "foreign-callable: spam is not a procedure".
foreign.mo:Expected error in mat collect-safe: "foreign-procedure: string argument not allowed with __collect_safe procedure".
foreign.mo:Expected error in mat collect-safe: "foreign-procedure: string argument not allowed with __collect_safe procedure".
foreign.mo:Expected error in mat collect-safe: "foreign-procedure: string argument not allowed with __collect_safe procedure".
foreign.mo:Expected error in mat collect-safe: "foreign-procedure: string argument not allowed with __collect_safe procedure".
foreign.mo:Expected error in mat collect-safe: "foreign-procedure: string argument not allowed with __collect_safe procedure".
foreign.mo:Expected error in mat collect-safe: "foreign-procedure: string argument not allowed with __collect_safe procedure".
foreign.mo:Expected error in mat collect-safe: "foreign-procedure: string argument not allowed with __collect_safe procedure".
foreign.mo:Expected error in mat collect-safe: "foreign-callable: string result not allowed with __collect_safe callable".
foreign.mo:Expected error in mat collect-safe: "foreign-callable: string result not allowed with __collect_safe callable".
foreign.mo:Expected error in mat collect-safe: "foreign-callable: string result not allowed with __collect_safe callable".
foreign.mo:Expected error in mat collect-safe: "foreign-callable: string result not allowed with __collect_safe callable".
foreign.mo:Expected error in mat collect-safe: "foreign-callable: string result not allowed with __collect_safe callable".
foreign.mo:Expected error in mat collect-safe: "foreign-callable: string result not allowed with __collect_safe callable".
foreign.mo:Expected error in mat collect-safe: "foreign-callable: string result not allowed with __collect_safe callable".
ftype.mo:Expected error in mat ftype: "unexpected function ftype outside pointer field (function #f (int) int)". ftype.mo:Expected error in mat ftype: "unexpected function ftype outside pointer field (function #f (int) int)".
ftype.mo:Expected error in mat ftype: "unexpected function ftype outside pointer field (function #f (int) int)". ftype.mo:Expected error in mat ftype: "unexpected function ftype outside pointer field (function #f (int) int)".
ftype.mo:Expected error in mat ftype: "unexpected function ftype outside pointer field (function #f (int) int)". ftype.mo:Expected error in mat ftype: "unexpected function ftype outside pointer field (function #f (int) int)".

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

@ -9492,6 +9492,20 @@ foreign.mo:Expected error in mat foreign-ftype: "unexpected function ftype name
foreign.mo:Expected error in mat foreign-callable: "foreign-callable: spam is not a procedure". foreign.mo:Expected error in mat foreign-callable: "foreign-callable: spam is not a procedure".
foreign.mo:Expected error in mat foreign-callable: "foreign-callable: spam is not a procedure". foreign.mo:Expected error in mat foreign-callable: "foreign-callable: spam is not a procedure".
foreign.mo:Expected error in mat foreign-callable: "foreign-callable: spam is not a procedure". foreign.mo:Expected error in mat foreign-callable: "foreign-callable: spam is not a procedure".
foreign.mo:Expected error in mat collect-safe: "foreign-procedure: string argument not allowed with __collect_safe procedure".
foreign.mo:Expected error in mat collect-safe: "foreign-procedure: string argument not allowed with __collect_safe procedure".
foreign.mo:Expected error in mat collect-safe: "foreign-procedure: string argument not allowed with __collect_safe procedure".
foreign.mo:Expected error in mat collect-safe: "foreign-procedure: string argument not allowed with __collect_safe procedure".
foreign.mo:Expected error in mat collect-safe: "foreign-procedure: string argument not allowed with __collect_safe procedure".
foreign.mo:Expected error in mat collect-safe: "foreign-procedure: string argument not allowed with __collect_safe procedure".
foreign.mo:Expected error in mat collect-safe: "foreign-procedure: string argument not allowed with __collect_safe procedure".
foreign.mo:Expected error in mat collect-safe: "foreign-callable: string result not allowed with __collect_safe callable".
foreign.mo:Expected error in mat collect-safe: "foreign-callable: string result not allowed with __collect_safe callable".
foreign.mo:Expected error in mat collect-safe: "foreign-callable: string result not allowed with __collect_safe callable".
foreign.mo:Expected error in mat collect-safe: "foreign-callable: string result not allowed with __collect_safe callable".
foreign.mo:Expected error in mat collect-safe: "foreign-callable: string result not allowed with __collect_safe callable".
foreign.mo:Expected error in mat collect-safe: "foreign-callable: string result not allowed with __collect_safe callable".
foreign.mo:Expected error in mat collect-safe: "foreign-callable: string result not allowed with __collect_safe callable".
ftype.mo:Expected error in mat ftype: "unexpected function ftype outside pointer field (function #f (int) int)". ftype.mo:Expected error in mat ftype: "unexpected function ftype outside pointer field (function #f (int) int)".
ftype.mo:Expected error in mat ftype: "unexpected function ftype outside pointer field (function #f (int) int)". ftype.mo:Expected error in mat ftype: "unexpected function ftype outside pointer field (function #f (int) int)".
ftype.mo:Expected error in mat ftype: "unexpected function ftype outside pointer field (function #f (int) int)". ftype.mo:Expected error in mat ftype: "unexpected function ftype outside pointer field (function #f (int) int)".

11
release_notes/release_notes.stex
View File

@ -58,6 +58,17 @@ Online versions of both books can be found at
%----------------------------------------------------------------------------- %-----------------------------------------------------------------------------
\section{Functionality Changes}\label{section:functionality} \section{Functionality Changes}\label{section:functionality}
\subsection{Foreign-procedure thread activation (9.5.1)}
A new \scheme{__collect_safe} foreign-procedure convention, which can
be combined with other conventions, causes a foreign-procedure call to
deactive the current thread during the call so that other threads can
perform a garbage collection. Similarly, the \scheme{__collect_safe}
convention modifier for callables causes the current thread to be
activated on entry to the callable, and the activation state is
reverted on exit from the callable; this activation makes callables
work from threads that are otherwise unknown to the Scheme system.
\subsection{Garbage collection and threads (9.5.1)} \subsection{Garbage collection and threads (9.5.1)}
A new \scheme{collect-rendezvous} function performs a garbage A new \scheme{collect-rendezvous} function performs a garbage

8
s/base-lang.ss
View File

@ -155,7 +155,7 @@
(define convention? (define convention?
(lambda (x) (lambda (x)
(or (eq? x #f) (symbol? x)))) (symbol? x)))
(define-record-type preinfo (define-record-type preinfo
(nongenerative #{preinfo e23pkvo5btgapnzomqgegm-2}) (nongenerative #{preinfo e23pkvo5btgapnzomqgegm-2})
@ -211,7 +211,7 @@
; source language used by the passes leading up to the compiler or interpreter ; source language used by the passes leading up to the compiler or interpreter
(define-language Lsrc (define-language Lsrc
(nongenerative-id #{Lsrc czsa1fcfzdeh493n-2}) (nongenerative-id #{Lsrc czsa1fcfzdeh493n-3})
(terminals (terminals
(preinfo (preinfo)) (preinfo (preinfo))
($prelex (x)) ($prelex (x))
@ -248,8 +248,8 @@
(record-ref rtd type index e) (record-ref rtd type index e)
(record-set! rtd type index e1 e2) (record-set! rtd type index e1 e2)
(cte-optimization-loc box e) (cte-optimization-loc box e)
(foreign conv name e (arg-type* ...) result-type) (foreign (conv* ...) name e (arg-type* ...) result-type)
(fcallable conv e (arg-type* ...) result-type) (fcallable (conv* ...) e (arg-type* ...) result-type)
(profile src) => (profile) (profile src) => (profile)
; used only in cpvalid ; used only in cpvalid
(cpvalid-defer e)) (cpvalid-defer e))

7
s/cmacros.ss
View File

@ -1387,6 +1387,10 @@
(cons (string->symbol (substring str 3 (- n 5))) params) (cons (string->symbol (substring str 3 (- n 5))) params)
params)))))) params))))))
(define-constant unactivate-mode-noop 0)
(define-constant unactivate-mode-deactivate 1)
(define-constant unactivate-mode-destroy 2)
(define-primitive-structure-disps rtd-counts type-typed-object (define-primitive-structure-disps rtd-counts type-typed-object
([iptr type] ([iptr type]
[U64 timestamp] [U64 timestamp]
@ -2624,6 +2628,9 @@
split-and-resize split-and-resize
raw-collect-cond raw-collect-cond
raw-tc-mutex raw-tc-mutex
activate-thread
deactivate-thread
unactivate-thread
handle-values-error handle-values-error
handle-mvlet-error handle-mvlet-error
handle-arg-error handle-arg-error

36
s/cp0.ss
View File

@ -949,13 +949,13 @@
[(record-cd ,rcd ,rtd-expr ,e) (memoize (pure? e))] [(record-cd ,rcd ,rtd-expr ,e) (memoize (pure? e))]
[(letrec ([,x* ,e*] ...) ,body) (memoize (and (andmap pure? e*) (pure? body)))] [(letrec ([,x* ,e*] ...) ,body) (memoize (and (andmap pure? e*) (pure? body)))]
[(record-type ,rtd ,e) (memoize (pure? e))] [(record-type ,rtd ,e) (memoize (pure? e))]
[(foreign ,conv ,name ,e (,arg-type* ...) ,result-type) (memoize (pure? e))] [(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type) (memoize (pure? e))]
[(letrec* ([,x* ,e*] ...) ,body) (memoize (and (andmap pure? e*) (pure? body)))] [(letrec* ([,x* ,e*] ...) ,body) (memoize (and (andmap pure? e*) (pure? body)))]
[(immutable-list (,e* ...) ,e) (memoize (and (andmap pure? e*) (pure? e)))] [(immutable-list (,e* ...) ,e) (memoize (and (andmap pure? e*) (pure? e)))]
[(profile ,src) #t] [(profile ,src) #t]
[(cte-optimization-loc ,box ,e) (memoize (pure? e))] [(cte-optimization-loc ,box ,e) (memoize (pure? e))]
[(moi) #t] [(moi) #t]
[(fcallable ,conv ,e (,arg-type* ...) ,result-type) (memoize (pure? e))] [(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) (memoize (pure? e))]
[(pariah) #t] [(pariah) #t]
[else ($oops who "unrecognized record ~s" e)])))) [else ($oops who "unrecognized record ~s" e)]))))
@ -1008,13 +1008,13 @@
[(record-cd ,rcd ,rtd-expr ,e) (memoize (ivory? e))] [(record-cd ,rcd ,rtd-expr ,e) (memoize (ivory? e))]
[(letrec ([,x* ,e*] ...) ,body) (memoize (and (andmap ivory? e*) (ivory? body)))] [(letrec ([,x* ,e*] ...) ,body) (memoize (and (andmap ivory? e*) (ivory? body)))]
[(record-type ,rtd ,e) (memoize (ivory? e))] [(record-type ,rtd ,e) (memoize (ivory? e))]
[(foreign ,conv ,name ,e (,arg-type* ...) ,result-type) (memoize (ivory? e))] [(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type) (memoize (ivory? e))]
[(letrec* ([,x* ,e*] ...) ,body) (memoize (and (andmap ivory? e*) (ivory? body)))] [(letrec* ([,x* ,e*] ...) ,body) (memoize (and (andmap ivory? e*) (ivory? body)))]
[(immutable-list (,e* ...) ,e) (memoize (and (andmap ivory? e*) (ivory? e)))] [(immutable-list (,e* ...) ,e) (memoize (and (andmap ivory? e*) (ivory? e)))]
[(profile ,src) #t] [(profile ,src) #t]
[(cte-optimization-loc ,box ,e) (memoize (ivory? e))] [(cte-optimization-loc ,box ,e) (memoize (ivory? e))]
[(moi) #t] [(moi) #t]
[(fcallable ,conv ,e (,arg-type* ...) ,result-type) (memoize (ivory? e))] [(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) (memoize (ivory? e))]
[(pariah) #t] [(pariah) #t]
[else ($oops who "unrecognized record ~s" e)])))) [else ($oops who "unrecognized record ~s" e)]))))
@ -1052,14 +1052,14 @@
[(record-cd ,rcd ,rtd-expr ,e) (memoize (simple? e))] [(record-cd ,rcd ,rtd-expr ,e) (memoize (simple? e))]
[(record-ref ,rtd ,type ,index ,e) (memoize (simple? e))] [(record-ref ,rtd ,type ,index ,e) (memoize (simple? e))]
[(record-set! ,rtd ,type ,index ,e1 ,e2) #f] [(record-set! ,rtd ,type ,index ,e1 ,e2) #f]
[(foreign ,conv ,name ,e (,arg-type* ...) ,result-type) (memoize (simple? e))] [(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type) (memoize (simple? e))]
[(record-type ,rtd ,e) (memoize (simple? e))] [(record-type ,rtd ,e) (memoize (simple? e))]
[(record ,rtd ,rtd-expr ,e* ...) (memoize (and (simple? rtd-expr) (andmap simple? e*)))] [(record ,rtd ,rtd-expr ,e* ...) (memoize (and (simple? rtd-expr) (andmap simple? e*)))]
[(pariah) #f] [(pariah) #f]
[(profile ,src) #f] [(profile ,src) #f]
[(cte-optimization-loc ,box ,e) (memoize (simple? e))] [(cte-optimization-loc ,box ,e) (memoize (simple? e))]
[(moi) #t] [(moi) #t]
[(fcallable ,conv ,e (,arg-type* ...) ,result-type) (memoize (simple? e))] [(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) (memoize (simple? e))]
[else ($oops who "unrecognized record ~s" e)])))) [else ($oops who "unrecognized record ~s" e)]))))
(define-who simple/profile? (define-who simple/profile?
@ -1097,14 +1097,14 @@
[(record-cd ,rcd ,rtd-expr ,e) (memoize (simple/profile? e))] [(record-cd ,rcd ,rtd-expr ,e) (memoize (simple/profile? e))]
[(record-ref ,rtd ,type ,index ,e) (memoize (simple/profile? e))] [(record-ref ,rtd ,type ,index ,e) (memoize (simple/profile? e))]
[(record-set! ,rtd ,type ,index ,e1 ,e2) #f] [(record-set! ,rtd ,type ,index ,e1 ,e2) #f]
[(foreign ,conv ,name ,e (,arg-type* ...) ,result-type) (memoize (simple/profile? e))] [(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type) (memoize (simple/profile? e))]
[(record-type ,rtd ,e) (memoize (simple/profile? e))] [(record-type ,rtd ,e) (memoize (simple/profile? e))]
[(record ,rtd ,rtd-expr ,e* ...) (memoize (and (simple/profile? rtd-expr) (andmap simple/profile? e*)))] [(record ,rtd ,rtd-expr ,e* ...) (memoize (and (simple/profile? rtd-expr) (andmap simple/profile? e*)))]
[(pariah) #t] [(pariah) #t]
[(profile ,src) #t] [(profile ,src) #t]
[(cte-optimization-loc ,box ,e) (memoize (simple/profile? e))] [(cte-optimization-loc ,box ,e) (memoize (simple/profile? e))]
[(moi) #t] [(moi) #t]
[(fcallable ,conv ,e (,arg-type* ...) ,result-type) (memoize (simple/profile? e))] [(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) (memoize (simple/profile? e))]
[else ($oops who "unrecognized record ~s" e)])))) [else ($oops who "unrecognized record ~s" e)]))))
(define-who boolean-valued? (define-who boolean-valued?
@ -1137,8 +1137,8 @@
[(profile ,src) #f] [(profile ,src) #f]
[(set! ,maybe-src ,x ,e) #f] [(set! ,maybe-src ,x ,e) #f]
[(moi) #f] [(moi) #f]
[(foreign ,conv ,name ,e (,arg-type* ...) ,result-type) #f] [(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type) #f]
[(fcallable ,conv ,e (,arg-type* ...) ,result-type) #f] [(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) #f]
[(pariah) #f] [(pariah) #f]
[else ($oops who "unrecognized record ~s" e)]))))) [else ($oops who "unrecognized record ~s" e)])))))
@ -2058,8 +2058,8 @@
[(set! ,maybe-src ,x0 ,e0) (list e)] [(set! ,maybe-src ,x0 ,e0) (list e)]
[(case-lambda ,preinfo ,cl* ...) (list e)] [(case-lambda ,preinfo ,cl* ...) (list e)]
[,pr (list e)] [,pr (list e)]
[(foreign ,conv ,name ,e0 (,arg-type* ...) ,result-type) (list e)] [(foreign (,conv* ...) ,name ,e0 (,arg-type* ...) ,result-type) (list e)]
[(fcallable ,conv ,e0 (,arg-type* ...) ,result-type) (list e)] [(fcallable (,conv* ...) ,e0 (,arg-type* ...) ,result-type) (list e)]
[(record-type ,rtd0 ,e0) (list e)] [(record-type ,rtd0 ,e0) (list e)]
[(record-cd ,rcd0 ,rtd-expr0 ,e0) (list e)] [(record-cd ,rcd0 ,rtd-expr0 ,e0) (list e)]
[(immutable-list (,e0* ...) ,e0) (list e)] [(immutable-list (,e0* ...) ,e0) (list e)]
@ -3363,8 +3363,8 @@
(nanopass-case (Lsrc Expr) xres (nanopass-case (Lsrc Expr) xres
[(case-lambda ,preinfo ,cl ...) #t] [(case-lambda ,preinfo ,cl ...) #t]
[,pr (all-set? (prim-mask proc) (primref-flags pr))] [,pr (all-set? (prim-mask proc) (primref-flags pr))]
[(foreign ,conv ,name ,e (,arg-type* ...) ,result-type) #t] [(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type) #t]
[(fcallable ,conv ,e (,arg-type* ...) ,result-type) #t] [(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) #t]
[(record-set! ,rtd ,type ,index ,e1 ,e2) #t] [(record-set! ,rtd ,type ,index ,e1 ,e2) #t]
[(immutable-list (,e* ...) ,e) #t] [(immutable-list (,e* ...) ,e) #t]
[else #f]))) [else #f])))
@ -4609,13 +4609,13 @@
true-rec true-rec
(begin (bump sc 1) pr))] (begin (bump sc 1) pr))]
[(app) (fold-primref pr ctxt sc wd name moi)])] [(app) (fold-primref pr ctxt sc wd name moi)])]
[(foreign ,conv ,name ,e (,arg-type* ...) ,result-type) [(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type)
(context-case ctxt (context-case ctxt
[(value app) (bump sc 1) `(foreign ,conv ,name ,(cp0 e 'value env sc wd #f moi) (,arg-type* ...) ,result-type)] [(value app) (bump sc 1) `(foreign (,conv* ...) ,name ,(cp0 e 'value env sc wd #f moi) (,arg-type* ...) ,result-type)]
[(effect test) (cp0 `(seq ,e ,true-rec) ctxt env sc wd #f moi)])] [(effect test) (cp0 `(seq ,e ,true-rec) ctxt env sc wd #f moi)])]
[(fcallable ,conv ,e (,arg-type* ...) ,result-type) [(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type)
(context-case ctxt (context-case ctxt
[(value app) (bump sc 1) `(fcallable ,conv ,(cp0 e 'value env sc wd #f moi) (,arg-type* ...) ,result-type)] [(value app) (bump sc 1) `(fcallable (,conv* ...) ,(cp0 e 'value env sc wd #f moi) (,arg-type* ...) ,result-type)]
[(effect) (cp0 e 'effect env sc wd #f moi)] [(effect) (cp0 e 'effect env sc wd #f moi)]
[(test) (make-seq ctxt (cp0 e 'effect env sc wd #f moi) true-rec)])] [(test) (make-seq ctxt (cp0 e 'effect env sc wd #f moi) true-rec)])]
[(record ,rtd ,rtd-expr ,e* ...) [(record ,rtd ,rtd-expr ,e* ...)

8
s/cpcheck.ss
View File

@ -130,11 +130,11 @@
[(set! ,maybe-src ,x ,[e #f -> e]) `(set! ,maybe-src ,x ,e)] [(set! ,maybe-src ,x ,[e #f -> e]) `(set! ,maybe-src ,x ,e)]
[(seq ,[e1 #f -> e1] ,[e2]) `(seq ,e1 ,e2)] [(seq ,[e1 #f -> e1] ,[e2]) `(seq ,e1 ,e2)]
[(if ,[e1 #f -> e1] ,[e2 #f -> e2] ,[e3 #f -> e3]) `(if ,e1 ,e2 ,e3)] [(if ,[e1 #f -> e1] ,[e2 #f -> e2] ,[e3 #f -> e3]) `(if ,e1 ,e2 ,e3)]
[(foreign ,conv ,name ,e (,arg-type* ...) ,result-type) [(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type)
(check! ctxt (list (length arg-type*))) (check! ctxt (list (length arg-type*)))
`(foreign ,conv ,name ,(Expr e #f) (,arg-type* ...) ,result-type)] `(foreign (,conv* ...) ,name ,(Expr e #f) (,arg-type* ...) ,result-type)]
[(fcallable ,conv ,[e #f -> e] (,arg-type* ...) ,result-type) [(fcallable (,conv* ...) ,[e #f -> e] (,arg-type* ...) ,result-type)
`(fcallable ,conv ,e (,arg-type* ...) ,result-type)] `(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type)]
[(call ,preinfo0 [(call ,preinfo0
(case-lambda ,preinfo1 (case-lambda ,preinfo1
(clause (,x* ...) ,interface ,body) (clause (,x* ...) ,interface ,body)

24
s/cpcommonize.ss
View File

@ -73,10 +73,10 @@
(values `(seq ,e1 ,e2) (fx+ size1 size2))] (values `(seq ,e1 ,e2) (fx+ size1 size2))]
[(if ,[e1 size1] ,[e2 size2] ,[e3 size3]) [(if ,[e1 size1] ,[e2 size2] ,[e3 size3])
(values `(if ,e1 ,e2 ,e3) (fx+ size1 size2 size3))] (values `(if ,e1 ,e2 ,e3) (fx+ size1 size2 size3))]
[(foreign ,conv ,name ,[e size] (,arg-type* ...) ,result-type) [(foreign (,conv* ...) ,name ,[e size] (,arg-type* ...) ,result-type)
(values `(foreign ,conv ,name ,e (,arg-type* ...) ,result-type) (fx+ 1 size))] (values `(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type) (fx+ 1 size))]
[(fcallable ,conv ,[e size] (,arg-type* ...) ,result-type) [(fcallable (,conv* ...) ,[e size] (,arg-type* ...) ,result-type)
(values `(fcallable ,conv ,e (,arg-type* ...) ,result-type) (fx+ 1 size))] (values `(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) (fx+ 1 size))]
; ($top-level-value 'x) adds just 1 to the size ; ($top-level-value 'x) adds just 1 to the size
[(call ,preinfo ,pr (quote ,d)) [(call ,preinfo ,pr (quote ,d))
(guard (eq? (primref-name pr) '$top-level-value)) (guard (eq? (primref-name pr) '$top-level-value))
@ -379,24 +379,24 @@
(with-env x1* x2* (with-env x1* x2*
`(letrec ([,x1* ,(map f e1* e2*) ,size1*] ...) ,(f body1 body2))))] `(letrec ([,x1* ,(map f e1* e2*) ,size1*] ...) ,(f body1 body2))))]
[else #f])] [else #f])]
[(foreign ,conv1 ,name1 ,e1 (,arg-type1* ...) ,result-type1) [(foreign (,conv1* ...) ,name1 ,e1 (,arg-type1* ...) ,result-type1)
(nanopass-case (Lcommonize1 Expr) e2 (nanopass-case (Lcommonize1 Expr) e2
[(foreign ,conv2 ,name2 ,e2 (,arg-type2* ...) ,result-type2) [(foreign (,conv2* ...) ,name2 ,e2 (,arg-type2* ...) ,result-type2)
(and (eq? conv1 conv2) (and (equal? conv1* conv2*)
(equal? name1 name2) (equal? name1 name2)
(fx= (length arg-type1*) (length arg-type2*)) (fx= (length arg-type1*) (length arg-type2*))
(andmap same-type? arg-type1* arg-type2*) (andmap same-type? arg-type1* arg-type2*)
(same-type? result-type1 result-type2) (same-type? result-type1 result-type2)
`(foreign ,conv1 ,name1 ,(f e1 e2) (,arg-type1* ...) ,result-type1))] `(foreign (,conv1* ...) ,name1 ,(f e1 e2) (,arg-type1* ...) ,result-type1))]
[else #f])] [else #f])]
[(fcallable ,conv1 ,e1 (,arg-type1* ...) ,result-type1) [(fcallable (,conv1* ...) ,e1 (,arg-type1* ...) ,result-type1)
(nanopass-case (Lcommonize1 Expr) e2 (nanopass-case (Lcommonize1 Expr) e2
[(fcallable ,conv2 ,e2 (,arg-type2* ...) ,result-type2) [(fcallable (,conv2* ...) ,e2 (,arg-type2* ...) ,result-type2)
(and (eq? conv1 conv2) (and (equal? conv1* conv2*)
(fx= (length arg-type1*) (length arg-type2*)) (fx= (length arg-type1*) (length arg-type2*))
(andmap same-type? arg-type1* arg-type2*) (andmap same-type? arg-type1* arg-type2*)
(same-type? result-type1 result-type2) (same-type? result-type1 result-type2)
`(fcallable ,conv1 ,(f e1 e2) (,arg-type1* ...) ,result-type1))] `(fcallable (,conv1* ...) ,(f e1 e2) (,arg-type1* ...) ,result-type1))]
[else #f])] [else #f])]
[(cte-optimization-loc ,box1 ,e1) [(cte-optimization-loc ,box1 ,e1)
(nanopass-case (Lcommonize1 Expr) e2 (nanopass-case (Lcommonize1 Expr) e2

8
s/cpletrec.ss
View File

@ -348,11 +348,11 @@ Handling letrec and letrec*
(with-initialized-ids x* (with-initialized-ids x*
(lambda (x*) (lambda (x*)
(cpletrec-letrec #t x* e* body)))] (cpletrec-letrec #t x* e* body)))]
[(foreign ,conv ,name ,[e pure?] (,arg-type* ...) ,result-type) [(foreign (,conv* ...) ,name ,[e pure?] (,arg-type* ...) ,result-type)
(values `(foreign ,conv ,name ,e (,arg-type* ...) ,result-type) (values `(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type)
(and (fx= (optimize-level) 3) pure?))] (and (fx= (optimize-level) 3) pure?))]
[(fcallable ,conv ,[e pure?] (,arg-type* ...) ,result-type) [(fcallable (,conv* ...) ,[e pure?] (,arg-type* ...) ,result-type)
(values `(fcallable ,conv ,e (,arg-type* ...) ,result-type) (values `(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type)
(and (fx= (optimize-level) 3) pure?))] (and (fx= (optimize-level) 3) pure?))]
[(record-ref ,rtd ,type ,index ,[e pure?]) [(record-ref ,rtd ,type ,index ,[e pure?])
(values `(record-ref ,rtd ,type ,index ,e) #f)] (values `(record-ref ,rtd ,type ,index ,e) #f)]

14
s/cpnanopass.ss
View File

@ -940,11 +940,11 @@
(define-record-type info-foreign (nongenerative) (define-record-type info-foreign (nongenerative)
(parent info) (parent info)
(sealed #t) (sealed #t)
(fields conv arg-type* result-type (mutable name)) (fields conv* arg-type* result-type (mutable name))
(protocol (protocol
(lambda (pargs->new) (lambda (pargs->new)
(lambda (conv arg-type* result-type) (lambda (conv* arg-type* result-type)
((pargs->new) conv arg-type* result-type #f))))) ((pargs->new) conv* arg-type* result-type #f)))))
(define-record-type info-literal (nongenerative) (define-record-type info-literal (nongenerative)
(parent info) (parent info)
@ -1045,12 +1045,12 @@
[(call ,preinfo ,e ,[e*] ...) [(call ,preinfo ,e ,[e*] ...)
`(call ,(make-info-call (preinfo-src preinfo) (preinfo-sexpr preinfo) (fx< (optimize-level) 3) #f #f) `(call ,(make-info-call (preinfo-src preinfo) (preinfo-sexpr preinfo) (fx< (optimize-level) 3) #f #f)
,(Expr e) ,e* ...)] ,(Expr e) ,e* ...)]
[(foreign ,conv ,name ,[e] (,arg-type* ...) ,result-type) [(foreign (,conv* ...) ,name ,[e] (,arg-type* ...) ,result-type)
(let ([info (make-info-foreign conv arg-type* result-type)]) (let ([info (make-info-foreign conv* arg-type* result-type)])
(info-foreign-name-set! info name) (info-foreign-name-set! info name)
`(foreign ,info ,e))] `(foreign ,info ,e))]
[(fcallable ,conv ,[e] (,arg-type* ...) ,result-type) [(fcallable (,conv* ...) ,[e] (,arg-type* ...) ,result-type)
`(fcallable ,(make-info-foreign conv arg-type* result-type) ,e)]) `(fcallable ,(make-info-foreign conv* arg-type* result-type) ,e)])
(CaseLambdaExpr ir #f)) (CaseLambdaExpr ir #f))
(define find-matching-clause (define find-matching-clause

21
s/cprep.ss
View File

@ -85,11 +85,14 @@
(uncprep-sequence e2 ls))] (uncprep-sequence e2 ls))]
[else (cons (uncprep x) ls)]))) [else (cons (uncprep x) ls)])))
(define uncprep-fp-conv (define uncprep-fp-conv
(lambda (x) (lambda (x*)
(case x (map (lambda (x)
[(i3nt-stdcall) '__stdcall] (case x
[(i3nt-com) '__com] [(i3nt-stdcall) '__stdcall]
[else #f]))) [(i3nt-com) '__com]
[(adjust-active) '__collect_safe]
[else #f]))
x*)))
(define-who uncprep-fp-specifier (define-who uncprep-fp-specifier
(lambda (x) (lambda (x)
(nanopass-case (Ltype Type) x (nanopass-case (Ltype Type) x
@ -184,12 +187,12 @@
[(letrec* ([,x* ,[e*]] ...) ,body) [(letrec* ([,x* ,[e*]] ...) ,body)
`(letrec* ,(map (lambda (x e) `(,(get-name x) ,e)) x* e*) `(letrec* ,(map (lambda (x e) `(,(get-name x) ,e)) x* e*)
,@(uncprep-sequence body '()))] ,@(uncprep-sequence body '()))]
[(foreign ,conv ,name ,[e] (,arg-type* ...) ,result-type) [(foreign (,conv* ...) ,name ,[e] (,arg-type* ...) ,result-type)
`($foreign-procedure ,(uncprep-fp-conv conv) ,name ,e `($foreign-procedure ,(uncprep-fp-conv conv*) ,name ,e
,(map uncprep-fp-specifier arg-type*) ,(map uncprep-fp-specifier arg-type*)
,(uncprep-fp-specifier result-type))] ,(uncprep-fp-specifier result-type))]
[(fcallable ,conv ,[e] (,arg-type* ...) ,result-type) [(fcallable (,conv* ...) ,[e] (,arg-type* ...) ,result-type)
`($foreign-callable ,(uncprep-fp-conv conv) ,e `($foreign-callable ,(uncprep-fp-conv conv*) ,e
,(map uncprep-fp-specifier arg-type*) ,(map uncprep-fp-specifier arg-type*)
,(uncprep-fp-specifier result-type))] ,(uncprep-fp-specifier result-type))]
[(record-ref ,rtd ,type ,index ,[e]) `(record-ref ,rtd ',type ,e ,index)] [(record-ref ,rtd ,type ,index ,[e]) `(record-ref ,rtd ',type ,e ,index)]

16
s/cpvalid.ss
View File

@ -328,10 +328,10 @@
(let-values ([(e* vals-dl?) (undefer* e* proxy dl?)]) (let-values ([(e* vals-dl?) (undefer* e* proxy dl?)])
(defer-or-not (or body-dl? vals-dl?) (defer-or-not (or body-dl? vals-dl?)
`(letrec* ([,x* ,e*] ...) ,body)))] `(letrec* ([,x* ,e*] ...) ,body)))]
[(foreign ,conv ,name ,[undefer : e dl?] (,arg-type* ...) ,result-type) [(foreign (,conv* ...) ,name ,[undefer : e dl?] (,arg-type* ...) ,result-type)
(defer-or-not dl? `(foreign ,conv ,name ,e (,arg-type* ...) ,result-type))] (defer-or-not dl? `(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type))]
[(fcallable ,conv ,[undefer : e dl?] (,arg-type* ...) ,result-type) [(fcallable (,conv* ...) ,[undefer : e dl?] (,arg-type* ...) ,result-type)
(defer-or-not dl? `(fcallable ,conv ,e (,arg-type* ...) ,result-type))] (defer-or-not dl? `(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type))]
[(cte-optimization-loc ,box ,[undefer : e dl?]) [(cte-optimization-loc ,box ,[undefer : e dl?])
(defer-or-not dl? `(cte-optimization-loc ,box ,e))] (defer-or-not dl? `(cte-optimization-loc ,box ,e))]
[(pariah) (values x #f)] [(pariah) (values x #f)]
@ -547,10 +547,10 @@
(defer-or-not (or dl0? dl1? dl2?) `(if ,e0 ,e1 ,e2))] (defer-or-not (or dl0? dl1? dl2?) `(if ,e0 ,e1 ,e2))]
[(seq ,[cpvalid : e1 dl1?] ,[cpvalid : e2 dl2?]) [(seq ,[cpvalid : e1 dl1?] ,[cpvalid : e2 dl2?])
(defer-or-not (or dl1? dl2?) `(seq ,e1 ,e2))] (defer-or-not (or dl1? dl2?) `(seq ,e1 ,e2))]
[(foreign ,conv ,name ,[cpvalid : e dl?] (,arg-type* ...) ,result-type) [(foreign (,conv* ...) ,name ,[cpvalid : e dl?] (,arg-type* ...) ,result-type)
(defer-or-not dl? `(foreign ,conv ,name ,e (,arg-type* ...) ,result-type))] (defer-or-not dl? `(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type))]
[(fcallable ,conv ,[cpvalid : e dl?] (,arg-type* ...) ,result-type) [(fcallable (,conv* ...) ,[cpvalid : e dl?] (,arg-type* ...) ,result-type)
(defer-or-not dl? `(fcallable ,conv ,e (,arg-type* ...) ,result-type))] (defer-or-not dl? `(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type))]
[(cte-optimization-loc ,box ,[cpvalid : e dl?]) [(cte-optimization-loc ,box ,[cpvalid : e dl?])
(defer-or-not dl? `(cte-optimization-loc ,box ,e))] (defer-or-not dl? `(cte-optimization-loc ,box ,e))]
[(pariah) (values x #f)] [(pariah) (values x #f)]

14
s/ftype.ss
View File

@ -56,7 +56,7 @@ ftype ->
(array length ftype) (array length ftype)
(bits (field-name signedness bits) ...) (bits (field-name signedness bits) ...)
(function (arg-type ...) result-type) (function (arg-type ...) result-type)
(function conv (arg-type ...) result-type) (function conv ... (arg-type ...) result-type)
(packed ftype) (packed ftype)
(unpacked ftype) (unpacked ftype)
(endian endianness ftype) (endian endianness ftype)
@ -322,7 +322,7 @@ ftype operators:
(define-ftd-record-type array #{rtd/ftd-array a9pth58056u34h517jsrqv-5} length ftd) (define-ftd-record-type array #{rtd/ftd-array a9pth58056u34h517jsrqv-5} length ftd)
(define-ftd-record-type pointer #{rtd/ftd-pointer a9pth58056u34h517jsrqv-6} (mutable ftd)) (define-ftd-record-type pointer #{rtd/ftd-pointer a9pth58056u34h517jsrqv-6} (mutable ftd))
(define-ftd-record-type bits #{rtd/ftd-ibits a9pth58056u34h517jsrqv-9} swap? field*) (define-ftd-record-type bits #{rtd/ftd-ibits a9pth58056u34h517jsrqv-9} swap? field*)
(define-ftd-record-type function #{rtd/ftd-function a9pth58056u34h517jsrqv-10} conv arg-type* result-type) (define-ftd-record-type function #{rtd/ftd-function a9pth58056u34h517jsrqv-11} conv* arg-type* result-type)
(module (pointer-size alignment pointer-alignment native-base-ftds swap-base-ftds) (module (pointer-size alignment pointer-alignment native-base-ftds swap-base-ftds)
(define alignment (define alignment
(lambda (max-alignment size) (lambda (max-alignment size)
@ -527,7 +527,7 @@ ftype operators:
[(function-kwd (arg-type ...) result-type) [(function-kwd (arg-type ...) result-type)
(eq? (datum function-kwd) 'function) (eq? (datum function-kwd) 'function)
(f #'(function-kwd #f (arg-type ...) result-type) #f stype funok?)] (f #'(function-kwd #f (arg-type ...) result-type) #f stype funok?)]
[(function-kwd conv (arg-type ...) result-type) [(function-kwd conv ... (arg-type ...) result-type)
(eq? (datum function-kwd) 'function) (eq? (datum function-kwd) 'function)
(let () (let ()
(define filter-type (define filter-type
@ -539,7 +539,7 @@ ftype operators:
(make-ftd-function rtd/fptr (make-ftd-function rtd/fptr
(and defid (symbol->string (syntax->datum defid))) (and defid (symbol->string (syntax->datum defid)))
stype #f #f stype #f #f
($filter-conv 'function-ftype #'conv) ($filter-conv 'function-ftype #'(conv ...))
(map (lambda (x) (filter-type r x #f)) #'(arg-type ...)) (map (lambda (x) (filter-type r x #f)) #'(arg-type ...))
(filter-type r #'result-type #t)))] (filter-type r #'result-type #t)))]
[(packed-kwd ftype) [(packed-kwd ftype)
@ -729,7 +729,7 @@ ftype operators:
;; (foreign-callable-entry-point code-object) ;; (foreign-callable-entry-point code-object)
[(procedure? x) [(procedure? x)
(let ([co #,($make-foreign-callable 'make-ftype-pointer (let ([co #,($make-foreign-callable 'make-ftype-pointer
(ftd-function-conv ftd) (ftd-function-conv* ftd)
#'x #'x
(map indirect-ftd-pointer (ftd-function-arg-type* ftd)) (map indirect-ftd-pointer (ftd-function-arg-type* ftd))
(indirect-ftd-pointer (ftd-function-result-type ftd)))]) (indirect-ftd-pointer (ftd-function-result-type ftd)))])
@ -1197,8 +1197,8 @@ ftype operators:
[(ftd-base? ftd) (do-base (filter-foreign-type (ftd-base-type ftd)) (ftd-base-swap? ftd) offset)] [(ftd-base? ftd) (do-base (filter-foreign-type (ftd-base-type ftd)) (ftd-base-swap? ftd) offset)]
[(ftd-pointer? ftd) #`(#3%$fptr-fptr-ref #,fptr-expr #,offset '#,(ftd-pointer-ftd ftd))] [(ftd-pointer? ftd) #`(#3%$fptr-fptr-ref #,fptr-expr #,offset '#,(ftd-pointer-ftd ftd))]
[(ftd-function? ftd) [(ftd-function? ftd)
($make-foreign-procedure ($make-foreign-procedure 'make-ftype-pointer
(ftd-function-conv ftd) (ftd-function-conv* ftd)
#f #f
#`($fptr-offset-addr #,fptr-expr offset) #`($fptr-offset-addr #,fptr-expr offset)
(map indirect-ftd-pointer (ftd-function-arg-type* ftd)) (map indirect-ftd-pointer (ftd-function-arg-type* ftd))

8
s/interpret.ss
View File

@ -459,7 +459,7 @@
[(seq ,e1 ,e2) [(seq ,e1 ,e2)
(let ((e1 (ip2 e1)) (e2 (ip2 e2))) (let ((e1 (ip2 e1)) (e2 (ip2 e2)))
($rt lambda () ($rt e1) ($rt e2)))] ($rt lambda () ($rt e1) ($rt e2)))]
[(foreign ,conv ,name ,e (,arg-type* ...) ,result-type) [(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type)
(unless $compiler-is-loaded? (unless $compiler-is-loaded?
($oops 'interpret "cannot compile foreign-procedure: compiler is not loaded")) ($oops 'interpret "cannot compile foreign-procedure: compiler is not loaded"))
(let ([p ($compile-backend (let ([p ($compile-backend
@ -468,11 +468,11 @@
(with-output-language (Lsrc Expr) (with-output-language (Lsrc Expr)
`(case-lambda ,(make-preinfo-lambda) `(case-lambda ,(make-preinfo-lambda)
(clause (,t) 1 (clause (,t) 1
(foreign ,conv ,name (ref #f ,t) (foreign (,conv* ...) ,name (ref #f ,t)
(,arg-type* ...) ,result-type))))))]) (,arg-type* ...) ,result-type))))))])
(let ([e (ip2 e)]) (let ([e (ip2 e)])
($rt lambda () ((p) ($rt e)))))] ($rt lambda () ((p) ($rt e)))))]
[(fcallable ,conv ,e (,arg-type* ...) ,result-type) [(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type)
(unless $compiler-is-loaded? (unless $compiler-is-loaded?
($oops 'interpret "cannot compile foreign-callable: compiler is not loaded")) ($oops 'interpret "cannot compile foreign-callable: compiler is not loaded"))
(let ([p ($compile-backend (let ([p ($compile-backend
@ -481,7 +481,7 @@
(with-output-language (Lsrc Expr) (with-output-language (Lsrc Expr)
`(case-lambda ,(make-preinfo-lambda) `(case-lambda ,(make-preinfo-lambda)
(clause (,t) 1 (clause (,t) 1
(fcallable ,conv (ref #f ,t) (,arg-type* ...) ,result-type))))))]) (fcallable (,conv* ...) (ref #f ,t) (,arg-type* ...) ,result-type))))))])
(let ([e (ip2 e)]) (let ([e (ip2 e)])
($rt lambda () ((p) ($rt e)))))] ($rt lambda () ((p) ($rt e)))))]
[else (unexpected-record x)]))) [else (unexpected-record x)])))

7
s/np-languages.ss
View File

@ -78,10 +78,6 @@
(import (nanopass)) (import (nanopass))
(include "base-lang.ss") (include "base-lang.ss")
; convention is a symbol or #f (we're assuming the front end already verified
; the convention is a valid one for this machine-type
(define convention? (lambda (x) (or (symbol? x) (eq? #f x))))
; r6rs says a quote subform should be a datum, not must be a datum ; r6rs says a quote subform should be a datum, not must be a datum
; chez scheme allows a quote subform to be any value ; chez scheme allows a quote subform to be any value
(define datum? (lambda (x) #t)) (define datum? (lambda (x) #t))
@ -489,6 +485,7 @@
(declare-primitive c-call effect #f) (declare-primitive c-call effect #f)
(declare-primitive c-simple-call effect #f) (declare-primitive c-simple-call effect #f)
(declare-primitive c-simple-return effect #f) (declare-primitive c-simple-return effect #f)
(declare-primitive deactivate-thread effect #f) ; threaded version only
(declare-primitive fl* effect #f) (declare-primitive fl* effect #f)
(declare-primitive fl+ effect #f) (declare-primitive fl+ effect #f)
(declare-primitive fl- effect #f) (declare-primitive fl- effect #f)
@ -521,6 +518,7 @@
(declare-primitive store-single effect #f) (declare-primitive store-single effect #f)
(declare-primitive store-single->double effect #f) (declare-primitive store-single->double effect #f)
(declare-primitive store-with-update effect #f) ; ppc (declare-primitive store-with-update effect #f) ; ppc
(declare-primitive unactivate-thread effect #f) ; threaded version only
(declare-primitive vpush-multiple effect #f) ; arm (declare-primitive vpush-multiple effect #f) ; arm
(declare-primitive < pred #t) (declare-primitive < pred #t)
@ -550,6 +548,7 @@
(declare-primitive fstps value #f) ; x86 only (declare-primitive fstps value #f) ; x86 only
(declare-primitive get-double value #t) ; x86_64 (declare-primitive get-double value #t) ; x86_64
(declare-primitive get-tc value #f) ; threaded version only (declare-primitive get-tc value #f) ; threaded version only
(declare-primitive activate-thread value #f) ; threaded version only
(declare-primitive lea1 value #t) (declare-primitive lea1 value #t)
(declare-primitive lea2 value #t) (declare-primitive lea2 value #t)
(declare-primitive load value #t) (declare-primitive load value #t)

244
s/ppc32.ss
View File

@ -57,7 +57,7 @@
[%xp %r20 #t 20] [%xp %r20 #t 20]
[%ts %r14 #t 14] [%ts %r14 #t 14]
[%td %r15 #t 15] [%td %r15 #t 15]
[%ac1 %r12 #f 12] [%ac1 %r12 %deact #f 12]
[%ret %r17 #t 17] [%ret %r17 #t 17]
[%cp %r24 #t 24] [%cp %r24 #t 24]
[%yp %r27 #t 27] [%yp %r27 #t 27]
@ -668,6 +668,30 @@
`(set! ,(make-live-info) ,u (asm ,null-info ,asm-kill)) `(set! ,(make-live-info) ,u (asm ,null-info ,asm-kill))
`(set! ,(make-live-info) ,z (asm ,info ,asm-get-tc ,u))))]) `(set! ,(make-live-info) ,z (asm ,info ,asm-get-tc ,u))))])
;; like get-tc
(define-instruction value (activate-thread)
[(op (z ur))
(safe-assert (eq? z %Cretval))
(let ([u (make-tmp 'u)])
(seq
`(set! ,(make-live-info) ,u (asm ,null-info ,asm-kill))
`(set! ,(make-live-info) ,z (asm ,info ,asm-activate-thread ,u))))])
(define-instruction effect (deactivate-thread)
[(op)
(let ([u (make-tmp 'u)])
(seq
`(set! ,(make-live-info) ,u (asm ,null-info ,asm-kill))
`(asm ,info ,asm-deactivate-thread ,u)))])
(define-instruction effect (unactivate-thread)
[(op (z ur))
(safe-assert (eq? z %Carg1))
(let ([u (make-tmp 'u)])
(seq
`(set! ,(make-live-info) ,u (asm ,null-info ,asm-kill))
`(asm ,info ,asm-unactivate-thread ,u)))])
(define-instruction value (asmlibcall) (define-instruction value (asmlibcall)
[(op (z ur)) [(op (z ur))
(let ([u (make-tmp 'u)]) (let ([u (make-tmp 'u)])
@ -823,7 +847,7 @@
shift-count? shift-count?
asm-isync asm-isync
; threaded version specific ; threaded version specific
asm-get-tc asm-get-tc asm-activate-thread asm-deactivate-thread asm-unactivate-thread
; machine dependent exports ; machine dependent exports
asm-kill) asm-kill)
@ -1906,6 +1930,21 @@
(lambda (code* dest tmp . ignore) ; dest is ignored, since it is always Cretval (lambda (code* dest tmp . ignore) ; dest is ignored, since it is always Cretval
(asm-helper-call code* target #f tmp)))) (asm-helper-call code* target #f tmp))))
(define asm-activate-thread
(let ([target `(ppc32-call 0 (entry ,(lookup-c-entry activate-thread)))])
(lambda (code* dest tmp . ignore) ; dest is ignored, since it is always Cretval
(asm-helper-call code* target #f tmp))))
(define asm-deactivate-thread
(let ([target `(ppc32-call 0 (entry ,(lookup-c-entry deactivate-thread)))])
(lambda (code* tmp . ignore)
(asm-helper-call code* target #f tmp))))
(define asm-unactivate-thread
(let ([target `(ppc32-call 0 (entry ,(lookup-c-entry unactivate-thread)))])
(lambda (code* tmp . ignore)
(asm-helper-call code* target #f tmp))))
(define-who asm-return-address (define-who asm-return-address
(lambda (dest l incr-offset next-addr) (lambda (dest l incr-offset next-addr)
(make-rachunk dest l incr-offset next-addr (make-rachunk dest l incr-offset next-addr
@ -2133,6 +2172,7 @@
(define align (lambda (b x) (let ([k (- b 1)]) (fxlogand (fx+ x k) (fxlognot k))))) (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 gp-parameter-regs (lambda () (list %Carg1 %Carg2 %Carg3 %Carg4 %Carg5 %Carg6 %Carg7 %Carg8)))
(define fp-parameter-regs (lambda () (list %Cfparg1 %Cfparg2 %Cfparg3 %Cfparg4 %Cfparg5 %Cfparg6 %Cfparg7 %Cfparg8))) (define fp-parameter-regs (lambda () (list %Cfparg1 %Cfparg2 %Cfparg3 %Cfparg4 %Cfparg5 %Cfparg6 %Cfparg7 %Cfparg8)))
(define fp-result-regs (lambda () (list %Cfpretval)))
(define (indirect-result-that-fits-in-registers? result-type) (define (indirect-result-that-fits-in-registers? result-type)
(nanopass-case (Ltype Type) result-type (nanopass-case (Ltype Type) result-type
[(fp-ftd& ,ftd) (not ($ftd-compound? ftd))] [(fp-ftd& ,ftd) (not ($ftd-compound? ftd))]
@ -2141,6 +2181,32 @@
(nanopass-case (Ltype Type) result-type (nanopass-case (Ltype Type) result-type
[(fp-ftd& ,ftd) ($ftd-compound? ftd)] [(fp-ftd& ,ftd) ($ftd-compound? ftd)]
[else #f])) [else #f]))
(module (push-registers pop-registers)
;; stack offset must be 8-byte aligned if fp-reg-count is non-zero
(define (move-registers regs fp-reg-count fp-regs load? offset e)
(with-output-language (L13 Effect)
(cond
[(fx> fp-reg-count 0)
;; Push floating-point first to get correct alignment
(let ([offset (align 8 offset)])
(move-registers regs (fx- fp-reg-count 1) (cdr fp-regs) load? (fx+ offset 8)
(cond
[load? `(seq ,e (inline ,(make-info-loadfl (car fp-regs)) ,%load-double ,%sp ,%zero (immediate ,offset)))]
[else `(seq (inline ,(make-info-loadfl (car fp-regs)) ,%store-double ,%sp ,%zero (immediate ,offset)) ,e)])))]
[(pair? regs)
(move-registers (cdr regs) 0 '() load? (fx+ offset 4)
(cond
[load? `(seq ,e (set! ,(car regs) ,(%mref ,%sp ,offset)))]
[else `(seq (set! ,(%mref ,%sp ,offset) ,(car regs)) ,e)]))]
[else e])))
;; Add "pushes" before e
(define (push-registers regs fp-reg-count fp-regs offset e)
(move-registers regs fp-reg-count fp-regs #f offset e))
;; Add "pops" after e
(define (pop-registers regs fp-reg-count fp-regs offset e)
(move-registers regs fp-reg-count fp-regs #t offset e)))
(define-who asm-foreign-call (define-who asm-foreign-call
(with-output-language (L13 Effect) (with-output-language (L13 Effect)
(define load-double-stack (define load-double-stack
@ -2233,10 +2299,12 @@
(lambda (types) (lambda (types)
;; NB: start stack pointer at 8 to put arguments above the linkage area ;; 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]
;; needed when adjusting active:
[fp-live-count 0]
;; configured for `ftd-fp&` unpacking of floats: ;; configured for `ftd-fp&` unpacking of floats:
[fp-disp (constant flonum-data-disp)] [single? #f]) [fp-disp (constant flonum-data-disp)] [single? #f])
(if (null? types) (if (null? types)
(values isp locs live*) (values isp locs live* fp-live-count)
(nanopass-case (Ltype Type) (car types) (nanopass-case (Ltype Type) (car types)
[(fp-double-float) [(fp-double-float)
(if (constant software-floating-point) (if (constant software-floating-point)
@ -2245,21 +2313,21 @@
(let ([isp (align 8 isp)]) (let ([isp (align 8 isp)])
(loop (cdr types) (loop (cdr types)
(cons (load-double-stack isp fp-disp) locs) (cons (load-double-stack isp fp-disp) locs)
live* '() flt* (fx+ isp 8) live* '() flt* (fx+ isp 8) fp-live-count
(constant flonum-data-disp) #f)) (constant flonum-data-disp) #f))
(loop (cdr types) (loop (cdr types)
(cons (load-soft-double-reg (cadr int*) (car int*) fp-disp) locs) (cons (load-soft-double-reg (cadr int*) (car int*) fp-disp) locs)
(cons* (car int*) (cadr int*) live*) (cddr int*) flt* isp (cons* (car int*) (cadr int*) live*) (cddr int*) flt* isp fp-live-count
(constant flonum-data-disp) #f))) (constant flonum-data-disp) #f)))
(if (null? flt*) (if (null? flt*)
(let ([isp (align 8 isp)]) (let ([isp (align 8 isp)])
(loop (cdr types) (loop (cdr types)
(cons (load-double-stack isp fp-disp) locs) (cons (load-double-stack isp fp-disp) locs)
live* int* '() (fx+ isp 8) live* int* '() (fx+ isp 8) fp-live-count
(constant flonum-data-disp) #f)) (constant flonum-data-disp) #f))
(loop (cdr types) (loop (cdr types)
(cons (load-double-reg (car flt*) fp-disp) locs) (cons (load-double-reg (car flt*) fp-disp) locs)
live* int* (cdr flt*) isp live* int* (cdr flt*) isp (fx+ fp-live-count 1)
(constant flonum-data-disp) #f)))] (constant flonum-data-disp) #f)))]
[(fp-single-float) [(fp-single-float)
(if (constant software-floating-point) (if (constant software-floating-point)
@ -2267,29 +2335,29 @@
; NB: ABI says singles are passed as doubles on the stack, but gcc/linux doesn't ; NB: ABI says singles are passed as doubles on the stack, but gcc/linux doesn't
(loop (cdr types) (loop (cdr types)
(cons (load-single-stack isp fp-disp single?) locs) (cons (load-single-stack isp fp-disp single?) locs)
live* '() flt* (fx+ isp 4) live* '() flt* (fx+ isp 4) fp-live-count
(constant flonum-data-disp) #f) (constant flonum-data-disp) #f)
(loop (cdr types) (loop (cdr types)
(cons (load-soft-single-reg (car int*) fp-disp single?) locs) (cons (load-soft-single-reg (car int*) fp-disp single?) locs)
(cons (car int*) live*) (cdr int*) flt* isp (cons (car int*) live*) (cdr int*) flt* isp fp-live-count
(constant flonum-data-disp) #f)) (constant flonum-data-disp) #f))
(if (null? flt*) (if (null? flt*)
; NB: ABI says singles are passed as doubles on the stack, but gcc/linux doesn't ; NB: ABI says singles are passed as doubles on the stack, but gcc/linux doesn't
(let ([isp (align 4 isp)]) (let ([isp (align 4 isp)])
(loop (cdr types) (loop (cdr types)
(cons (load-single-stack isp fp-disp single?) locs) (cons (load-single-stack isp fp-disp single?) locs)
live* int* '() (fx+ isp 4) live* int* '() (fx+ isp 4) fp-live-count
(constant flonum-data-disp) #f)) (constant flonum-data-disp) #f))
(loop (cdr types) (loop (cdr types)
(cons (load-single-reg (car flt*) fp-disp single?) locs) (cons (load-single-reg (car flt*) fp-disp single?) locs)
live* int* (cdr flt*) isp live* int* (cdr flt*) isp (fx+ fp-live-count 1)
(constant flonum-data-disp) #f)))] (constant flonum-data-disp) #f)))]
[(fp-ftd& ,ftd) [(fp-ftd& ,ftd)
(cond (cond
[($ftd-compound? ftd) [($ftd-compound? ftd)
;; pass as pointer ;; pass as pointer
(let ([pointer-type (with-output-language (Ltype Type) `(fp-integer 32))]) (let ([pointer-type (with-output-language (Ltype Type) `(fp-integer 32))])
(loop (cons pointer-type (cdr types)) locs live* int* flt* isp (loop (cons pointer-type (cdr types)) locs live* int* flt* isp fp-live-count
(constant flonum-data-disp) #f))] (constant flonum-data-disp) #f))]
[else [else
;; extract content and pass that content ;; extract content and pass that content
@ -2301,7 +2369,7 @@
(case ($ftd-size ftd) (case ($ftd-size ftd)
[(4) `(fp-single-float)] [(4) `(fp-single-float)]
[else `(fp-double-float)]))]) [else `(fp-double-float)]))])
(loop (cons unpacked-type (cdr types)) locs live* int* flt* isp (loop (cons unpacked-type (cdr types)) locs live* int* flt* isp fp-live-count
;; no floating displacement within pointer: ;; no floating displacement within pointer:
0 0
;; in case of float, load as single-float: ;; in case of float, load as single-float:
@ -2313,21 +2381,21 @@
(let ([isp (align 8 isp)]) (let ([isp (align 8 isp)])
(loop (cdr types) (loop (cdr types)
(cons (load-indirect-int64-stack isp) locs) (cons (load-indirect-int64-stack isp) locs)
live* '() flt* (fx+ isp 8) live* '() flt* (fx+ isp 8) fp-live-count
(constant flonum-data-disp) #f)) (constant flonum-data-disp) #f))
(loop (cdr types) (loop (cdr types)
(cons (load-indirect-int64-reg (cadr int*) (car int*)) locs) (cons (load-indirect-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 fp-live-count
(constant flonum-data-disp) #f)))] (constant flonum-data-disp) #f)))]
[else [else
(if (null? int*) (if (null? int*)
(loop (cdr types) (loop (cdr types)
(cons (load-indirect-int-stack isp ($ftd-size ftd)) locs) (cons (load-indirect-int-stack isp ($ftd-size ftd)) locs)
live* '() flt* (fx+ isp 4) live* '() flt* (fx+ isp 4) fp-live-count
(constant flonum-data-disp) #f) (constant flonum-data-disp) #f)
(loop (cdr types) (loop (cdr types)
(cons (load-indirect-int-reg (car int*) ($ftd-size ftd) category) locs) (cons (load-indirect-int-reg (car int*) ($ftd-size ftd) category) locs)
(cons (car int*) live*) (cdr int*) flt* isp (cons (car int*) live*) (cdr int*) flt* isp fp-live-count
(constant flonum-data-disp) #f))]))])] (constant flonum-data-disp) #f))]))])]
[else [else
(if (nanopass-case (Ltype Type) (car types) (if (nanopass-case (Ltype Type) (car types)
@ -2339,20 +2407,20 @@
(let ([isp (align 8 isp)]) (let ([isp (align 8 isp)])
(loop (cdr types) (loop (cdr types)
(cons (load-int64-stack isp) locs) (cons (load-int64-stack isp) locs)
live* '() flt* (fx+ isp 8) live* '() flt* (fx+ isp 8) fp-live-count
(constant flonum-data-disp) #f)) (constant flonum-data-disp) #f))
(loop (cdr types) (loop (cdr types)
(cons (load-int64-reg (cadr int*) (car int*)) locs) (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 fp-live-count
(constant flonum-data-disp) #f))) (constant flonum-data-disp) #f)))
(if (null? int*) (if (null? int*)
(loop (cdr types) (loop (cdr types)
(cons (load-int-stack isp) locs) (cons (load-int-stack isp) locs)
live* '() flt* (fx+ isp 4) live* '() flt* (fx+ isp 4) fp-live-count
(constant flonum-data-disp) #f) (constant flonum-data-disp) #f)
(loop (cdr types) (loop (cdr types)
(cons (load-int-reg (car int*)) locs) (cons (load-int-reg (car int*)) locs)
(cons (car int*) live*) (cdr int*) flt* isp (cons (car int*) live*) (cdr int*) flt* isp fp-live-count
(constant flonum-data-disp) #f)))]))))) (constant flonum-data-disp) #f)))])))))
(define do-indirect-result-from-registers (define do-indirect-result-from-registers
(lambda (ftd offset) (lambda (ftd offset)
@ -2374,16 +2442,40 @@
(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 0) ,%Cretval-high)
(inline ,(make-info-load 'integer-32 #f) ,%store ,tmp ,%zero (immediate 4) ,%Cretval-low))] (inline ,(make-info-load 'integer-32 #f) ,%store ,tmp ,%zero (immediate 4) ,%Cretval-low))]
[else (sorry! who "unexpected result size")])]))))) [else (sorry! who "unexpected result size")])])))))
(define (add-deactivate t0 offset live* fp-live-count result-live* result-fp-live-count e)
(let ([save-and-restore
(lambda (regs fp-count fp-regs e)
(cond
[(and (null? regs) (fx= 0 fp-count)) e]
[else
(pop-registers regs fp-count fp-regs offset
(push-registers regs fp-count fp-regs offset
e))]))])
(%seq
(set! ,%deact ,t0)
,(save-and-restore (cons %deact live*) fp-live-count (fp-parameter-regs) (%inline deactivate-thread))
,e
,(save-and-restore result-live* result-fp-live-count (fp-result-regs) `(set! ,%Cretval ,(%inline activate-thread))))))
(lambda (info) (lambda (info)
(safe-assert (reg-callee-save? %tc)) ; no need to save-restore (safe-assert (reg-callee-save? %tc)) ; no need to save-restore
(let* ([arg-type* (info-foreign-arg-type* info)] (let* ([arg-type* (info-foreign-arg-type* info)]
[result-type (info-foreign-result-type info)] [result-type (info-foreign-result-type info)]
[fill-result-here? (indirect-result-that-fits-in-registers? result-type)]) [fill-result-here? (indirect-result-that-fits-in-registers? result-type)]
[adjust-active? (if-feature pthreads (memq 'adjust-active (info-foreign-conv* info)) #f)])
(with-values (do-args (if fill-result-here? (cdr arg-type*) arg-type*)) (with-values (do-args (if fill-result-here? (cdr arg-type*) arg-type*))
(lambda (orig-frame-size locs live*) (lambda (orig-frame-size locs live* fp-live-count)
;; NB: add 4 to frame size for CR save word ;; NB: add 4 to frame size for CR save word
(let ([fill-stash-offset orig-frame-size] (let* ([fill-stash-offset orig-frame-size]
[frame-size (align 16 (fx+ orig-frame-size 4 (if fill-result-here? 4 0)))]) [base-frame-size (fx+ orig-frame-size (if fill-result-here? 4 0))]
[deactivate-save-offset (if (and adjust-active? (fx> fp-live-count 0))
(align 8 base-frame-size) ; for `double` save
base-frame-size)]
[frame-size (align 16 (fx+ 4 ; for CR save
(if adjust-active?
(fx+ deactivate-save-offset
(fx* fp-live-count 8)
(fx* (length live*) 4))
deactivate-save-offset)))])
(values (values
(lambda () (%inline store-with-update ,%Csp ,%Csp (immediate ,(fx- frame-size)))) (lambda () (%inline store-with-update ,%Csp ,%Csp (immediate ,(fx- frame-size))))
(let ([locs (reverse locs)]) (let ([locs (reverse locs)])
@ -2393,20 +2485,26 @@
(cons (load-int-stack fill-stash-offset) locs)] (cons (load-int-stack fill-stash-offset) locs)]
[else locs])) [else locs]))
(lambda (t0) (lambda (t0)
(if (constant software-floating-point) (define (make-call result-live* result-fp-live-count)
(cond
[adjust-active?
(add-deactivate t0 deactivate-save-offset live* fp-live-count result-live* result-fp-live-count
`(inline ,(make-info-kill*-live* result-live* live*) ,%c-call ,%deact))]
[else `(inline ,(make-info-kill*-live* result-live* live*) ,%c-call ,t0)]))
(if (constant software-floating-point)
(let () (let ()
(define handle-64-bit (define handle-64-bit
(lambda () (lambda ()
`(inline ,(make-info-kill*-live* (reg-list %Cretval-high %Cretval-low) live*) ,%c-call ,t0))) (make-call (reg-list %Cretval-high %Cretval-low) 0)))
(define handle-32-bit (define handle-32-bit
(lambda () (lambda ()
`(inline ,(make-info-kill*-live* (reg-list %Cretval) live*) ,%c-call ,t0))) (make-call (reg-list %Cretval) 0)))
(define handle-integer-cases (define handle-integer-cases
(lambda (bits) (lambda (bits)
(case bits (case bits
[(8 16 32) (handle-32-bit)] [(8 16 32) (handle-32-bit)]
[(64) (handle-64-bit)] [(64) (handle-64-bit)]
[else (sorry! who "unexpected asm-foriegn-procedures fp-integer size ~s" bits)]))) [else (sorry! who "unexpected asm-foreign-procedures fp-integer size ~s" bits)])))
(define (handle-ftd&-case ftd) (define (handle-ftd&-case ftd)
(cond (cond
[fill-result-here? [fill-result-here?
@ -2415,20 +2513,20 @@
(handle-64-bit) (handle-64-bit)
(handle-32-bit)) (handle-32-bit))
,(do-indirect-result-from-registers ftd fill-stash-offset))] ,(do-indirect-result-from-registers ftd fill-stash-offset))]
[else `(inline ,(make-info-kill*-live* (reg-list) live*) ,%c-call ,t0)])) [else (make-call (reg-list) 0)]))
(nanopass-case (Ltype Type) result-type (nanopass-case (Ltype Type) result-type
[(fp-double-float) (handle-64-bit)] [(fp-double-float) (handle-64-bit)]
[(fp-single-float) (handle-32-bit)] [(fp-single-float) (handle-32-bit)]
[(fp-integer ,bits) (handle-integer-cases bits)] [(fp-integer ,bits) (handle-integer-cases bits)]
[(fp-integer ,bits) (handle-integer-cases bits)] [(fp-integer ,bits) (handle-integer-cases bits)]
[(fp-ftd& ,ftd) (handle-ftd&-case ftd)] [(fp-ftd& ,ftd) (handle-ftd&-case ftd)]
[else `(inline ,(make-info-kill*-live* (reg-list %Cretval) live*) ,%c-call ,t0)])) [else (make-call (reg-list %Cretval) 0)]))
(let () (let ()
(define handle-integer-cases (define handle-integer-cases
(lambda (bits) (lambda (bits)
(case bits (case bits
[(8 16 32) `(inline ,(make-info-kill*-live* (reg-list %Cretval) live*) ,%c-call ,t0)] [(8 16 32) (make-call (reg-list %Cretval) 0)]
[(64) `(inline ,(make-info-kill*-live* (reg-list %Cretval-high %Cretval-low) live*) ,%c-call ,t0)] [(64) (make-call (reg-list %Cretval-high %Cretval-low) 0)]
[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) (define (handle-ftd&-case ftd)
(cond (cond
@ -2436,16 +2534,16 @@
(%seq (%seq
,(if (not (eq? 'float ($ftd-atomic-category ftd))) ,(if (not (eq? 'float ($ftd-atomic-category ftd)))
(handle-integer-cases (* 8 ($ftd-size ftd))) (handle-integer-cases (* 8 ($ftd-size ftd)))
`(inline ,(make-info-kill*-live* (reg-list) live*) ,%c-call ,t0)) (make-call (reg-list) 1))
,(do-indirect-result-from-registers ftd fill-stash-offset))] ,(do-indirect-result-from-registers ftd fill-stash-offset))]
[else `(inline ,(make-info-kill*-live* (reg-list) live*) ,%c-call ,t0)])) [else `(inline ,(make-info-kill*-live* (reg-list) live*) ,%c-call ,t0)]))
(nanopass-case (Ltype Type) result-type (nanopass-case (Ltype Type) result-type
[(fp-double-float) `(inline ,(make-info-kill*-live* (reg-list) live*) ,%c-call ,t0)] [(fp-double-float) (make-call (reg-list) 1)]
[(fp-single-float) `(inline ,(make-info-kill*-live* (reg-list) live*) ,%c-call ,t0)] [(fp-single-float) (make-call (reg-list) 1)]
[(fp-integer ,bits) (handle-integer-cases bits)] [(fp-integer ,bits) (handle-integer-cases bits)]
[(fp-unsigned ,bits) (handle-integer-cases bits)] [(fp-unsigned ,bits) (handle-integer-cases bits)]
[(fp-ftd& ,ftd) (handle-ftd&-case ftd)] [(fp-ftd& ,ftd) (handle-ftd&-case ftd)]
[else `(inline ,(make-info-kill*-live* (reg-list %Cretval) live*) ,%c-call ,t0)])))) [else (make-call (reg-list %Cretval) 0)]))))
(nanopass-case (Ltype Type) result-type (nanopass-case (Ltype Type) result-type
[(fp-double-float) [(fp-double-float)
(lambda (lvalue) (lambda (lvalue)
@ -2552,12 +2650,15 @@
| | | |
| back chain | 1 word | back chain | 1 word
sp+X: | | sp+X: | |
+---------------------------+ <- 16-byte aligned
+---------------------------+ +---------------------------+
+---------------------------+ <- 16-byte aligned +---------------------------+ <- 16-byte aligned
| | | |
| &-return space | 2 words, if needed | &-return space | 2 words, if needed
| | | |
+---------------------------+ <- 8-byte aligned +---------------------------+ <- 8-byte aligned
| unactivate mode | 1 word, if needed
+---------------------------+
| | | |
| callee-save regs | | callee-save regs |
| | | |
@ -2567,9 +2668,9 @@
| | | |
+---------------------------+ <- 8-byte aligned +---------------------------+ <- 8-byte aligned
| | | |
| integer argument regs | | integer argument regs | Also used to stash results during unactivate
| | | |
sp+8: +---------------------------+ <-- 8-byte aligned sp+8: +---------------------------+ <- 8-byte aligned
| | | |
| lr | 1 word (place for get-thread-context to store lr) | lr | 1 word (place for get-thread-context to store lr)
| | | |
@ -2837,20 +2938,23 @@
(case ($ftd-size ftd) (case ($ftd-size ftd)
[(4) `(inline ,(make-info-loadfl %Cfpretval) ,%load-single ,%sp ,%zero (immediate ,return-space-offset))] [(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 `(inline ,(make-info-loadfl %Cfpretval) ,%load-double ,%sp ,%zero (immediate ,return-space-offset))]))
'())] '()
1)]
[else [else
(cond (cond
[($ftd-compound? ftd) [($ftd-compound? ftd)
;; return pointer ;; return pointer
(values (values
(lambda () `(set! ,%Cretval ,(%mref ,%sp ,int-reg-offset))) (lambda () `(set! ,%Cretval ,(%mref ,%sp ,int-reg-offset)))
(list %Cretval))] (list %Cretval)
0)]
[(fx= 8 ($ftd-size ftd)) [(fx= 8 ($ftd-size ftd))
(values (lambda () (values (lambda ()
(%seq (%seq
(set! ,%Cretval-high ,(%mref ,%sp ,return-space-offset)) (set! ,%Cretval-high ,(%mref ,%sp ,return-space-offset))
(set! ,%Cretval-low ,(%mref ,%sp ,(fx+ return-space-offset 4))))) (set! ,%Cretval-low ,(%mref ,%sp ,(fx+ return-space-offset 4)))))
(list %Cretval-high %Cretval-low))] (list %Cretval-high %Cretval-low)
0)]
[else [else
(values (values
(lambda () (lambda ()
@ -2858,18 +2962,22 @@
[(1) `(set! ,%Cretval (inline ,(make-info-load 'integer-8 #f) ,%load ,%sp ,%zero (immediate ,return-space-offset)))] [(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)))] [(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))])) [else `(set! ,%Cretval ,(%mref ,%sp ,return-space-offset))]))
(list %Cretval))])])] (list %Cretval)
0)])])]
[(fp-double-float) [(fp-double-float)
(values (lambda (x) (values (lambda (x)
`(inline ,(make-info-loadfl %Cfpretval) ,%load-double ,x ,%zero ,(%constant flonum-data-disp))) `(inline ,(make-info-loadfl %Cfpretval) ,%load-double ,x ,%zero ,(%constant flonum-data-disp)))
'())] '()
1)]
[(fp-single-float) [(fp-single-float)
(values (lambda (x) (values (lambda (x)
`(inline ,(make-info-loadfl %Cfpretval) ,%load-double->single ,x ,%zero ,(%constant flonum-data-disp))) `(inline ,(make-info-loadfl %Cfpretval) ,%load-double->single ,x ,%zero ,(%constant flonum-data-disp)))
'())] '()
1)]
[(fp-void) [(fp-void)
(values (lambda () `(nop)) (values (lambda () `(nop))
'())] '()
0)]
[else [else
(cond (cond
[(nanopass-case (Ltype Type) result-type [(nanopass-case (Ltype Type) result-type
@ -2880,11 +2988,20 @@
(%seq (%seq
(set! ,%Cretval-low ,lo-rhs) (set! ,%Cretval-low ,lo-rhs)
(set! ,%Cretval-high ,hi-rhs))) (set! ,%Cretval-high ,hi-rhs)))
(list %Cretval-high %Cretval-low))] (list %Cretval-high %Cretval-low)
0)]
[else [else
(values (lambda (rhs) (values (lambda (rhs)
`(set! ,%Cretval ,rhs)) `(set! ,%Cretval ,rhs))
(list %Cretval))])]))) (list %Cretval)
0)])])))
(define (unactivate unactivate-mode-offset result-regs result-num-fp-regs stash-offset)
(let ([e (%seq
(set! ,%Carg1 ,(%mref ,%sp ,unactivate-mode-offset))
,(%inline unactivate-thread ,%Carg1))])
(pop-registers result-regs result-num-fp-regs (fp-result-regs) stash-offset
(push-registers result-regs result-num-fp-regs (fp-result-regs) stash-offset
e))))
(lambda (info) (lambda (info)
(define callee-save-regs (list %r14 %r15 %r16 %r17 %r18 %r19 %r20 %r21 %r22 %r23 %r24 %r25 %r26 %r27 %r28 %r29 %r30 %r31)) (define callee-save-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)) (define isaved (length callee-save-regs))
@ -2899,12 +3016,12 @@
float-reg-offset float-reg-offset
(fx+ (fx* fp-reg-count 8) float-reg-offset))] (fx+ (fx* fp-reg-count 8) float-reg-offset))]
[synthesize-first-argument? (indirect-result-that-fits-in-registers? result-type)] [synthesize-first-argument? (indirect-result-that-fits-in-registers? result-type)]
[return-space-offset (align 8 (fx+ (fx* isaved 4) callee-save-offset))] [adjust-active? (if-feature pthreads (memq 'adjust-active (info-foreign-conv* info)) #f)]
[stack-size (align 16 (if synthesize-first-argument? [unactivate-mode-offset (fx+ (fx* isaved 4) callee-save-offset)]
(fx+ return-space-offset 8) [return-space-offset (align 8 (fx+ unactivate-mode-offset (if adjust-active? 4 0)))]
return-space-offset))] [stack-size (align 16 (fx+ return-space-offset (if synthesize-first-argument? 8 0)))]
[stack-arg-offset (fx+ stack-size 8)]) [stack-arg-offset (fx+ stack-size 8)])
(let-values ([(get-result result-regs) (do-result result-type return-space-offset int-reg-offset)]) (let-values ([(get-result result-regs result-num-fp-regs) (do-result result-type return-space-offset int-reg-offset)])
(values (values
(lambda () (lambda ()
(%seq (%seq
@ -2916,9 +3033,16 @@
; not bothering with cr, because we don't update nonvolatile fields ; not bothering with cr, because we don't update nonvolatile fields
,(save-regs callee-save-regs callee-save-offset) ,(save-regs callee-save-regs callee-save-offset)
,(if-feature pthreads ,(if-feature pthreads
(%seq ((lambda (e)
(set! ,%Cretval ,(%inline get-tc)) (if adjust-active?
(set! ,%tc ,%Cretval)) (%seq
(set! ,%Cretval ,(%inline activate-thread))
(set! ,(%mref ,%sp ,unactivate-mode-offset) ,%Cretval)
,e)
e))
(%seq
(set! ,%Cretval ,(%inline get-tc))
(set! ,%tc ,%Cretval)))
`(set! ,%tc (literal ,(make-info-literal #f 'entry (lookup-c-entry thread-context) 0)))))) `(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 ; list of procedures that marshal arguments from their C stack locations
; to the Scheme argument locations ; to the Scheme argument locations
@ -2927,6 +3051,12 @@
get-result get-result
(lambda () (lambda ()
(in-context Tail (in-context Tail
((lambda (e)
(if adjust-active?
(%seq
,(unactivate unactivate-mode-offset result-regs result-num-fp-regs int-reg-offset)
,e)
e))
(%seq (%seq
; restore the lr ; restore the lr
(inline ,null-info ,%restore-lr (immediate ,(fx+ stack-size 4))) (inline ,null-info ,%restore-lr (immediate ,(fx+ stack-size 4)))
@ -2935,5 +3065,5 @@
; deallocate space for pad & arg reg values ; deallocate space for pad & arg reg values
(set! ,%Csp ,(%inline + ,%Csp (immediate ,stack-size))) (set! ,%Csp ,(%inline + ,%Csp (immediate ,stack-size)))
; done ; done
(asm-c-return ,null-info ,callee-save-regs ... ,result-regs ...)))))))))))))) (asm-c-return ,null-info ,callee-save-regs ... ,result-regs ...)))))))))))))))
) )

115
s/syntax.ss
View File

@ -687,16 +687,16 @@
($oops #f "invalid ~a ~a specifier ~s" who what x))))) ($oops #f "invalid ~a ~a specifier ~s" who what x)))))
(define build-foreign-procedure (define build-foreign-procedure
(lambda (ae conv foreign-name foreign-addr params result) (lambda (ae conv* foreign-name foreign-addr params result)
(build-profile ae (build-profile ae
`(foreign ,conv ,foreign-name ,foreign-addr `(foreign (,conv* ...) ,foreign-name ,foreign-addr
(,(map (lambda (x) (build-fp-specifier 'foreign-procedure 'parameter x #f)) params) ...) (,(map (lambda (x) (build-fp-specifier 'foreign-procedure 'parameter x #f)) params) ...)
,(build-fp-specifier 'foreign-procedure "result" result #t))))) ,(build-fp-specifier 'foreign-procedure "result" result #t)))))
(define build-foreign-callable (define build-foreign-callable
(lambda (ae conv proc params result) (lambda (ae conv* proc params result)
(build-profile ae (build-profile ae
`(fcallable ,conv ,proc `(fcallable (,conv* ...) ,proc
(,(map (lambda (x) (build-fp-specifier 'foreign-callable 'parameter x #f)) params) ...) (,(map (lambda (x) (build-fp-specifier 'foreign-callable 'parameter x #f)) params) ...)
,(build-fp-specifier 'foreign-callable "result" result #t)))))) ,(build-fp-specifier 'foreign-callable "result" result #t))))))
@ -6023,9 +6023,9 @@
(global-extend 'core '$foreign-procedure (global-extend 'core '$foreign-procedure
(lambda (e r w ae) (lambda (e r w ae)
(syntax-case e () (syntax-case e ()
((_ conv foreign-name foreign-addr (arg ...) result) ((_ conv* foreign-name foreign-addr (arg ...) result)
(build-foreign-procedure ae (build-foreign-procedure ae
(strip (syntax conv) w) (strip (syntax conv*) w)
(strip (syntax foreign-name) w) (strip (syntax foreign-name) w)
(chi (syntax foreign-addr) r w) (chi (syntax foreign-addr) r w)
(map (lambda (x) (strip x w)) (syntax (arg ...))) (map (lambda (x) (strip x w)) (syntax (arg ...)))
@ -6034,9 +6034,9 @@
(global-extend 'core '$foreign-callable (global-extend 'core '$foreign-callable
(lambda (e r w ae) (lambda (e r w ae)
(syntax-case e () (syntax-case e ()
((_ conv proc (arg ...) result) ((_ conv* proc (arg ...) result)
(build-foreign-callable ae (build-foreign-callable ae
(strip (syntax conv) w) (strip (syntax conv*) w)
(chi (syntax proc) r w) (chi (syntax proc) r w)
(map (lambda (x) (strip x w)) (syntax (arg ...))) (map (lambda (x) (strip x w)) (syntax (arg ...)))
(strip (syntax result) w)))))) (strip (syntax result) w))))))
@ -8572,30 +8572,51 @@
[else ($oops '$fp-type->pred "unrecognized type ~s" type)])]))) [else ($oops '$fp-type->pred "unrecognized type ~s" type)])])))
(define $filter-conv (define $filter-conv
(lambda (who conv) (lambda (who conv*)
(define squawk (define squawk
(lambda (x) (lambda (x)
(syntax-error x (format "invalid ~s convention" who)))) (syntax-error x (format "invalid ~s convention" who))))
(let ([c (syntax->datum conv)]) (let loop ([conv* conv*] [accum '()] [keep-accum '()])
(if (not c) (cond
#f [(null? conv*) (datum->syntax #'filter-conv keep-accum)]
(case ($target-machine) [else
[(i3nt ti3nt) (let* ([orig-c (car conv*)]
(case c [c (syntax->datum orig-c)]
[(__stdcall) #'i3nt-stdcall] [c (cond
[(__cdecl) #f] [(not c) #f]
[(__com) #'i3nt-com] [(eq? c '__collect_safe) 'adjust-active]
[else (squawk conv)])] [else
[(ppcnt) (case ($target-machine)
(case c [(i3nt ti3nt)
[(__stdcall __cdecl) #f] (case c
[else (squawk conv)])] [(__stdcall) 'i3nt-stdcall]
[else (squawk conv)]))))) [(__cdecl) #f]
[(__com) 'i3nt-com]
[else (squawk orig-c)])]
[(ppcnt)
(case c
[(__stdcall __cdecl) #f]
[else (squawk orig-c)])]
[else (squawk orig-c)])])])
(when (member c accum)
(syntax-error orig-c (format "redundant ~s convention" who)))
(unless (or (null? accum)
(eq? c 'adjust-active)
(and (eq? 'adjust-active (car accum))
(null? (cdr accum))))
(syntax-error orig-c (format "conflicting ~s convention" who)))
(loop (cdr conv*) (cons c accum)
(if c
(cons c keep-accum)
keep-accum)))]))))
(define $make-foreign-procedure (define $make-foreign-procedure
(lambda (conv foreign-name ?foreign-addr type* result-type) (lambda (who conv* foreign-name ?foreign-addr type* result-type)
(let ([unsafe? (= (optimize-level) 3)]) (let ([unsafe? (= (optimize-level) 3)])
(with-syntax ([conv conv] (define (check-strings-allowed)
(when (memq 'adjust-active (syntax->datum conv*))
($oops who "string argument not allowed with __collect_safe procedure")))
(with-syntax ([conv* conv*]
[foreign-name foreign-name] [foreign-name foreign-name]
[?foreign-addr ?foreign-addr] [?foreign-addr ?foreign-addr]
[(t ...) (generate-temporaries type*)]) [(t ...) (generate-temporaries type*)])
@ -8637,6 +8658,7 @@
(err ($moi) x)))) (err ($moi) x))))
(unsigned-32))])] (unsigned-32))])]
[(utf-8) [(utf-8)
(check-strings-allowed)
#`(() #`(()
((if (eq? x #f) ((if (eq? x #f)
x x
@ -8647,6 +8669,7 @@
(err ($moi) x))))) (err ($moi) x)))))
(u8*))] (u8*))]
[(utf-16le) [(utf-16le)
(check-strings-allowed)
#`(() #`(()
((if (eq? x #f) ((if (eq? x #f)
x x
@ -8657,6 +8680,7 @@
(err ($moi) x))))) (err ($moi) x)))))
(u16*))] (u16*))]
[(utf-16be) [(utf-16be)
(check-strings-allowed)
#`(() #`(()
((if (eq? x #f) ((if (eq? x #f)
x x
@ -8667,6 +8691,7 @@
(err ($moi) x))))) (err ($moi) x)))))
(u16*))] (u16*))]
[(utf-32le) [(utf-32le)
(check-strings-allowed)
#`(() #`(()
((if (eq? x #f) ((if (eq? x #f)
x x
@ -8677,6 +8702,7 @@
(err ($moi) x))))) (err ($moi) x)))))
(u32*))] (u32*))]
[(utf-32be) [(utf-32be)
(check-strings-allowed)
#`(() #`(()
((if (eq? x #f) ((if (eq? x #f)
x x
@ -8745,7 +8771,7 @@
#`[] #`[]
#`[(unless (record? &-result '#,(unbox result-type)) (err ($moi) &-result))]))] #`[(unless (record? &-result '#,(unbox result-type)) (err ($moi) &-result))]))]
[else #'([] [] [])])]) [else #'([] [] [])])])
#`(let ([p ($foreign-procedure conv foreign-name ?foreign-addr (extra-arg ... arg ... ...) result)] #`(let ([p ($foreign-procedure conv* foreign-name ?foreign-addr (extra-arg ... arg ... ...) result)]
#,@(if unsafe? #,@(if unsafe?
#'() #'()
#'([err (lambda (who x) #'([err (lambda (who x)
@ -8762,25 +8788,29 @@
(or ($fp-filter-type ($expand-fp-ftype 'foreign-procedure what r x) result?) (or ($fp-filter-type ($expand-fp-ftype 'foreign-procedure what r x) result?)
(syntax-error x (format "invalid foreign-procedure ~s type specifier" what)))))) (syntax-error x (format "invalid foreign-procedure ~s type specifier" what))))))
(syntax-case x () (syntax-case x ()
[(_ ?name (arg ...) result) [(_ c ... ?name (arg ...) result)
#'(foreign-procedure #f ?name (arg ...) result)]
[(_ conv ?name (arg ...) result)
(lambda (r) (lambda (r)
($make-foreign-procedure ($make-foreign-procedure 'foreign-procedure
($filter-conv 'foreign-procedure #'conv) ($filter-conv 'foreign-procedure #'(c ...))
(let ([x (datum ?name)]) (and (string? x) x)) (let ([x (datum ?name)]) (and (string? x) x))
#'($foreign-entry ?name) #'($foreign-entry ?name)
(map (lambda (x) (filter-type r x #f)) #'(arg ...)) (map (lambda (x) (filter-type r x #f)) #'(arg ...))
(filter-type r #'result #t)))]))) (filter-type r #'result #t)))])))
(define $make-foreign-callable (define $make-foreign-callable
(lambda (who conv ?proc type* result-type) (lambda (who conv* ?proc type* result-type)
(when (eq? conv 'i3nt-com) ($oops who "unsupported convention ~s" conv)) (for-each (lambda (c)
(when (eq? (syntax->datum c) 'i3nt-com)
($oops who "unsupported convention ~s" c)))
(syntax->list conv*))
(let ([unsafe? (= (optimize-level) 3)]) (let ([unsafe? (= (optimize-level) 3)])
(with-syntax ([conv conv] [?proc ?proc]) (define (check-strings-allowed)
(when (memq 'adjust-active (syntax->datum conv*))
($oops who "string result not allowed with __collect_safe callable")))
(with-syntax ([conv* conv*] [?proc ?proc])
(with-syntax ([((actual (t ...) (arg ...)) ...) (with-syntax ([((actual (t ...) (arg ...)) ...)
(map (map
(lambda (type) (lambda (type)
(or (case type (or (case type
[(boolean) [(boolean)
(with-syntax ([(x) (generate-temporaries #'(*))]) (with-syntax ([(x) (generate-temporaries #'(*))])
@ -8907,6 +8937,7 @@
unsigned-16 unsigned-16
[] [])])] [] [])])]
[(utf-8) [(utf-8)
(check-strings-allowed)
#`((lambda (x) #`((lambda (x)
(if (eq? x #f) (if (eq? x #f)
x x
@ -8918,6 +8949,7 @@
u8* u8*
[] [])] [] [])]
[(utf-16le) [(utf-16le)
(check-strings-allowed)
#`((lambda (x) #`((lambda (x)
(if (eq? x #f) (if (eq? x #f)
x x
@ -8929,6 +8961,7 @@
u16* u16*
[] [])] [] [])]
[(utf-16be) [(utf-16be)
(check-strings-allowed)
#`((lambda (x) #`((lambda (x)
(if (eq? x #f) (if (eq? x #f)
x x
@ -8940,6 +8973,7 @@
u16* u16*
[] [])] [] [])]
[(utf-32le) [(utf-32le)
(check-strings-allowed)
#`((lambda (x) #`((lambda (x)
(if (eq? x #f) (if (eq? x #f)
x x
@ -8951,6 +8985,7 @@
u32* u32*
[] [])] [] [])]
[(utf-32be) [(utf-32be)
(check-strings-allowed)
#`((lambda (x) #`((lambda (x)
(if (eq? x #f) (if (eq? x #f)
x x
@ -8991,7 +9026,7 @@
[] []))])])]) [] []))])])])
; use a gensym to avoid giving the procedure a confusing name ; use a gensym to avoid giving the procedure a confusing name
(with-syntax ([p (datum->syntax #'foreign-callable (gensym))]) (with-syntax ([p (datum->syntax #'foreign-callable (gensym))])
#`($foreign-callable conv #`($foreign-callable conv*
(let ([p ?proc]) (let ([p ?proc])
(define (err x) (define (err x)
($oops 'foreign-callable ($oops 'foreign-callable
@ -9010,12 +9045,10 @@
(or ($fp-filter-type ($expand-fp-ftype 'foreign-callable what r x) result?) (or ($fp-filter-type ($expand-fp-ftype 'foreign-callable what r x) result?)
(syntax-error x (format "invalid foreign-callable ~s type specifier" what)))))) (syntax-error x (format "invalid foreign-callable ~s type specifier" what))))))
(syntax-case x () (syntax-case x ()
[(_ proc (arg ...) result) [(_ c ... ?proc (arg ...) result)
#'(foreign-callable #f proc (arg ...) result)]
[(_ conv ?proc (arg ...) result)
(lambda (r) (lambda (r)
($make-foreign-callable 'foreign-callable ($make-foreign-callable 'foreign-callable
($filter-conv 'foreign-callable #'conv) ($filter-conv 'foreign-callable #'(c ...))
#'?proc #'?proc
(map (lambda (x) (filter-type r x #f)) #'(arg ...)) (map (lambda (x) (filter-type r x #f)) #'(arg ...))
(filter-type r #'result #t)))]))) (filter-type r #'result #t)))])))

259
s/x86.ss
View File

@ -778,6 +778,19 @@
(safe-assert (eq? z %eax)) (safe-assert (eq? z %eax))
`(set! ,(make-live-info) ,z (asm ,info ,asm-get-tc))]) `(set! ,(make-live-info) ,z (asm ,info ,asm-get-tc))])
(define-instruction value activate-thread
[(op (z ur))
(safe-assert (eq? z %eax)) ; see get-tc
`(set! ,(make-live-info) ,z (asm ,info ,asm-activate-thread))])
(define-instruction effect deactivate-thread
[(op)
`(asm ,info ,asm-deactivate-thread)])
(define-instruction effect unactivate-thread
[(op)
`(asm ,info ,asm-unactivate-thread)])
; TODO: should we insist that asm-library-call preserve %ts and %td? ; TODO: should we insist that asm-library-call preserve %ts and %td?
; TODO: risc architectures will have to take info-asmlib-save-ra? into account ; TODO: risc architectures will have to take info-asmlib-save-ra? into account
(define-instruction value asmlibcall (define-instruction value asmlibcall
@ -925,7 +938,7 @@
asm-inc-profile-counter asm-inc-profile-counter
asm-inc-cc-counter asm-read-time-stamp-counter asm-read-performance-monitoring-counter asm-inc-cc-counter asm-read-time-stamp-counter asm-read-performance-monitoring-counter
; threaded version specific ; threaded version specific
asm-get-tc asm-get-tc asm-activate-thread asm-deactivate-thread asm-unactivate-thread
; machine dependent exports ; machine dependent exports
asm-sext-eax->edx) asm-sext-eax->edx)
@ -2104,7 +2117,22 @@
(define asm-get-tc (define asm-get-tc
(let ([target `(literal 0 (entry ,(lookup-c-entry get-thread-context)))]) (let ([target `(literal 0 (entry ,(lookup-c-entry get-thread-context)))])
(lambda (code* dest) ; dest is ignored, since it is always the first C argument (eax in this case) (lambda (code* dest) ; dest is ignored, since it is always the first C result (eax in this case)
(emit bsr target code*))))
(define asm-activate-thread
(let ([target `(literal 0 (entry ,(lookup-c-entry activate-thread)))])
(lambda (code* dest) ; dest is ignored, as in asm-get-tc
(emit bsr target code*))))
(define asm-deactivate-thread
(let ([target `(literal 0 (entry ,(lookup-c-entry deactivate-thread)))])
(lambda (code*)
(emit bsr target code*))))
(define asm-unactivate-thread
(let ([target `(literal 0 (entry ,(lookup-c-entry unactivate-thread)))])
(lambda (code*)
(emit bsr target code*)))) (emit bsr target code*))))
(define asm-indirect-call (define asm-indirect-call
@ -2281,6 +2309,43 @@
[(fp-ftd& ,ftd) (not (callee-expects-result-pointer? result-type))] [(fp-ftd& ,ftd) (not (callee-expects-result-pointer? result-type))]
[else #f]))) [else #f])))
(module (push-registers pop-registers push-registers-size)
(define (move-registers regs fp-reg-count load? offset e)
(with-output-language (L13 Effect)
(cond
[(fx> fp-reg-count 0)
(let ([offset (fx- offset 8)])
(move-registers regs (fx- fp-reg-count 1) load? offset
(cond
[load? `(seq ,(%inline fldl ,(%mref ,%sp ,offset)) ,e)]
[else `(seq ,e ,(%inline fstpl ,(%mref ,%sp ,offset)))])))]
[(pair? regs)
(let ([offset (fx- offset 4)])
(move-registers (cdr regs) 0 load? offset
(cond
[load? `(seq (set! ,(car regs) ,(%mref ,%sp ,offset)) ,e)]
[else `(seq ,e (set! ,(%mref ,%sp ,offset) ,(car regs)))])))]
[else e])))
(define (push-registers-size regs fp-reg-count arg-count)
;; Align with the expectation that `arg-count` arguments
;; will be pushed later, before a function call
(let ([offset (fx+ (fx* 4 (length regs)) (fx* 8 fp-reg-count))])
(constant-case machine-type-name
[(i3osx ti3osx)
(fx- (fxlogand (fx+ offset (fx* 4 arg-count) 15) -16)
(fx* 4 arg-count))]
[else offset])))
(define (push-registers regs fp-reg-count arg-count)
(let ([offset (push-registers-size regs fp-reg-count arg-count)])
(move-registers regs fp-reg-count #f offset
(with-output-language (L13 Effect)
`(set! ,%sp ,(%inline - ,%sp (immediate ,offset)))))))
(define (pop-registers regs fp-reg-count arg-count)
(let ([offset (push-registers-size regs fp-reg-count arg-count)])
(move-registers regs fp-reg-count #t offset
(with-output-language (L13 Effect)
`(set! ,%sp ,(%inline + ,%sp (immediate ,offset))))))))
(define asm-foreign-call (define asm-foreign-call
(with-output-language (L13 Effect) (with-output-language (L13 Effect)
(letrec ([load-double-stack (letrec ([load-double-stack
@ -2386,8 +2451,60 @@
(cons (load-stack n) locs) (cons (load-stack n) locs)
(fx+ n 4) (fx+ n 4)
#f))])))]) #f))])))])
(define (get-result-registers fill-result-here? result-type)
(cond
[fill-result-here?
(let* ([ftd (nanopass-case (Ltype Type) result-type
[(fp-ftd& ,ftd) ftd])]
[size ($ftd-size ftd)])
(case size
[(4)
(cond
[(and (if-feature windows (not ($ftd-compound? ftd)) #t)
(equal? '((float 4 0)) ($ftd->members ftd)))
(values '() 1)]
[else (values (reg-list %eax) 0)])]
[(8)
(cond
[(and (if-feature windows (not ($ftd-compound? ftd)) #t)
(equal? '((float 8 0)) ($ftd->members ftd)))
(values '() 1)]
[else (values (reg-list %eax %edx) 0)])]
[else (values (reg-list %eax) 0)]))]
[else
(nanopass-case (Ltype Type) result-type
[(fp-double-float) (values '() 1)]
[(fp-single-float) (values '() 1)]
[(fp-integer ,bits)
(case bits
[(64) (values (reg-list %eax %edx) 0)]
[else (values (reg-list %eax) 0)])]
[(fp-unsigned ,bits)
(case bits
[(64) (values (reg-list %eax %edx) 0)]
[else (values (reg-list %eax) 0)])]
[(fp-void) (values '() 0)]
[else (values (reg-list %eax) 0)])]))
(define (add-deactivate adjust-active? fill-result-here? t0 result-type e)
(cond
[adjust-active?
(let-values ([(result-regs result-fp-count) (get-result-registers fill-result-here? result-type)])
(let ([save-and-restore
(lambda (regs fp-count e)
(cond
[(and (null? regs) (fx= 0 fp-count)) e]
[else (%seq
,(push-registers regs fp-count 0)
,e
,(pop-registers regs fp-count 0))]))])
(%seq
(set! ,%edx ,t0)
,(save-and-restore (list %edx) 0 (%inline deactivate-thread))
,e
,(save-and-restore result-regs result-fp-count `(set! ,%eax ,(%inline activate-thread))))))]
[else e]))
(define returnem (define returnem
(lambda (conv orig-frame-size locs result-type ccall r-loc) (lambda (conv* orig-frame-size locs result-type ccall r-loc)
(let ([frame-size (constant-case machine-type-name (let ([frame-size (constant-case machine-type-name
; maintain 16-byte alignment not including the return address pushed ; maintain 16-byte alignment not including the return address pushed
; by the call instruction, which counts as part of callee's frame ; by the call instruction, which counts as part of callee's frame
@ -2402,7 +2519,7 @@
r-loc r-loc
; Windows __stdcall convention requires callee to clean up ; Windows __stdcall convention requires callee to clean up
(lambda () (lambda ()
(if (or (fx= frame-size 0) (memq conv '(i3nt-stdcall i3nt-com))) (if (or (fx= frame-size 0) (memq 'i3nt-stdcall conv*) (memq 'i3nt-com conv*))
`(nop) `(nop)
(let ([frame-size (if (callee-pops-result-pointer? result-type) (let ([frame-size (if (callee-pops-result-pointer? result-type)
(fx- frame-size (constant ptr-bytes)) (fx- frame-size (constant ptr-bytes))
@ -2410,28 +2527,32 @@
`(set! ,%sp ,(%inline + ,%sp (immediate ,frame-size)))))))))) `(set! ,%sp ,(%inline + ,%sp (immediate ,frame-size))))))))))
(lambda (info) (lambda (info)
(safe-assert (reg-callee-save? %tc)) ; no need to save-restore (safe-assert (reg-callee-save? %tc)) ; no need to save-restore
(let ([conv (info-foreign-conv info)] (let ([conv* (info-foreign-conv* info)]
[arg-type* (info-foreign-arg-type* info)] [arg-type* (info-foreign-arg-type* info)]
[result-type (info-foreign-result-type info)]) [result-type (info-foreign-result-type info)])
(with-values (do-stack arg-type* '() 0 result-type) (with-values (do-stack arg-type* '() 0 result-type)
(lambda (frame-size locs) (lambda (frame-size locs)
(returnem conv frame-size locs result-type (returnem conv* frame-size locs result-type
(lambda (t0) (lambda (t0)
(let ([call (let* ([fill-result-here? (fill-result-pointer-from-registers? result-type)]
(case conv [adjust-active? (if-feature pthreads (memq 'adjust-active conv*) #f)]
[(i3nt-com) [t (if adjust-active? %edx t0)] ; need a register if `adjust-active?`
(when (null? arg-type*) [call
($oops 'foreign-procedure (add-deactivate adjust-active? fill-result-here? t0 result-type
"__com convention requires instance argument")) (cond
; jump indirect [(memq 'i3nt-com conv*)
(%seq (when (null? arg-type*)
(set! ,%eax ,(%mref ,%sp 0)) ($oops 'foreign-procedure
(set! ,%eax ,(%mref ,%eax 0)) "__com convention requires instance argument"))
(set! ,%eax ,(%inline + ,%eax ,t0)) ; jump indirect
(inline ,(make-info-kill*-live* (reg-list %eax %edx) '()) ,%c-call ,(%mref ,%eax 0)))] (%seq
[else `(inline ,(make-info-kill*-live* (reg-list %eax %edx) '()) ,%c-call ,t0)])]) (set! ,%eax ,(%mref ,%sp 0))
(set! ,%eax ,(%mref ,%eax 0))
(set! ,%eax ,(%inline + ,%eax ,t))
(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 ,t)]))])
(cond (cond
[(fill-result-pointer-from-registers? result-type) [fill-result-here?
(let* ([ftd (nanopass-case (Ltype Type) result-type (let* ([ftd (nanopass-case (Ltype Type) result-type
[(fp-ftd& ,ftd) ftd])] [(fp-ftd& ,ftd) ftd])]
[size ($ftd-size ftd)]) [size ($ftd-size ftd)])
@ -2509,13 +2630,15 @@
+---------------------------+ +---------------------------+
| | | |
| incoming stack args | | incoming stack args |
sp+X+Y: | | sp+X+Y+Z: | |
+---------------------------+ <- i3osx: 16-byte boundary +---------------------------+ <- i3osx: 16-byte boundary
| incoming return address | one word | incoming return address | one word
+---------------------------+ +---------------------------+
| | | |
| callee-save registers | EBP, ESI, EDI, EBX (4 words) | callee-save registers | EBP, ESI, EDI, EBX (4 words)
sp+X: | | sp+X+Y: | |
+---------------------------+
sp+X: | unactivate mode | 0 words or 1 word
+---------------------------+ +---------------------------+
| indirect result space | i3osx: 3 words | indirect result space | i3osx: 3 words
| (for & results via regs) | other: 2 words | (for & results via regs) | other: 2 words
@ -2610,38 +2733,46 @@
(equal? '((float 4 0)) ($ftd->members ftd))) (equal? '((float 4 0)) ($ftd->members ftd)))
(values (lambda () (values (lambda ()
(%inline flds ,(%mref ,%sp 0))) (%inline flds ,(%mref ,%sp 0)))
'())] '()
1)]
[(and (if-feature windows (not ($ftd-compound? ftd)) #t) [(and (if-feature windows (not ($ftd-compound? ftd)) #t)
(equal? '((float 8 0)) ($ftd->members ftd))) (equal? '((float 8 0)) ($ftd->members ftd)))
(values (lambda () (values (lambda ()
(%inline fldl ,(%mref ,%sp 0))) (%inline fldl ,(%mref ,%sp 0)))
'())] '()
1)]
[(fx= ($ftd-size ftd) 8) [(fx= ($ftd-size ftd) 8)
(values (lambda () (values (lambda ()
`(seq `(seq
(set! ,%eax ,(%mref ,%sp 0)) (set! ,%eax ,(%mref ,%sp 0))
(set! ,%edx ,(%mref ,%sp 4)))) (set! ,%edx ,(%mref ,%sp 4))))
(list %eax %edx))] (list %eax %edx)
0)]
[else [else
(values (lambda () (values (lambda ()
`(set! ,%eax ,(%mref ,%sp 0))) `(set! ,%eax ,(%mref ,%sp 0)))
(list %eax))])] (list %eax)
0)])]
[else [else
(values (lambda () (values (lambda ()
;; Return pointer that was filled; destination was the first argument ;; Return pointer that was filled; destination was the first argument
`(set! ,%eax ,(%mref ,%sp ,init-stack-offset))) `(set! ,%eax ,(%mref ,%sp ,init-stack-offset)))
(list %eax))])] (list %eax)
0)])]
[(fp-double-float) [(fp-double-float)
(values (lambda (x) (values (lambda (x)
(%inline fldl ,(%mref ,x ,(constant flonum-data-disp)))) (%inline fldl ,(%mref ,x ,(constant flonum-data-disp))))
'())] '()
1)]
[(fp-single-float) [(fp-single-float)
(values (lambda (x) (values (lambda (x)
(%inline fldl ,(%mref ,x ,(constant flonum-data-disp)))) (%inline fldl ,(%mref ,x ,(constant flonum-data-disp))))
'())] '()
1)]
[(fp-void) [(fp-void)
(values (lambda () `(nop)) (values (lambda () `(nop))
'())] '()
0)]
[else [else
(cond (cond
[(nanopass-case (Ltype Type) result-type [(nanopass-case (Ltype Type) result-type
@ -2652,25 +2783,42 @@
(%seq (%seq
(set! ,%eax ,lorhs) (set! ,%eax ,lorhs)
(set! ,%edx ,hirhs))) (set! ,%edx ,hirhs)))
(list %eax %edx))] (list %eax %edx)
0)]
[else [else
(values (lambda (x) (values (lambda (x)
`(set! ,%eax ,x)) `(set! ,%eax ,x))
(list %eax))])])) (list %eax)
0)])]))
(define (unactivate result-regs result-num-fp-regs)
(let ([e (%seq
(set! ,%eax ,(%mref ,%sp ,(+ 8 (push-registers-size result-regs result-num-fp-regs 1))))
,(%inline push ,%eax)
,(%inline unactivate-thread)
,(%inline pop ,%eax))])
(if (and (null? result-regs) (fx= 0 result-num-fp-regs))
e
(%seq
,(push-registers result-regs result-num-fp-regs 1)
,e
,(pop-registers result-regs result-num-fp-regs 1)))))
(lambda (info) (lambda (info)
(let ([conv (info-foreign-conv info)] (let* ([conv* (info-foreign-conv* info)]
[arg-type* (info-foreign-arg-type* info)] [adjust-active? (if-feature pthreads (memq 'adjust-active conv*) #f)]
[result-type (info-foreign-result-type info)] [arg-type* (info-foreign-arg-type* info)]
[init-stack-offset (constant-case machine-type-name [(i3osx ti3osx) 32] [else 28])] [result-type (info-foreign-result-type info)]
[indirect-result-space (constant-case machine-type-name [indirect-result-space (constant-case machine-type-name
[(i3osx ti3osx) [(i3osx ti3osx)
;; maintain 16-bit alignment for i3osx, taking into account ;; maintain 16-bit alignment for i3osx, taking into account
;; 16 bytes pushed above + 4 for RA pushed by asmCcall; ;; 16 bytes pushed above + 4 for RA pushed by asmCcall;
;; 8 of these bytes are used for &-return space, if needed ;; 8 of these bytes are used for &-return space, if needed;
12] ;; the extra 4 bytes may be used for the unactivate mode
[else 8])]) 12]
(let ([indirect-result-to-registers? (fill-result-pointer-from-registers? result-type)]) [else (if adjust-active? 12 8)])]
(let-values ([(get-result result-regs) (do-result result-type init-stack-offset indirect-result-to-registers?)]) [init-stack-offset (fx+ 20 indirect-result-space)]
[indirect-result-to-registers? (fill-result-pointer-from-registers? result-type)])
(let-values ([(get-result result-regs result-num-fp-regs)
(do-result result-type init-stack-offset indirect-result-to-registers?)])
(with-values (do-stack (if indirect-result-to-registers? (with-values (do-stack (if indirect-result-to-registers?
(cdr arg-type*) (cdr arg-type*)
arg-type*) arg-type*)
@ -2686,9 +2834,16 @@
,(%inline push ,%ebx) ,(%inline push ,%ebx)
(set! ,%sp ,(%inline - ,%sp (immediate ,indirect-result-space))) (set! ,%sp ,(%inline - ,%sp (immediate ,indirect-result-space)))
,(if-feature pthreads ,(if-feature pthreads
`(seq ((lambda (e)
(set! ,%eax ,(%inline get-tc)) (if adjust-active?
(set! ,%tc ,%eax)) (%seq
(set! ,%eax ,(%inline activate-thread))
(set! ,(%mref ,%sp ,8) ,%eax)
,e)
e))
`(seq
(set! ,%eax ,(%inline get-tc))
(set! ,%tc ,%eax)))
`(set! ,%tc (literal ,(make-info-literal #f 'entry (lookup-c-entry thread-context) 0)))))) `(set! ,%tc (literal ,(make-info-literal #f 'entry (lookup-c-entry thread-context) 0))))))
(let ([locs (reverse locs)]) (let ([locs (reverse locs)])
(if indirect-result-to-registers? (if indirect-result-to-registers?
@ -2698,6 +2853,12 @@
get-result get-result
(lambda () (lambda ()
(in-context Tail (in-context Tail
((lambda (e)
(if adjust-active?
(%seq
,(unactivate result-regs result-num-fp-regs)
,e)
e))
(%seq (%seq
(set! ,%sp ,(%inline + ,%sp (immediate ,indirect-result-space))) (set! ,%sp ,(%inline + ,%sp (immediate ,indirect-result-space)))
(set! ,%ebx ,(%inline pop)) (set! ,%ebx ,(%inline pop))
@ -2706,7 +2867,7 @@
(set! ,%ebp ,(%inline pop)) (set! ,%ebp ,(%inline pop))
; Windows __stdcall convention requires callee to clean up ; Windows __stdcall convention requires callee to clean up
,((lambda (e) ,((lambda (e)
(if (memq conv '(i3nt-stdcall i3nt-com)) (if (or (memq 'i3nt-stdcall conv*) (memq 'i3nt-com conv*))
(let ([arg-size (fx- frame-size init-stack-offset)]) (let ([arg-size (fx- frame-size init-stack-offset)])
(if (fx> arg-size 0) (if (fx> arg-size 0)
(%seq (%seq

203
s/x86_64.ss
View File

@ -28,7 +28,7 @@
[%xp %r12 #t 12] [%xp %r12 #t 12]
[%ts %rax %Cretval #f 0] [%ts %rax %Cretval #f 0]
[%td %rbx #t 3] [%td %rbx #t 3]
[%ac1 %r10 #f 10] [%ac1 %r10 %deact #f 10]
[%yp %r11 #f 11] [%yp %r11 #f 11]
[%cp %r15 #t 15] [%cp %r15 #t 15]
[#;%ret %rsi #t 6] [#;%ret %rsi #t 6]
@ -57,7 +57,7 @@
[%xp %r12 #t 12] [%xp %r12 #t 12]
[%ts %rax %Cretval #f 0] [%ts %rax %Cretval #f 0]
[%td %rbx #t 3] [%td %rbx #t 3]
[%ac1 %r10 #f 10] [%ac1 %r10 %deact #f 10]
[%yp %r11 #f 11] [%yp %r11 #f 11]
[%cp %r15 #t 15] [%cp %r15 #t 15]
[#;%ret %r8 %Carg5 #f 8] [#;%ret %r8 %Carg5 #f 8]
@ -824,6 +824,20 @@
(safe-assert (eq? z %rax)) (safe-assert (eq? z %rax))
`(set! ,(make-live-info) ,z (asm ,info ,asm-get-tc))]) `(set! ,(make-live-info) ,z (asm ,info ,asm-get-tc))])
(define-instruction value activate-thread
[(op (z ur))
(safe-assert (eq? z %rax)) ; see get-tc
`(set! ,(make-live-info) ,z (asm ,info ,asm-activate-thread))])
(define-instruction effect deactivate-thread
[(op)
`(asm ,info ,asm-deactivate-thread)])
(define-instruction effect unactivate-thread
[(op (x ur))
(safe-assert (eq? x %Carg1))
`(asm ,info ,asm-unactivate-thread ,x)])
; TODO: risc architectures will have to take info-asmlib-save-ra? into account ; TODO: risc architectures will have to take info-asmlib-save-ra? into account
(define-instruction value asmlibcall (define-instruction value asmlibcall
[(op (z ur)) [(op (z ur))
@ -982,7 +996,7 @@
asm-inc-profile-counter asm-inc-profile-counter
asm-inc-cc-counter asm-read-time-stamp-counter asm-read-performance-monitoring-counter asm-inc-cc-counter asm-read-time-stamp-counter asm-read-performance-monitoring-counter
; threaded version specific ; threaded version specific
asm-get-tc asm-get-tc asm-activate-thread asm-deactivate-thread asm-unactivate-thread
; machine dependent exports ; machine dependent exports
asm-sext-rax->rdx asm-store-single->double asm-kill asm-get-double) asm-sext-rax->rdx asm-store-single->double asm-kill asm-get-double)
@ -2219,6 +2233,21 @@
(lambda (code* jmp-reg) ; dest is ignored, since it is always the first C argument (rax in this case) (lambda (code* jmp-reg) ; dest is ignored, since it is always the first C argument (rax in this case)
(asm-helper-call code* target jmp-reg)))) (asm-helper-call code* target jmp-reg))))
(define asm-activate-thread
(let ([target `(x86_64-call 0 (entry ,(lookup-c-entry activate-thread)))])
(lambda (code* jmp-reg)
(asm-helper-call code* target jmp-reg))))
(define asm-deactivate-thread
(let ([target `(x86_64-call 0 (entry ,(lookup-c-entry deactivate-thread)))])
(lambda (code*)
(asm-helper-call code* target %rax))))
(define asm-unactivate-thread
(let ([target `(x86_64-call 0 (entry ,(lookup-c-entry unactivate-thread)))])
(lambda (code* arg-reg)
(asm-helper-call code* target %rax))))
(define asm-indirect-call (define asm-indirect-call
(lambda (code* t . ignore) (lambda (code* t . ignore)
; NB: c-call is already required to be a register or memory operand, so ; NB: c-call is already required to be a register or memory operand, so
@ -2494,6 +2523,47 @@
(fx> (fx+ iint ints) 6) (fx> (fx+ iint ints) 6)
(fx> (fx+ ifp fps) 8))) (fx> (fx+ ifp fps) 8)))
(module (push-registers pop-registers push-registers-size)
(define (move-registers regs load?)
(define vfp (make-vfp))
(define (fp-reg? reg)
(let loop ([i (fx- (vector-length vfp) 1)])
(or (eq? reg (vector-ref vfp i))
(and (fx> i 0) (loop (fx- i 1))))))
(with-output-language (L13 Effect)
(let loop ([regs regs] [offset 0])
(let* ([reg (car regs)]
[e (cond
[(fp-reg? reg)
`(inline ,(make-info-loadfl reg) ,(if load? %load-double %store-double) ,%sp ,%zero (immediate ,offset))]
[load? `(set! ,reg ,(%mref ,%sp ,offset))]
[else `(set! ,(%mref ,%sp ,offset) ,reg)])]
[regs (cdr regs)])
(if (null? regs)
e
`(seq ,e ,(loop regs (fx+ offset 8))))))))
(define (push-registers-size regs)
(align (fx* 8 (length regs)) 16))
(define (push-registers regs)
(with-output-language (L13 Effect)
(%seq
(set! ,%sp ,(%inline - ,%sp (immediate ,(push-registers-size regs))))
,(move-registers regs #f))))
(define (pop-registers regs)
(with-output-language (L13 Effect)
(%seq
,(move-registers regs #t)
(set! ,%sp ,(%inline + ,%sp (immediate ,(push-registers-size regs))))))))
(define (as-c-call e)
(if-feature windows
(with-output-language (L13 Effect)
(%seq
(set! ,%sp ,(%inline - ,%sp (immediate 32)))
,e
(set! ,%sp ,(%inline + ,%sp (immediate 32)))))
e))
(define asm-foreign-call (define asm-foreign-call
(with-output-language (L13 Effect) (with-output-language (L13 Effect)
(letrec ([load-double-stack (letrec ([load-double-stack
@ -2737,6 +2807,20 @@
(loop (cdr types) (loop (cdr types)
(cons (load-int-stack isp) locs) (cons (load-int-stack isp) locs)
regs iint ifp (fx+ isp 8)))])))))]) regs iint ifp (fx+ isp 8)))])))))])
(define (add-deactivate adjust-active? t0 live* result-live* e)
(cond
[adjust-active?
(let ([save-and-restore
(lambda (regs e)
(cond
[(null? regs) e]
[else (%seq ,(push-registers regs) ,e ,(pop-registers regs))]))])
(%seq
(set! ,%deact ,t0)
,(save-and-restore (cons %deact live*) (as-c-call (%inline deactivate-thread)))
,e
,(save-and-restore result-live* (as-c-call `(set! ,%rax ,(%inline activate-thread))))))]
[else e]))
(define (add-save-fill-target fill-result-here? frame-size locs) (define (add-save-fill-target fill-result-here? frame-size locs)
(cond (cond
[fill-result-here? [fill-result-here?
@ -2766,6 +2850,20 @@
`(seq `(seq
,(loop (cdr classes) (fx+ offset 8) (cdr iregs) fpregs) ,(loop (cdr classes) (fx+ offset 8) (cdr iregs) fpregs)
(set! ,(%mref ,%rcx ,offset) ,(car iregs)))]))) (set! ,(%mref ,%rcx ,offset) ,(car iregs)))])))
(define (get-result-regs fill-result-here? result-type result-classes)
(if fill-result-here?
(let loop ([classes result-classes] [iregs (reg-list %rax %rdx)] [fpregs (reg-list %Cfparg1 %Cfparg2)])
(cond
[(null? classes) '()]
[(eq? 'sse (car classes))
(cons (car fpregs) (loop (cdr classes) iregs (cdr fpregs)))]
[else
(cons (car iregs) (loop (cdr classes) (cdr iregs) fpregs))]))
(nanopass-case (Ltype Type) result-type
[(fp-double-float) (list %Cfpretval)]
[(fp-single-float) (list %Cfpretval)]
[(fp-void) '()]
[else (list %rax)])))
(define returnem (define returnem
(lambda (frame-size locs ccall r-loc) (lambda (frame-size locs ccall r-loc)
; need to maintain 16-byte alignment, ignoring the return address ; need to maintain 16-byte alignment, ignoring the return address
@ -2785,28 +2883,32 @@
`(set! ,%sp ,(%inline + ,%sp (immediate ,frame-size))))))))) `(set! ,%sp ,(%inline + ,%sp (immediate ,frame-size)))))))))
(lambda (info) (lambda (info)
(safe-assert (reg-callee-save? %tc)) ; no need to save-restore (safe-assert (reg-callee-save? %tc)) ; no need to save-restore
(let* ([conv (info-foreign-conv info)] (let* ([conv* (info-foreign-conv* info)]
[arg-type* (info-foreign-arg-type* info)] [arg-type* (info-foreign-arg-type* info)]
[result-type (info-foreign-result-type info)] [result-type (info-foreign-result-type info)]
[result-classes (classify-type result-type)] [result-classes (classify-type result-type)]
[fill-result-here? (result-fits-in-registers? result-classes)]) [fill-result-here? (result-fits-in-registers? result-classes)]
[adjust-active? (if-feature pthreads (memq 'adjust-active conv*) #f)])
(with-values (do-args (if fill-result-here? (cdr arg-type*) arg-type*) (make-vint) (make-vfp)) (with-values (do-args (if fill-result-here? (cdr arg-type*) arg-type*) (make-vint) (make-vfp))
(lambda (frame-size nfp locs live*) (lambda (frame-size nfp locs live*)
(with-values (add-save-fill-target fill-result-here? frame-size locs) (with-values (add-save-fill-target fill-result-here? frame-size locs)
(lambda (frame-size locs) (lambda (frame-size locs)
(returnem frame-size locs (returnem frame-size locs
(lambda (t0) (lambda (t0)
(let ([c-call (let* ([t (if adjust-active? %deact t0)] ; need a register if `adjust-active?`
(if-feature windows [c-call
(%seq (add-deactivate adjust-active? t0 live*
(set! ,%sp ,(%inline - ,%sp (immediate 32))) (get-result-regs fill-result-here? result-type result-classes)
(inline ,(make-info-kill*-live* (reg-list %rax) live*) ,%c-call ,t0) (if-feature windows
(set! ,%sp ,(%inline + ,%sp (immediate 32)))) (%seq
(%seq (set! ,%sp ,(%inline - ,%sp (immediate 32)))
;; System V ABI varargs functions require count of fp regs used in %al register. (inline ,(make-info-kill*-live* (reg-list %rax %rdx) live*) ,%c-call ,t)
;; since we don't know if the callee is a varargs function, we always set it. (set! ,%sp ,(%inline + ,%sp (immediate 32))))
(set! ,%rax (immediate ,nfp)) (%seq
(inline ,(make-info-kill*-live* (reg-list %rax) (cons %rax live*)) ,%c-call ,t0)))]) ;; 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 %rdx) (cons %rax live*)) ,%c-call ,t))))])
(cond (cond
[fill-result-here? [fill-result-here?
(add-fill-result c-call (fx- frame-size (constant ptr-bytes)) result-classes)] (add-fill-result c-call (fx- frame-size (constant ptr-bytes)) result-classes)]
@ -2851,10 +2953,12 @@
+---------------------------+ <- 16-byte boundary +---------------------------+ <- 16-byte boundary
| | | |
| space for register args | four quads | space for register args | four quads
sp+80: | | sp+80/96: | |
+---------------------------+ <- 16-byte boundary +---------------------------+ <- 16-byte boundary
| incoming return address | one quad | incoming return address | one quad
incoming sp: +---------------------------+ incoming sp: +---------------------------+
sp+72: | active state | zero or two quads
+---------------------------+
| | | |
| callee-save registers | RBX, RBP, RDI, RSI, R12, R13, R14, R15 (8 quads) | callee-save registers | RBX, RBP, RDI, RSI, R12, R13, R14, R15 (8 quads)
| | | |
@ -2872,10 +2976,10 @@
+---------------------------+ <- 16-byte boundary +---------------------------+ <- 16-byte boundary
| incoming return address | one quad | incoming return address | one quad
+---------------------------+ +---------------------------+
| pad word | one quad sp+176: | pad word / active state | one quad
+---------------------------+ +---------------------------+
| indirect result space | two quads | indirect result space | two quads
sp+160 | (for & results via regs) | sp+160: | (for & results via regs) |
+---------------------------+<- 16-byte boundary +---------------------------+<- 16-byte boundary
| | | |
| saved register args | space for Carg*, Cfparg* (14 quads) | saved register args | space for Carg*, Cfparg* (14 quads)
@ -3038,11 +3142,11 @@
,(f (cdr types) (fx+ iint 1) ifp (fx+ isp 8))) ,(f (cdr types) (fx+ iint 1) ifp (fx+ isp 8)))
(f (cdr types) iint ifp isp))])))))) (f (cdr types) iint ifp isp))]))))))
(define do-stack (define do-stack
(lambda (types) (lambda (types adjust-active?)
; risp is where incoming register args are stored ; risp is where incoming register args are stored
; sisp is where incoming stack args are stored ; sisp is where incoming stack args are stored
(if-feature windows (if-feature windows
(let f ([types types] [locs '()] [isp 80]) (let f ([types types] [locs '()] [isp (if adjust-active? 96 80)])
(if (null? types) (if (null? types)
locs locs
(f (cdr types) (f (cdr types)
@ -3111,7 +3215,7 @@
(f (cdr types) (f (cdr types)
(cons (load-int-stack (car types) risp) locs) (cons (load-int-stack (car types) risp) locs)
(fx+ iint 1) ifp (fx+ risp 8) sisp))])))))) (fx+ iint 1) ifp (fx+ risp 8) sisp))]))))))
(define (do-result result-type result-classes) (define (do-result result-type result-classes adjust-active?)
(nanopass-case (Ltype Type) result-type (nanopass-case (Ltype Type) result-type
[(fp-ftd& ,ftd) [(fp-ftd& ,ftd)
(cond (cond
@ -3148,7 +3252,7 @@
[else [else
(values (lambda () (values (lambda ()
;; Return pointer that was filled; destination was the first argument ;; Return pointer that was filled; destination was the first argument
`(set! ,%Cretval ,(%mref ,%sp ,(if-feature windows 80 48)))) `(set! ,%Cretval ,(%mref ,%sp ,(if-feature windows (if adjust-active? 96 80) 48))))
(list %Cretval))])] (list %Cretval))])]
[(fp-double-float) [(fp-double-float)
(values (values
@ -3167,21 +3271,37 @@
(values(lambda (x) (values(lambda (x)
`(set! ,%Cretval ,x)) `(set! ,%Cretval ,x))
(list %Cretval))])) (list %Cretval))]))
(define (unactivate result-regs)
(let ([e `(seq
(set! ,%Carg1 ,(%mref ,%sp ,(+ (push-registers-size result-regs) (if-feature windows 72 176))))
,(as-c-call (%inline unactivate-thread ,%Carg1)))])
(if (null? result-regs)
e
(%seq
,(push-registers result-regs)
,e
,(pop-registers result-regs)))))
(lambda (info) (lambda (info)
(let ([conv (info-foreign-conv info)] (let ([conv* (info-foreign-conv* info)]
[arg-type* (info-foreign-arg-type* info)] [arg-type* (info-foreign-arg-type* info)]
[result-type (info-foreign-result-type info)]) [result-type (info-foreign-result-type info)])
(let* ([result-classes (classify-type result-type)] (let* ([result-classes (classify-type result-type)]
[adjust-active? (if-feature pthreads (memq 'adjust-active conv*) #f)]
[synthesize-first? (and result-classes [synthesize-first? (and result-classes
(result-fits-in-registers? result-classes))] (result-fits-in-registers? result-classes))]
[locs (do-stack (if synthesize-first? (cdr arg-type*) arg-type*))]) [locs (do-stack (if synthesize-first? (cdr arg-type*) arg-type*) adjust-active?)])
(let-values ([(get-result result-regs) (do-result result-type result-classes)]) (let-values ([(get-result result-regs) (do-result result-type result-classes adjust-active?)])
(values (values
(lambda () (lambda ()
(%seq (%seq
,(if-feature windows ,(if-feature windows
(%seq (%seq
,(save-arg-regs arg-type*) ,(let ([e (save-arg-regs arg-type*)])
(if adjust-active?
(%seq
,e
(set! ,%sp ,(%inline - ,%sp (immediate 16))))
e))
,(%inline push ,%rbx) ,(%inline push ,%rbx)
,(%inline push ,%rbp) ,(%inline push ,%rbp)
,(%inline push ,%rdi) ,(%inline push ,%rdi)
@ -3201,9 +3321,16 @@
,(%inline push ,%r15) ,(%inline push ,%r15)
,(save-arg-regs arg-type*))) ,(save-arg-regs arg-type*)))
,(if-feature pthreads ,(if-feature pthreads
(%seq ((lambda (e)
(if adjust-active?
(%seq
,(as-c-call `(set! ,%rax ,(%inline activate-thread)))
(set! ,(%mref ,%sp ,(if-feature windows 72 176)) ,%rax)
,e)
e))
(%seq
(set! ,%rax ,(%inline get-tc)) (set! ,%rax ,(%inline get-tc))
(set! ,%tc ,%rax)) (set! ,%tc ,%rax)))
`(set! ,%tc (literal ,(make-info-literal #f 'entry (lookup-c-entry thread-context) 0)))))) `(set! ,%tc (literal ,(make-info-literal #f 'entry (lookup-c-entry thread-context) 0))))))
(let ([locs (reverse locs)]) (let ([locs (reverse locs)])
(if synthesize-first? (if synthesize-first?
@ -3213,9 +3340,19 @@
get-result get-result
(lambda () (lambda ()
(in-context Tail (in-context Tail
(%seq ((lambda (e)
(if adjust-active?
(%seq
,(unactivate result-regs)
,e)
e))
(%seq
,(if-feature windows ,(if-feature windows
(%seq ((lambda (e)
(if adjust-active?
(%seq ,e (set! ,%sp ,(%inline + ,%sp (immediate 16))))
e))
(%seq
(set! ,%sp ,(%inline + ,%sp (immediate 8))) (set! ,%sp ,(%inline + ,%sp (immediate 8)))
(set! ,%r15 ,(%inline pop)) (set! ,%r15 ,(%inline pop))
(set! ,%r14 ,(%inline pop)) (set! ,%r14 ,(%inline pop))
@ -3224,7 +3361,7 @@
(set! ,%rsi ,(%inline pop)) (set! ,%rsi ,(%inline pop))
(set! ,%rdi ,(%inline pop)) (set! ,%rdi ,(%inline pop))
(set! ,%rbp ,(%inline pop)) (set! ,%rbp ,(%inline pop))
(set! ,%rbx ,(%inline pop))) (set! ,%rbx ,(%inline pop))))
(%seq (%seq
(set! ,%r15 ,(%inline pop)) (set! ,%r15 ,(%inline pop))
(set! ,%r14 ,(%inline pop)) (set! ,%r14 ,(%inline pop))
@ -3233,5 +3370,5 @@
(set! ,%rbp ,(%inline pop)) (set! ,%rbp ,(%inline pop))
(set! ,%rbx ,(%inline pop)) (set! ,%rbx ,(%inline pop))
(set! ,%sp ,(%inline + ,%sp (immediate 136))))) (set! ,%sp ,(%inline + ,%sp (immediate 136)))))
(asm-c-return ,null-info ,result-regs ...))))))))))))) (asm-c-return ,null-info ,result-regs ...))))))))))))))
) )