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
compile-whole-program
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 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 INT S_activate_thread PROTO((void));
extern void S_unactivate_thread PROTO((int mode));
#endif
/* scheme.c */

8
c/prim.c
View File

@ -124,6 +124,9 @@ static void create_c_entry_vector() {
#ifdef PTHREADS
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_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 */
install_c_entry(CENTRY_handle_values_error, proc2ptr(S_handle_values_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++) {
#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 */
if (Svector_ref(S_G.c_entry_vector, i) == Sfalse) {
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 */
ptr tc = get_thread_context();
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
\formdef{foreign-procedure}{\categorysyntax}{(foreign-procedure \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})}
\formdef{foreign-procedure}{\categorysyntax}{(foreign-procedure \var{conv} \dots \var{entry-exp} (\var{param-type} \dots) \var{res-type})}
\returns a procedure
\listlibraries
\endentryheader
@ -213,13 +212,15 @@ by the \var{res-type}.
Multiple procedures may be created for the same \index{foreign entry}foreign entry.
\label{page:conv-description}%
If \var{conv} is present, it specifies the calling convention to be used.
The default is \scheme{#f}, which specifies the default calling convention
on the target machine.
Three other conventions are currently supported, all only under
Windows: \scheme{__stdcall}, \scheme{__cdecl}, and \scheme{__com}.
Each \var{conv} adjusts specifies the calling convention to be used.
A \scheme{#f} is allowed as \var{conv} to indicate the default calling convention
on the target machine (so the \scheme{#f} has no effect).
Three other conventions are currently supported under
Windows: \scheme{__stdcall}, \scheme{__cdecl}, and \scheme{__com} (32-bit only).
Since \scheme{__cdecl} is the default, specifying \scheme{__cdecl} is
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{__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
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
\index{\scheme{scheme-object}}\scheme{scheme-object},
\index{\scheme{string}}\scheme{string},
@ -266,14 +297,29 @@ and
\index{\scheme{utf-32be}}\scheme{utf-32be},
must be used with caution, however, since they allow allocated
Scheme objects to be used in places the Scheme memory management system
cannot control.
No problems will arise as long as such objects are not
retained in
foreign variables or data structures while Scheme code is running,
since garbage collection can occur only while Scheme code is running.
All other parameter types are converted to equivalent foreign
representations and consequently can be retained indefinitely in
cannot control. No problems will arise as long as such objects are not
retained in foreign variables or data structures while Scheme code is running,
and as long as they are not passed as arguments to a \scheme{__collect_safe} procedure,
since garbage collection can occur only while Scheme code is running
or when concurrent garbage collection is enabled.
Other parameter types are converted to equivalent foreign
representations and consequently they can be retained indefinitely in
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:
\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.
The bytevector should not be retained in foreign variables or data
structures, since the memory management system may relocate or discard
them between foreign procedure calls, and use their storage for some
other purpose.
them between foreign procedure calls and use their storage for some
other purpose. The \scheme{utf-8} argument type is not allowed for a
\scheme{__collect_safe} foreign procedure.
\foreigntype{\scheme{utf-16le}}
\index{\scheme{utf-16le}}Arguments of this type are treated like arguments
@ -976,8 +1023,7 @@ function ftype (Section~\ref{SECTFOREIGNDATA}).
%----------------------------------------------------------------------------
\entryheader
\formdef{foreign-callable}{\categorysyntax}{(foreign-callable \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})}
\formdef{foreign-callable}{\categorysyntax}{(foreign-callable \var{conv} \dots \var{proc-exp} (\var{param-type} \dots) \var{res-type})}
\returns a code object
\listlibraries
\endentryheader
@ -1002,9 +1048,16 @@ since the parameter
values are provided by the foreign code and must be assumed to be
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-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,
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
(foreign-procedure "register_callback" (char void*) void))
(define event-loop
(foreign-procedure "event_loop" () void))
(foreign-procedure __collect_safe "event_loop" () void))
\endschemedisplay
\noindent
@ -1101,7 +1154,7 @@ A callback for selected characters can then be defined.
\schemedisplay
(define callback
(lambda (p)
(let ([code (foreign-callable p (char) void)])
(let ([code (foreign-callable __collect_safe p (char) void)])
(lock-object code)
(foreign-callable-entry-point code))))
(define ouch
@ -1135,7 +1188,10 @@ Ouch! Hit by 'e'
\endschemedisplay
\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
registered as a callback.
@ -1440,8 +1496,7 @@ An \var{ftype} must take one of the following forms:
(array \var{length} \var{ftype})
(* \var{ftype})
(bits (\var{field-name} \var{signedness} \var{bits}) \dots)
(function (\var{ftype} \dots) \var{ftype})
(function \var{conv} (\var{ftype} \dots) \var{ftype})
(function \var{conv} \dots (\var{ftype} \dots) \var{ftype})
(packed \var{ftype})
(unpacked \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
thread created by some mechanism other than \scheme{fork-thread} must,
however, be activated before before it can access Scheme data or execute
Scheme code.
\scheme{Sactivate_thread} is used for this purpose.
Scheme code. A foreign callable that is declared with \scheme{__collect_safe}
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
subsequent call.
subsequent call until the activation is destroyed with \scheme{Sdestroy_thread}.
Since active threads operating in C code prevent the storage management
system from garbage collecting,
a thread should be deactivated via \scheme{Sdeactivate_thread} whenever
it may spend a significant amount of time in C code.
a thread should be deactivated via \scheme{Sdeactivate_thread} or
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
function, like \scheme{read}, that may block indefinitely.
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
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
cc -o cat_flush cat_flush.c

2
mats/Mf-ta6le
View File

@ -21,7 +21,7 @@ fobj = foreign1.so
include Mf-base
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
cc -o cat_flush cat_flush.c

2
mats/Mf-ta6nb
View File

@ -21,7 +21,7 @@ fobj = foreign1.so
include Mf-base
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
cc -o cat_flush cat_flush.c

2
mats/Mf-ta6ob
View File

@ -21,7 +21,7 @@ fobj = foreign1.so
include Mf-base
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
cc -o cat_flush cat_flush.c

2
mats/Mf-ta6osx
View File

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

2
mats/Mf-ti3fb
View File

@ -21,7 +21,7 @@ fobj = foreign1.so
include Mf-base
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
cc -o cat_flush cat_flush.c

2
mats/Mf-ti3le
View File

@ -21,7 +21,7 @@ fobj = foreign1.so
include Mf-base
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
cc -o cat_flush cat_flush.c

2
mats/Mf-ti3nb
View File

@ -21,7 +21,7 @@ fobj = foreign1.so
include Mf-base
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
cc -o cat_flush cat_flush.c

2
mats/Mf-ti3ob
View File

@ -21,7 +21,7 @@ fobj = foreign1.so
include Mf-base
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
cc -o cat_flush cat_flush.c

2
mats/Mf-ti3osx
View File

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

2
mats/Mf-tppc32le
View File

@ -21,7 +21,7 @@ fobj = foreign1.so
include Mf-base
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
cc -o cat_flush cat_flush.c

231
mats/foreign.ms
View File

@ -2682,49 +2682,49 @@
(define-ftype i64 integer-64)
(define-syntax check*
(syntax-rules ()
[(_ T s [vi ...] [T-ref ...] [T-set! ...])
[(_ (conv ...) T s [vi ...] [T-ref ...] [T-set! ...])
(let ()
(define-ftype callback (function ((& T)) double))
(define-ftype callback-two (function ((& T) (& T)) double))
(define-ftype pre-int-callback (function (int (& T)) double))
(define-ftype pre-double-callback (function (double (& T)) double))
(define-ftype callback-r (function () (& T)))
(define get (foreign-procedure (format "f4_get~a" s)
(define-ftype callback (function conv ... ((& T)) double))
(define-ftype callback-two (function conv ... ((& T) (& T)) double))
(define-ftype pre-int-callback (function conv ... (int (& T)) double))
(define-ftype pre-double-callback (function conv ... (double (& T)) double))
(define-ftype callback-r (function conv ... () (& T)))
(define get (foreign-procedure conv ... (format "f4_get~a" s)
() (& T)))
(define sum (foreign-procedure (format "f4_sum~a" s)
(define sum (foreign-procedure conv ... (format "f4_sum~a" s)
((& 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))
(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))
(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))
(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))
(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))
(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))
(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))
(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))
(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))
(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))
(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))
(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))
(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))
(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))
(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))
(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))
(define-syntax with-callback
(syntax-rules ()
@ -2788,6 +2788,11 @@
(begin
(free_at_boundary (ftype-pointer-address a))
#t)))))]))
(define-syntax check*t
(syntax-rules ()
[(_ arg ...)
(and (check* () arg ...)
(check* (__collect_safe) arg ...))]))
(define-syntax check-n
(syntax-rules ()
[(_ [ni ti vi] ...)
@ -2800,17 +2805,17 @@
[(null? l) '()]
[else (cons (format "_~a" (car l))
(loop (cdr l)))]))))
(check* T s
[vi ...]
[(lambda (a) (ftype-ref T (ni) a)) ...]
[(lambda (a) (ftype-set! T (ni) a vi)) ...]))]))
(check*t T s
[vi ...]
[(lambda (a) (ftype-ref T (ni) a)) ...]
[(lambda (a) (ftype-set! T (ni) a vi)) ...]))]))
(define-syntax check
(syntax-rules ()
[(_ t1 v1)
(check* t1 (format "_~a" 't1)
[v1]
[(lambda (a) (ftype-ref t1 () a))]
[(lambda (a) (ftype-set! t1 () a v1))])]))
(check*t t1 (format "_~a" 't1)
[v1]
[(lambda (a) (ftype-ref t1 () a))]
[(lambda (a) (ftype-set! t1 () a v1))])]))
(define-syntax check-union
(syntax-rules ()
[(_ [n0 t0 v0] [ni ti vi] ...)
@ -2823,10 +2828,10 @@
[(null? l) '()]
[else (cons (format "_~a" (car l))
(loop (cdr l)))]))))
(check* T s
[v0]
[(lambda (a) (ftype-ref T (n0) a))]
[(lambda (a) (ftype-set! T (n0) a v0))]))]))
(check*t T s
[v0]
[(lambda (a) (ftype-ref T (n0) a))]
[(lambda (a) (ftype-set! T (n0) a v0))]))]))
(define-syntax check-1
(syntax-rules ()
[(_ t1 v1)
@ -2917,4 +2922,156 @@
(check-union [x int 48] [y int 0])
(check-union [x i64 43] [y int 0])
(check-union [x float 58.0] [y int 0])
(check-union [x double 68.0] [y int 0]))
(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
EXPORT int __stdcall sum_stdcall(int a, int b) {
return a + b;
}
EXPORT ptr Sinvoke2_stdcall(ptr code, ptr x1, iptr 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 <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 unsigned char u8;
typedef unsigned short u16;
@ -63,6 +75,78 @@ EXPORT void free_at_boundary(void *p)
}
#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) \
EXPORT ts f4_get_ ## ts () { \
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 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)".

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 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)".

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}
\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)}
A new \scheme{collect-rendezvous} function performs a garbage

8
s/base-lang.ss
View File

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

7
s/cmacros.ss
View File

@ -1387,6 +1387,10 @@
(cons (string->symbol (substring str 3 (- n 5))) 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
([iptr type]
[U64 timestamp]
@ -2624,6 +2628,9 @@
split-and-resize
raw-collect-cond
raw-tc-mutex
activate-thread
deactivate-thread
unactivate-thread
handle-values-error
handle-mvlet-error
handle-arg-error

36
s/cp0.ss
View File

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

24
s/cpcommonize.ss
View File

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

8
s/cpletrec.ss
View File

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

14
s/cpnanopass.ss
View File

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

21
s/cprep.ss
View File

@ -85,11 +85,14 @@
(uncprep-sequence e2 ls))]
[else (cons (uncprep x) ls)])))
(define uncprep-fp-conv
(lambda (x)
(case x
[(i3nt-stdcall) '__stdcall]
[(i3nt-com) '__com]
[else #f])))
(lambda (x*)
(map (lambda (x)
(case x
[(i3nt-stdcall) '__stdcall]
[(i3nt-com) '__com]
[(adjust-active) '__collect_safe]
[else #f]))
x*)))
(define-who uncprep-fp-specifier
(lambda (x)
(nanopass-case (Ltype Type) x
@ -184,12 +187,12 @@
[(letrec* ([,x* ,[e*]] ...) ,body)
`(letrec* ,(map (lambda (x e) `(,(get-name x) ,e)) x* e*)
,@(uncprep-sequence body '()))]
[(foreign ,conv ,name ,[e] (,arg-type* ...) ,result-type)
`($foreign-procedure ,(uncprep-fp-conv conv) ,name ,e
[(foreign (,conv* ...) ,name ,[e] (,arg-type* ...) ,result-type)
`($foreign-procedure ,(uncprep-fp-conv conv*) ,name ,e
,(map uncprep-fp-specifier arg-type*)
,(uncprep-fp-specifier result-type))]
[(fcallable ,conv ,[e] (,arg-type* ...) ,result-type)
`($foreign-callable ,(uncprep-fp-conv conv) ,e
[(fcallable (,conv* ...) ,[e] (,arg-type* ...) ,result-type)
`($foreign-callable ,(uncprep-fp-conv conv*) ,e
,(map uncprep-fp-specifier arg-type*)
,(uncprep-fp-specifier result-type))]
[(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?)])
(defer-or-not (or body-dl? vals-dl?)
`(letrec* ([,x* ,e*] ...) ,body)))]
[(foreign ,conv ,name ,[undefer : e dl?] (,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)
(defer-or-not dl? `(fcallable ,conv ,e (,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))]
[(fcallable (,conv* ...) ,[undefer : e dl?] (,arg-type* ...) ,result-type)
(defer-or-not dl? `(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type))]
[(cte-optimization-loc ,box ,[undefer : e dl?])
(defer-or-not dl? `(cte-optimization-loc ,box ,e))]
[(pariah) (values x #f)]
@ -547,10 +547,10 @@
(defer-or-not (or dl0? dl1? dl2?) `(if ,e0 ,e1 ,e2))]
[(seq ,[cpvalid : e1 dl1?] ,[cpvalid : e2 dl2?])
(defer-or-not (or dl1? dl2?) `(seq ,e1 ,e2))]
[(foreign ,conv ,name ,[cpvalid : e dl?] (,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)
(defer-or-not dl? `(fcallable ,conv ,e (,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))]
[(fcallable (,conv* ...) ,[cpvalid : e dl?] (,arg-type* ...) ,result-type)
(defer-or-not dl? `(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type))]
[(cte-optimization-loc ,box ,[cpvalid : e dl?])
(defer-or-not dl? `(cte-optimization-loc ,box ,e))]
[(pariah) (values x #f)]

14
s/ftype.ss
View File

@ -56,7 +56,7 @@ ftype ->
(array length ftype)
(bits (field-name signedness bits) ...)
(function (arg-type ...) result-type)
(function conv (arg-type ...) result-type)
(function conv ... (arg-type ...) result-type)
(packed ftype)
(unpacked 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 pointer #{rtd/ftd-pointer a9pth58056u34h517jsrqv-6} (mutable ftd))
(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)
(define alignment
(lambda (max-alignment size)
@ -527,7 +527,7 @@ ftype operators:
[(function-kwd (arg-type ...) result-type)
(eq? (datum function-kwd) 'function)
(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)
(let ()
(define filter-type
@ -539,7 +539,7 @@ ftype operators:
(make-ftd-function rtd/fptr
(and defid (symbol->string (syntax->datum defid)))
stype #f #f
($filter-conv 'function-ftype #'conv)
($filter-conv 'function-ftype #'(conv ...))
(map (lambda (x) (filter-type r x #f)) #'(arg-type ...))
(filter-type r #'result-type #t)))]
[(packed-kwd ftype)
@ -729,7 +729,7 @@ ftype operators:
;; (foreign-callable-entry-point code-object)
[(procedure? x)
(let ([co #,($make-foreign-callable 'make-ftype-pointer
(ftd-function-conv ftd)
(ftd-function-conv* ftd)
#'x
(map indirect-ftd-pointer (ftd-function-arg-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-pointer? ftd) #`(#3%$fptr-fptr-ref #,fptr-expr #,offset '#,(ftd-pointer-ftd ftd))]
[(ftd-function? ftd)
($make-foreign-procedure
(ftd-function-conv ftd)
($make-foreign-procedure 'make-ftype-pointer
(ftd-function-conv* ftd)
#f
#`($fptr-offset-addr #,fptr-expr offset)
(map indirect-ftd-pointer (ftd-function-arg-type* ftd))

8
s/interpret.ss
View File

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

7
s/np-languages.ss
View File

@ -78,10 +78,6 @@
(import (nanopass))
(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
; chez scheme allows a quote subform to be any value
(define datum? (lambda (x) #t))
@ -489,6 +485,7 @@
(declare-primitive c-call effect #f)
(declare-primitive c-simple-call 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)
@ -521,6 +518,7 @@
(declare-primitive store-single effect #f)
(declare-primitive store-single->double effect #f)
(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 < pred #t)
@ -550,6 +548,7 @@
(declare-primitive fstps value #f) ; x86 only
(declare-primitive get-double value #t) ; x86_64
(declare-primitive get-tc value #f) ; threaded version only
(declare-primitive activate-thread value #f) ; threaded version only
(declare-primitive lea1 value #t)
(declare-primitive lea2 value #t)
(declare-primitive load value #t)

244
s/ppc32.ss
View File

@ -57,7 +57,7 @@
[%xp %r20 #t 20]
[%ts %r14 #t 14]
[%td %r15 #t 15]
[%ac1 %r12 #f 12]
[%ac1 %r12 %deact #f 12]
[%ret %r17 #t 17]
[%cp %r24 #t 24]
[%yp %r27 #t 27]
@ -668,6 +668,30 @@
`(set! ,(make-live-info) ,u (asm ,null-info ,asm-kill))
`(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)
[(op (z ur))
(let ([u (make-tmp 'u)])
@ -823,7 +847,7 @@
shift-count?
asm-isync
; threaded version specific
asm-get-tc
asm-get-tc asm-activate-thread asm-deactivate-thread asm-unactivate-thread
; machine dependent exports
asm-kill)
@ -1906,6 +1930,21 @@
(lambda (code* dest tmp . ignore) ; dest is ignored, since it is always Cretval
(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
(lambda (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 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-result-regs (lambda () (list %Cfpretval)))
(define (indirect-result-that-fits-in-registers? result-type)
(nanopass-case (Ltype Type) result-type
[(fp-ftd& ,ftd) (not ($ftd-compound? ftd))]
@ -2141,6 +2181,32 @@
(nanopass-case (Ltype Type) result-type
[(fp-ftd& ,ftd) ($ftd-compound? ftd)]
[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
(with-output-language (L13 Effect)
(define load-double-stack
@ -2233,10 +2299,12 @@
(lambda (types)
;; NB: start stack pointer at 8 to put arguments above the linkage area
(let loop ([types types] [locs '()] [live* '()] [int* (gp-parameter-regs)] [flt* (fp-parameter-regs)] [isp 8]
;; needed when adjusting active:
[fp-live-count 0]
;; configured for `ftd-fp&` unpacking of floats:
[fp-disp (constant flonum-data-disp)] [single? #f])
(if (null? types)
(values isp locs live*)
(values isp locs live* fp-live-count)
(nanopass-case (Ltype Type) (car types)
[(fp-double-float)
(if (constant software-floating-point)
@ -2245,21 +2313,21 @@
(let ([isp (align 8 isp)])
(loop (cdr types)
(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))
(loop (cdr types)
(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)))
(if (null? flt*)
(let ([isp (align 8 isp)])
(loop (cdr types)
(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))
(loop (cdr types)
(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)))]
[(fp-single-float)
(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
(loop (cdr types)
(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)
(loop (cdr types)
(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))
(if (null? flt*)
; NB: ABI says singles are passed as doubles on the stack, but gcc/linux doesn't
(let ([isp (align 4 isp)])
(loop (cdr types)
(cons (load-single-stack isp fp-disp single?) locs)
live* int* '() (fx+ isp 4)
live* int* '() (fx+ isp 4) fp-live-count
(constant flonum-data-disp) #f))
(loop (cdr types)
(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)))]
[(fp-ftd& ,ftd)
(cond
[($ftd-compound? ftd)
;; pass as pointer
(let ([pointer-type (with-output-language (Ltype Type) `(fp-integer 32))])
(loop (cons pointer-type (cdr types)) locs live* int* flt* isp
(loop (cons pointer-type (cdr types)) locs live* int* flt* isp fp-live-count
(constant flonum-data-disp) #f))]
[else
;; extract content and pass that content
@ -2301,7 +2369,7 @@
(case ($ftd-size ftd)
[(4) `(fp-single-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:
0
;; in case of float, load as single-float:
@ -2313,21 +2381,21 @@
(let ([isp (align 8 isp)])
(loop (cdr types)
(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))
(loop (cdr types)
(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)))]
[else
(if (null? int*)
(loop (cdr types)
(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)
(loop (cdr types)
(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))]))])]
[else
(if (nanopass-case (Ltype Type) (car types)
@ -2339,20 +2407,20 @@
(let ([isp (align 8 isp)])
(loop (cdr types)
(cons (load-int64-stack isp) locs)
live* '() flt* (fx+ isp 8)
live* '() flt* (fx+ isp 8) fp-live-count
(constant flonum-data-disp) #f))
(loop (cdr types)
(cons (load-int64-reg (cadr int*) (car int*)) locs)
(cons* (car int*) (cadr int*) live*) (cddr int*) flt* isp
(cons* (car int*) (cadr int*) live*) (cddr int*) flt* isp fp-live-count
(constant flonum-data-disp) #f)))
(if (null? int*)
(loop (cdr types)
(cons (load-int-stack isp) locs)
live* '() flt* (fx+ isp 4)
live* '() flt* (fx+ isp 4) fp-live-count
(constant flonum-data-disp) #f)
(loop (cdr types)
(cons (load-int-reg (car int*)) locs)
(cons (car int*) live*) (cdr int*) flt* isp
(cons (car int*) live*) (cdr int*) flt* isp fp-live-count
(constant flonum-data-disp) #f)))])))))
(define do-indirect-result-from-registers
(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 4) ,%Cretval-low))]
[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)
(safe-assert (reg-callee-save? %tc)) ; no need to save-restore
(let* ([arg-type* (info-foreign-arg-type* info)]
[result-type (info-foreign-result-type info)]
[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*))
(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
(let ([fill-stash-offset orig-frame-size]
[frame-size (align 16 (fx+ orig-frame-size 4 (if fill-result-here? 4 0)))])
(let* ([fill-stash-offset orig-frame-size]
[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
(lambda () (%inline store-with-update ,%Csp ,%Csp (immediate ,(fx- frame-size))))
(let ([locs (reverse locs)])
@ -2393,20 +2485,26 @@
(cons (load-int-stack fill-stash-offset) locs)]
[else locs]))
(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 ()
(define handle-64-bit
(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
(lambda ()
`(inline ,(make-info-kill*-live* (reg-list %Cretval) live*) ,%c-call ,t0)))
(make-call (reg-list %Cretval) 0)))
(define handle-integer-cases
(lambda (bits)
(case bits
[(8 16 32) (handle-32-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)
(cond
[fill-result-here?
@ -2415,20 +2513,20 @@
(handle-64-bit)
(handle-32-bit))
,(do-indirect-result-from-registers ftd fill-stash-offset))]
[else `(inline ,(make-info-kill*-live* (reg-list) live*) ,%c-call ,t0)]))
[else (make-call (reg-list) 0)]))
(nanopass-case (Ltype Type) result-type
[(fp-double-float) (handle-64-bit)]
[(fp-single-float) (handle-32-bit)]
[(fp-integer ,bits) (handle-integer-cases bits)]
[(fp-integer ,bits) (handle-integer-cases bits)]
[(fp-ftd& ,ftd) (handle-ftd&-case ftd)]
[else `(inline ,(make-info-kill*-live* (reg-list %Cretval) live*) ,%c-call ,t0)]))
[else (make-call (reg-list %Cretval) 0)]))
(let ()
(define handle-integer-cases
(lambda (bits)
(case bits
[(8 16 32) `(inline ,(make-info-kill*-live* (reg-list %Cretval) live*) ,%c-call ,t0)]
[(64) `(inline ,(make-info-kill*-live* (reg-list %Cretval-high %Cretval-low) live*) ,%c-call ,t0)]
[(8 16 32) (make-call (reg-list %Cretval) 0)]
[(64) (make-call (reg-list %Cretval-high %Cretval-low) 0)]
[else (sorry! who "unexpected asm-foreign-procedures fp-integer size ~s" bits)])))
(define (handle-ftd&-case ftd)
(cond
@ -2436,16 +2534,16 @@
(%seq
,(if (not (eq? 'float ($ftd-atomic-category ftd)))
(handle-integer-cases (* 8 ($ftd-size ftd)))
`(inline ,(make-info-kill*-live* (reg-list) live*) ,%c-call ,t0))
(make-call (reg-list) 1))
,(do-indirect-result-from-registers ftd fill-stash-offset))]
[else `(inline ,(make-info-kill*-live* (reg-list) live*) ,%c-call ,t0)]))
(nanopass-case (Ltype Type) result-type
[(fp-double-float) `(inline ,(make-info-kill*-live* (reg-list) live*) ,%c-call ,t0)]
[(fp-single-float) `(inline ,(make-info-kill*-live* (reg-list) live*) ,%c-call ,t0)]
[(fp-double-float) (make-call (reg-list) 1)]
[(fp-single-float) (make-call (reg-list) 1)]
[(fp-integer ,bits) (handle-integer-cases bits)]
[(fp-unsigned ,bits) (handle-integer-cases bits)]
[(fp-ftd& ,ftd) (handle-ftd&-case ftd)]
[else `(inline ,(make-info-kill*-live* (reg-list %Cretval) live*) ,%c-call ,t0)]))))
[else (make-call (reg-list %Cretval) 0)]))))
(nanopass-case (Ltype Type) result-type
[(fp-double-float)
(lambda (lvalue)
@ -2552,12 +2650,15 @@
| |
| back chain | 1 word
sp+X: | |
+---------------------------+ <- 16-byte aligned
+---------------------------+
+---------------------------+ <- 16-byte aligned
| |
| &-return space | 2 words, if needed
| |
+---------------------------+ <- 8-byte aligned
| unactivate mode | 1 word, if needed
+---------------------------+
| |
| callee-save regs |
| |
@ -2567,9 +2668,9 @@
| |
+---------------------------+ <- 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)
| |
@ -2837,20 +2938,23 @@
(case ($ftd-size ftd)
[(4) `(inline ,(make-info-loadfl %Cfpretval) ,%load-single ,%sp ,%zero (immediate ,return-space-offset))]
[else `(inline ,(make-info-loadfl %Cfpretval) ,%load-double ,%sp ,%zero (immediate ,return-space-offset))]))
'())]
'()
1)]
[else
(cond
[($ftd-compound? ftd)
;; return pointer
(values
(lambda () `(set! ,%Cretval ,(%mref ,%sp ,int-reg-offset)))
(list %Cretval))]
(list %Cretval)
0)]
[(fx= 8 ($ftd-size ftd))
(values (lambda ()
(%seq
(set! ,%Cretval-high ,(%mref ,%sp ,return-space-offset))
(set! ,%Cretval-low ,(%mref ,%sp ,(fx+ return-space-offset 4)))))
(list %Cretval-high %Cretval-low))]
(list %Cretval-high %Cretval-low)
0)]
[else
(values
(lambda ()
@ -2858,18 +2962,22 @@
[(1) `(set! ,%Cretval (inline ,(make-info-load 'integer-8 #f) ,%load ,%sp ,%zero (immediate ,return-space-offset)))]
[(2) `(set! ,%Cretval (inline ,(make-info-load 'integer-16 #f) ,%load ,%sp ,%zero (immediate ,return-space-offset)))]
[else `(set! ,%Cretval ,(%mref ,%sp ,return-space-offset))]))
(list %Cretval))])])]
(list %Cretval)
0)])])]
[(fp-double-float)
(values (lambda (x)
`(inline ,(make-info-loadfl %Cfpretval) ,%load-double ,x ,%zero ,(%constant flonum-data-disp)))
'())]
'()
1)]
[(fp-single-float)
(values (lambda (x)
`(inline ,(make-info-loadfl %Cfpretval) ,%load-double->single ,x ,%zero ,(%constant flonum-data-disp)))
'())]
'()
1)]
[(fp-void)
(values (lambda () `(nop))
'())]
'()
0)]
[else
(cond
[(nanopass-case (Ltype Type) result-type
@ -2880,11 +2988,20 @@
(%seq
(set! ,%Cretval-low ,lo-rhs)
(set! ,%Cretval-high ,hi-rhs)))
(list %Cretval-high %Cretval-low))]
(list %Cretval-high %Cretval-low)
0)]
[else
(values (lambda (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)
(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))
@ -2899,12 +3016,12 @@
float-reg-offset
(fx+ (fx* fp-reg-count 8) float-reg-offset))]
[synthesize-first-argument? (indirect-result-that-fits-in-registers? result-type)]
[return-space-offset (align 8 (fx+ (fx* isaved 4) callee-save-offset))]
[stack-size (align 16 (if synthesize-first-argument?
(fx+ return-space-offset 8)
return-space-offset))]
[adjust-active? (if-feature pthreads (memq 'adjust-active (info-foreign-conv* info)) #f)]
[unactivate-mode-offset (fx+ (fx* isaved 4) callee-save-offset)]
[return-space-offset (align 8 (fx+ unactivate-mode-offset (if adjust-active? 4 0)))]
[stack-size (align 16 (fx+ return-space-offset (if synthesize-first-argument? 8 0)))]
[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
(lambda ()
(%seq
@ -2916,9 +3033,16 @@
; not bothering with cr, because we don't update nonvolatile fields
,(save-regs callee-save-regs callee-save-offset)
,(if-feature pthreads
(%seq
(set! ,%Cretval ,(%inline get-tc))
(set! ,%tc ,%Cretval))
((lambda (e)
(if adjust-active?
(%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))))))
; list of procedures that marshal arguments from their C stack locations
; to the Scheme argument locations
@ -2927,6 +3051,12 @@
get-result
(lambda ()
(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
; restore the lr
(inline ,null-info ,%restore-lr (immediate ,(fx+ stack-size 4)))
@ -2935,5 +3065,5 @@
; deallocate space for pad & arg reg values
(set! ,%Csp ,(%inline + ,%Csp (immediate ,stack-size)))
; done
(asm-c-return ,null-info ,callee-save-regs ... ,result-regs ...))))))))))))))
(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)))))
(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
`(foreign ,conv ,foreign-name ,foreign-addr
`(foreign (,conv* ...) ,foreign-name ,foreign-addr
(,(map (lambda (x) (build-fp-specifier 'foreign-procedure 'parameter x #f)) params) ...)
,(build-fp-specifier 'foreign-procedure "result" result #t)))))
(define build-foreign-callable
(lambda (ae conv proc params result)
(lambda (ae conv* proc params result)
(build-profile ae
`(fcallable ,conv ,proc
`(fcallable (,conv* ...) ,proc
(,(map (lambda (x) (build-fp-specifier 'foreign-callable 'parameter x #f)) params) ...)
,(build-fp-specifier 'foreign-callable "result" result #t))))))
@ -6023,9 +6023,9 @@
(global-extend 'core '$foreign-procedure
(lambda (e r w ae)
(syntax-case e ()
((_ conv foreign-name foreign-addr (arg ...) result)
((_ conv* foreign-name foreign-addr (arg ...) result)
(build-foreign-procedure ae
(strip (syntax conv) w)
(strip (syntax conv*) w)
(strip (syntax foreign-name) w)
(chi (syntax foreign-addr) r w)
(map (lambda (x) (strip x w)) (syntax (arg ...)))
@ -6034,9 +6034,9 @@
(global-extend 'core '$foreign-callable
(lambda (e r w ae)
(syntax-case e ()
((_ conv proc (arg ...) result)
((_ conv* proc (arg ...) result)
(build-foreign-callable ae
(strip (syntax conv) w)
(strip (syntax conv*) w)
(chi (syntax proc) r w)
(map (lambda (x) (strip x w)) (syntax (arg ...)))
(strip (syntax result) w))))))
@ -8572,30 +8572,51 @@
[else ($oops '$fp-type->pred "unrecognized type ~s" type)])])))
(define $filter-conv
(lambda (who conv)
(lambda (who conv*)
(define squawk
(lambda (x)
(syntax-error x (format "invalid ~s convention" who))))
(let ([c (syntax->datum conv)])
(if (not c)
#f
(case ($target-machine)
[(i3nt ti3nt)
(case c
[(__stdcall) #'i3nt-stdcall]
[(__cdecl) #f]
[(__com) #'i3nt-com]
[else (squawk conv)])]
[(ppcnt)
(case c
[(__stdcall __cdecl) #f]
[else (squawk conv)])]
[else (squawk conv)])))))
(let loop ([conv* conv*] [accum '()] [keep-accum '()])
(cond
[(null? conv*) (datum->syntax #'filter-conv keep-accum)]
[else
(let* ([orig-c (car conv*)]
[c (syntax->datum orig-c)]
[c (cond
[(not c) #f]
[(eq? c '__collect_safe) 'adjust-active]
[else
(case ($target-machine)
[(i3nt ti3nt)
(case c
[(__stdcall) 'i3nt-stdcall]
[(__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
(lambda (conv foreign-name ?foreign-addr type* result-type)
(lambda (who conv* foreign-name ?foreign-addr type* result-type)
(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-addr ?foreign-addr]
[(t ...) (generate-temporaries type*)])
@ -8637,6 +8658,7 @@
(err ($moi) x))))
(unsigned-32))])]
[(utf-8)
(check-strings-allowed)
#`(()
((if (eq? x #f)
x
@ -8647,6 +8669,7 @@
(err ($moi) x)))))
(u8*))]
[(utf-16le)
(check-strings-allowed)
#`(()
((if (eq? x #f)
x
@ -8657,6 +8680,7 @@
(err ($moi) x)))))
(u16*))]
[(utf-16be)
(check-strings-allowed)
#`(()
((if (eq? x #f)
x
@ -8667,6 +8691,7 @@
(err ($moi) x)))))
(u16*))]
[(utf-32le)
(check-strings-allowed)
#`(()
((if (eq? x #f)
x
@ -8677,6 +8702,7 @@
(err ($moi) x)))))
(u32*))]
[(utf-32be)
(check-strings-allowed)
#`(()
((if (eq? x #f)
x
@ -8745,7 +8771,7 @@
#`[]
#`[(unless (record? &-result '#,(unbox result-type)) (err ($moi) &-result))]))]
[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?
#'()
#'([err (lambda (who x)
@ -8762,25 +8788,29 @@
(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-case x ()
[(_ ?name (arg ...) result)
#'(foreign-procedure #f ?name (arg ...) result)]
[(_ conv ?name (arg ...) result)
[(_ c ... ?name (arg ...) result)
(lambda (r)
($make-foreign-procedure
($filter-conv 'foreign-procedure #'conv)
($make-foreign-procedure 'foreign-procedure
($filter-conv 'foreign-procedure #'(c ...))
(let ([x (datum ?name)]) (and (string? x) x))
#'($foreign-entry ?name)
(map (lambda (x) (filter-type r x #f)) #'(arg ...))
(filter-type r #'result #t)))])))
(define $make-foreign-callable
(lambda (who conv ?proc type* result-type)
(when (eq? conv 'i3nt-com) ($oops who "unsupported convention ~s" conv))
(lambda (who conv* ?proc type* result-type)
(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)])
(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 ...)) ...)
(map
(lambda (type)
(lambda (type)
(or (case type
[(boolean)
(with-syntax ([(x) (generate-temporaries #'(*))])
@ -8907,6 +8937,7 @@
unsigned-16
[] [])])]
[(utf-8)
(check-strings-allowed)
#`((lambda (x)
(if (eq? x #f)
x
@ -8918,6 +8949,7 @@
u8*
[] [])]
[(utf-16le)
(check-strings-allowed)
#`((lambda (x)
(if (eq? x #f)
x
@ -8929,6 +8961,7 @@
u16*
[] [])]
[(utf-16be)
(check-strings-allowed)
#`((lambda (x)
(if (eq? x #f)
x
@ -8940,6 +8973,7 @@
u16*
[] [])]
[(utf-32le)
(check-strings-allowed)
#`((lambda (x)
(if (eq? x #f)
x
@ -8951,6 +8985,7 @@
u32*
[] [])]
[(utf-32be)
(check-strings-allowed)
#`((lambda (x)
(if (eq? x #f)
x
@ -8991,7 +9026,7 @@
[] []))])])])
; use a gensym to avoid giving the procedure a confusing name
(with-syntax ([p (datum->syntax #'foreign-callable (gensym))])
#`($foreign-callable conv
#`($foreign-callable conv*
(let ([p ?proc])
(define (err x)
($oops 'foreign-callable
@ -9010,12 +9045,10 @@
(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-case x ()
[(_ proc (arg ...) result)
#'(foreign-callable #f proc (arg ...) result)]
[(_ conv ?proc (arg ...) result)
[(_ c ... ?proc (arg ...) result)
(lambda (r)
($make-foreign-callable 'foreign-callable
($filter-conv 'foreign-callable #'conv)
($filter-conv 'foreign-callable #'(c ...))
#'?proc
(map (lambda (x) (filter-type r x #f)) #'(arg ...))
(filter-type r #'result #t)))])))

259
s/x86.ss
View File

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

203
s/x86_64.ss
View File

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