From 63a6443c2607f056be8401f69725f8574a87c663 Mon Sep 17 00:00:00 2001 From: Gustavo Massaccesi Date: Mon, 15 Jan 2018 14:08:56 -0300 Subject: [PATCH 01/21] fix a few signatures primdata.ss original commit: 903e017f2611f7e2c3817667afefee7a0ebfae35 --- LOG | 2 ++ s/primdata.ss | 8 ++++---- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/LOG b/LOG index 477a911001..fd606fd585 100644 --- a/LOG +++ b/LOG @@ -788,3 +788,5 @@ - fix bounds checking with an immediate index on immutable vectors, fxvectors, strings, and bytevectors cpnanopass.ss, 5_5.ms, 5_6.ms, bytevector.ms +- fix a few signatures + primdata.ss diff --git a/s/primdata.ss b/s/primdata.ss index 7dd04e73b5..349ad75b14 100644 --- a/s/primdata.ss +++ b/s/primdata.ss @@ -329,7 +329,7 @@ (vector [sig [(ptr ...) -> (vector)]] [flags unrestricted alloc ieee r5rs cp02]) (vector-length [sig [(vector) -> (length)]] [flags pure true ieee r5rs mifoldable discard]) (vector-ref [sig [(vector sub-index) -> (ptr)]] [flags ieee r5rs mifoldable discard cp02]) - (vector-set! [sig [(vector sub-index ptr) -> (ptr)]] [flags true ieee r5rs]) + (vector-set! [sig [(vector sub-index ptr) -> (void)]] [flags true ieee r5rs]) (vector->list [sig [(vector) -> (list)]] [flags alloc ieee r5rs]) (list->vector [sig [(list) -> (vector)]] [flags alloc ieee r5rs]) (vector-fill! [sig [(vector ptr) -> (void)]] [flags true ieee r5rs]) @@ -839,9 +839,9 @@ (define-symbol-flags* ([libraries (chezscheme csv7)] [flags primitive proc]) ; csv7 compatibility ((csv7: record-field-accessible?) [sig [(rtd sub-ptr) -> (boolean)]] [flags pure mifoldable discard cp02]) - ((csv7: record-field-accessor) [sig [(rtd sub-ptr) -> (boolean)]] [flags pure alloc cp02]) + ((csv7: record-field-accessor) [sig [(rtd sub-ptr) -> (procedure)]] [flags pure alloc cp02]) ((csv7: record-field-mutable?) [sig [(rtd sub-ptr) -> (boolean)]] [flags pure mifoldable discard cp02]) - ((csv7: record-field-mutator) [sig [(rtd sub-ptr) -> (boolean)]] [flags pure alloc cp02]) + ((csv7: record-field-mutator) [sig [(rtd sub-ptr) -> (procedure)]] [flags pure alloc cp02]) ((csv7: record-type-descriptor) [sig [(record) -> (rtd)]] [flags pure mifoldable discard true cp02]) ((csv7: record-type-field-decls) [sig [(rtd) -> (list)]] [flags pure mifoldable discard true cp02]) ((csv7: record-type-field-names) [sig [(rtd) -> (list)]] [flags pure mifoldable discard true cp02]) @@ -1520,7 +1520,7 @@ (put-string-some [sig [(textual-output-port string) (textual-output-port string length) (textual-output-port string length length) -> (uint)]] [flags true]) (putprop [sig [(symbol ptr ptr) -> (void)]] [flags true]) (putenv [sig [(string string) -> (void)]] [flags true]) - (profile-query-weight [sig [(ptr) -> (maybe-flonum)]] [flags discard true]) + (profile-query-weight [sig [(ptr) -> (maybe-flonum)]] [flags unrestricted discard]) (random [sig [(sub-number) -> (number)]] [flags alloc]) (ratnum? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) (read-token [sig [() (textual-input-port) (textual-input-port sfd) -> (symbol ptr maybe-uint maybe-uint)]] [flags]) From f7c414bda3673f8fa7cb2bc0721d01c9a9a2e234 Mon Sep 17 00:00:00 2001 From: dybvig Date: Mon, 29 Jan 2018 09:20:07 -0500 Subject: [PATCH 02/21] Various updates, mostly to the compiler, including a new lambda commonizatio pass and support for specifying default record equal and hash procedures: - more staid and consistent Mf-cross main target Mf-cross - cpletrec now replaces the incoming prelexes with new ones so that it doesn't have to alter the flags on the incoming ones, since the same expander output is passed through the compiler twice while compiling a file with macro definitions or libraries. we were getting away without this just by luck. cpletrec.ss - pure? and ivory? now return #t for a primref only if the prim is declared to be a proc, since some non-proc prims are mutable, e.g., $active-threads and $collect-request-pending. cp0.ss - $error-handling-mode? and $eol-style? are now properly declared to be procs rather than system state variables. primdata.ss - the new pass $check-prelex-flags verifies that prelex referenced, multiply-referenced, and assigned flags are set when they should be. (it doesn't, however, complain if a flag is set when it need not be.) when the new system parameter $enable-check-prelex-flags is set, $check-prelex-flags is called after each major pass that produces Lsrc forms to verify that the flags are set correctly in the output of the pass. this parameter is unset by default but set when running the mats. cprep.ss, back.ss, compile.ss, primdata.ss, mats/Mf-base - removed the unnecessary set of prelex referenced flag from the build-ref routines when we've just established that it is set. syntax.ss, compile.ss - equivalent-expansion? now prints differences to the current output port to aid in debugging. mat.ss - the nanopass that patches calls to library globals into calls to their local counterparts during whole-program optimization now creates new prelexes and sets the prelex referenced, multiply referenced, and assigned flags on the new prelexes rather than destructively setting flags on the incoming prelexes. The only known problems this fixes are (1) the multiply referenced flag was not previously being set for cross-library calls when it should have been, resulting in overly aggressive inlining of library exports during whole-program optimization, and (2) the referenced flag could sometimes be set for library exports that aren't actually used in the final program, which could prevent some unreachable code from being eliminated. compile.ss - added support for specifying default record-equal and record-hash procedures. primdata.ss, cmacros.ss, cpnanopass.ss, prims.ss, newhash.ss, gc.c, record.ms - added missing call to relocate for subset-mode tc field, which wasn't burning us because the only valid non-false value, the symbol system, is in the static generation after the initial heap compaction. gc.c - added a lambda-commonization pass that runs after the other source optimizations, particularly inlining, and a new parameter that controls how hard it works. the value of commonization-level ranges from 0 through 9, with 0 disabling commonization and 9 maximizing it. The default value is 0 (disabled). At present, for non-zero level n, the commonizer attempts to commonize lambda expressions consisting of 2^(10-n) or more nodes. commonization of one or more lambda expressions requires that they have identical structure down to the leaf nodes for quote expressions, references to unassigned variables, and primitives. So that various downstream optimizations aren't disabled, there are some additional restrictions, the most important of which being that call-position expressions must be identical. The commonizer works by abstracting the code into a helper that takes the values of the differing leaf nodes as arguments. the name of the helper is formed by concatenating the names of the original procedures, separated by '&', and this is the name that will show up in a stack trace. The source location will be that of one of the original procedures. Profiling inhibits commonization, because commonization requires profile source locations to be identical. cpcommonize.ss (new), compile.ss, interpret.ss, cprep.ss, primdata.ss, s/Mf-base, mats/Mf-base - cpletrec now always produces a letrec rather than a let for single immutable lambda bindings, even when not recursive, for consistent expand/optimize output whether the commonizer is run or not. cpletrec.ss, record.ms - trans-make-ftype-pointer no longer generates a call to $verify-ftype-address if the address expression is a call to ftype-pointer-address. ftype.ss original commit: b6a3dcc814b64faacc9310fec4a4531fb3f18dcd --- LOG | 89 +++++++++++++++ c/gc.c | 8 +- csug/objects.stex | 57 +++++++++- csug/system.stex | 28 +++++ mats/Mf-base | 30 +++-- mats/mat.ss | 78 +++++++------ mats/record.ms | 131 +++++++++++++++++++++- release_notes/release_notes.stex | 27 ++++- s/Mf-base | 18 ++- s/Mf-cross | 2 +- s/back.ss | 5 + s/cmacros.ss | 2 + s/compile.ss | 186 ++++++++++++++++++++----------- s/cp0.ss | 4 +- s/cpletrec.ss | 111 ++++++++++-------- s/cpnanopass.ss | 2 + s/cprep.ss | 63 +++++++++-- s/ftype.ss | 5 +- s/interpret.ss | 3 +- s/newhash.ss | 21 ++-- s/primdata.ss | 10 +- s/prims.ss | 2 + s/syntax.ss | 6 +- 23 files changed, 694 insertions(+), 194 deletions(-) diff --git a/LOG b/LOG index fd606fd585..8f01a213c5 100644 --- a/LOG +++ b/LOG @@ -790,3 +790,92 @@ cpnanopass.ss, 5_5.ms, 5_6.ms, bytevector.ms - fix a few signatures primdata.ss +- more staid and consistent Mf-cross main target + Mf-cross +- cpletrec now replaces the incoming prelexes with new ones so + that it doesn't have to alter the flags on the incoming ones, since + the same expander output is passed through the compiler twice while + compiling a file with macro definitions or libraries. we were + getting away without this just by luck. + cpletrec.ss +- pure? and ivory? now return #t for a primref only if the prim is + declared to be a proc, since some non-proc prims are mutable, e.g., + $active-threads and $collect-request-pending. + cp0.ss +- $error-handling-mode? and $eol-style? are now properly declared to + be procs rather than system state variables. + primdata.ss +- the new pass $check-prelex-flags verifies that prelex referenced, + multiply-referenced, and assigned flags are set when they + should be. (it doesn't, however, complain if a flag is set + when it need not be.) when the new system parameter + $enable-check-prelex-flags is set, $check-prelex-flags is + called after each major pass that produces Lsrc forms to verify + that the flags are set correctly in the output of the pass. + this parameter is unset by default but set when running the + mats. + cprep.ss, back.ss, compile.ss, primdata.ss, + mats/Mf-base +- removed the unnecessary set of prelex referenced flag from the + build-ref routines when we've just established that it is set. + syntax.ss, compile.ss +- equivalent-expansion? now prints differences to the current output + port to aid in debugging. + mat.ss +- the nanopass that patches calls to library globals into calls to + their local counterparts during whole-program optimization now + creates new prelexes and sets the prelex referenced, multiply + referenced, and assigned flags on the new prelexes rather than + destructively setting flags on the incoming prelexes. The + only known problems this fixes are (1) the multiply referenced + flag was not previously being set for cross-library calls when + it should have been, resulting in overly aggressive inlining + of library exports during whole-program optimization, and (2) + the referenced flag could sometimes be set for library exports + that aren't actually used in the final program, which could + prevent some unreachable code from being eliminated. + compile.ss +- added support for specifying default record-equal and + record-hash procedures. + primdata.ss, cmacros.ss, cpnanopass.ss, prims.ss, newhash.ss, + gc.c, + record.ms +- added missing call to relocate for subset-mode tc field, which + wasn't burning us because the only valid non-false value, the + symbol system, is in the static generation after the initial heap + compaction. + gc.c +- added a lambda-commonization pass that runs after the other + source optimizations, particularly inlining, and a new parameter + that controls how hard it works. the value of commonization-level + ranges from 0 through 9, with 0 disabling commonization and 9 + maximizing it. The default value is 0 (disabled). At present, + for non-zero level n, the commonizer attempts to commonize + lambda expressions consisting of 2^(10-n) or more nodes. + commonization of one or more lambda expressions requires that + they have identical structure down to the leaf nodes for quote + expressions, references to unassigned variables, and primitives. + So that various downstream optimizations aren't disabled, there + are some additional restrictions, the most important of which + being that call-position expressions must be identical. The + commonizer works by abstracting the code into a helper that + takes the values of the differing leaf nodes as arguments. + the name of the helper is formed by concatenating the names of + the original procedures, separated by '&', and this is the name + that will show up in a stack trace. The source location will + be that of one of the original procedures. Profiling inhibits + commonization, because commonization requires profile source + locations to be identical. + cpcommonize.ss (new), compile.ss, interpret.ss, cprep.ss, + primdata.ss, s/Mf-base, + mats/Mf-base +- cpletrec now always produces a letrec rather than a let for + single immutable lambda bindings, even when not recursive, for + consistent expand/optimize output whether the commonizer is + run or not. + cpletrec.ss, + record.ms +- trans-make-ftype-pointer no longer generates a call to + $verify-ftype-address if the address expression is a call to + ftype-pointer-address. + ftype.ss diff --git a/c/gc.c b/c/gc.c index 4d2970f523..c65215d16a 100644 --- a/c/gc.c +++ b/c/gc.c @@ -1500,9 +1500,13 @@ static void sweep_thread(p) ptr p; { /* immediate GENERATEINSPECTORINFORMATION */ /* immediate GENERATEPROFILEFORMS */ /* immediate OPTIMIZELEVEL */ - relocate(&PARAMETERS(tc)) + relocate(&SUBSETMODE(tc)) + /* immediate SUPPRESSPRIMITIVEINLINING */ + relocate(&DEFAULTRECORDEQUALPROCEDURE(tc)) + relocate(&DEFAULTRECORDHASHPROCEDURE(tc)) /* U64 INSTRCOUNTER(tc) */ /* U64 ALLOCCOUNTER(tc) */ + relocate(&PARAMETERS(tc)) for (i = 0 ; i < virtual_register_count ; i += 1) { relocate(&VIRTREG(tc, i)); } @@ -2126,7 +2130,7 @@ static int check_dirty_ephemeron(ptr pe, int tg, int youngest) { youngest = tg; } else { /* Not reached, so far; add to pending list */ - add_ephemeron_to_pending(pe); + add_ephemeron_to_pending(pe); /* Make the consistent (but pessimistic w.r.t. to wrong-way pointers) assumption that the key will stay live and move to the target generation. That assumption covers the value diff --git a/csug/objects.stex b/csug/objects.stex index 5e8017b0a6..af0e9b052a 100644 --- a/csug/objects.stex +++ b/csug/objects.stex @@ -2380,6 +2380,12 @@ comparison of potentially cyclic structure. When comparing two non-eq? instances that do not share an equality procedure, \scheme{equal?} returns \scheme{#f}. +A default equality procedure to be used for all record types (including +opaque types) can be specified via the parameter +\index{\scheme{default-record-equal-procedure}}\scheme{default-record-equal-procedure}. +The default equality procedure is used only if neither instance's type has or inherits +a type-specific record equality procedure. + \index{record hashing}\index{\scheme{equal-hash} on records}% Similarly, when the \index{\scheme{equal-hash}}\scheme{equal-hash} primitive hashes a record instance, it defaults to a value that is @@ -2391,11 +2397,18 @@ that describes the record type. The procedure \index{\scheme{record-hash-procedure}}\scheme{record-hash-procedure} can be used to find the hash procedure for a given record instance, following the inheritance chain. -\var{equal-hash} passes \var{hash-proc} two arguments: the +\var{equal-hash} passes the hash procedure two arguments: the instance plus a \var{hash} procedure that should be used for recursive hashing of values within the instance. Use of \var{hash} for recursive hashing is necessary to allow -hashing of potentially cyclic structure. +hashing of potentially cyclic structure and to make the hashing +of shared structure more efficient. + +A default hash procedure to be used for all record types (including +opaque types) can be specified via the parameter +\index{\scheme{default-record-hash-procedure}}\scheme{default-record-hash-procedure}. +The default hash procedure is used only if an instance's type does not have or inherit +a type-specific hash procedure. The following example illustrates the setting of equality and hash procedures. @@ -2532,6 +2545,10 @@ If \var{hash-proc} is \scheme{#f}, any existing association between In the second form, \scheme{record-type-hash-procedure} returns the hash procedure associated with \var{rtd}, if any, otherwise \scheme{#f}. +The procedure \var{hash-proc} should accept two arguments, the +instance for which it should compute a hash value and a hash procedure +to use to compute hash values for arbitrary fields of the instance, +and it return a nonnegative exact integer. A record type's hash procedure should produce the same hash value for any two instances the record type's equality procedure considers equal. @@ -2550,6 +2567,42 @@ If such type is found, the hash procedure associated with the type is returned. Otherwise, \scheme{#f} is returned. +%---------------------------------------------------------------------------- +\entryheader +\formdef{default-record-equal-procedure}{\categorythreadparameter}{default-record-equal-procedure} +\listlibraries +\endentryheader + +This parameter determines how two record instances are compared by +\scheme{equal?} if neither has a type-specific equality procedure. +When the parameter has the value \scheme{#f} (the default), \scheme{equal?} +compares the instances with \scheme{eq?}, i.e., there is no attempt at +determining structural equivalence. +Otherwise, the parameter's value must be a procedure, and \scheme{equal?} +invokes that procedure to compare the instances, passing it three arguments: +the two instances and a procedure that should be used to recursively +compare arbitrary values within the instances. + +%---------------------------------------------------------------------------- +\entryheader +\formdef{default-record-hash-procedure}{\categorythreadparameter}{default-record-hash-procedure} +\listlibraries +\endentryheader + +This parameter determines the hash procedure used when \scheme{equal-hash} +is called on a record instance and the instance does not have a type-specific +hash procedure. +When the parameter has the value \scheme{#f} (the default), \scheme{equal-hash} +returns a value that is independent of the record type and contents +of the instance. +Otherwise, the parameter's value must be a procedure, and \scheme{equal-hash} +invokes the procedure to compute the instance's hash value, passing it +the record instance and a procedure to invoke to recursively compute +hash values for arbitrary values contained within the record. +The procedure should return a nonnegative exact integer, and the +return value should be the same for any two instances the default +equal procedure considers equivalent. + \section{Legacy Record Types\label{SECTCSV7RECORDS}} \index{records}\index{\scheme{define-record}}\index{\scheme{make-record-type}}% diff --git a/csug/system.stex b/csug/system.stex index a21473c8b3..22b572005b 100644 --- a/csug/system.stex +++ b/csug/system.stex @@ -2631,6 +2631,34 @@ would be reduced to \scheme{3628800}, but would be left unchanged, although the optimizer may take a while to reach this decision if the effort and outer unroll limits are large. +%---------------------------------------------------------------------------- +\entryheader +\formdef{commonization-level}{\categorythreadparameter}{commonization-level} +\listlibraries +\endentryheader + +After running the main source optimization pass (cp0) for the last time, the +compiler optionally runs a \emph{commonization} pass. +The pass commonizes the code for lambda expressions that have +identical structure by abstracting differences at certain leaves +of the program, namely constants, references to unassigned variables, +and references to primitives. +The parameter \scheme{commonization-level} controls whether commonization +is run and, if so, how aggressive it is. +Its value must be a nonnegative exact integer ranging from 0 through 9. +When the parameter is set to 0, the default, commonization is not run. +Otherwise, higher values result in more commonization. + +Commonization can undo some of the effects of cp0's inlining, can +add run-time overhead, and can complicate debugging, particularly +at higher commonization levels, which is why it is disabled by +default. +On the other hand, for macros or other meta programs that can +generate large, mostly similar lambda expressions, enabling +commonization can result in significant savings in object-code size +and even reduce run-time overhead by making more efficient use of +instruction caches. + %---------------------------------------------------------------------------- \entryheader \formdef{undefined-variable-warnings}{\categorythreadparameter}{undefined-variable-warnings} diff --git a/mats/Mf-base b/mats/Mf-base index cbcf26e93e..db0fd1aed7 100644 --- a/mats/Mf-base +++ b/mats/Mf-base @@ -115,6 +115,14 @@ ehc = $(defaultehc) defaulteoc = t eoc = $(defaulteoc) +# cl determines the commonization level +defaultcl = (commonization-level) +cl = $(defaultcl) + +# ecpf determines whether the compiler checks prelex flags +defaultecpf = t +ecpf = $(defaultecpf) + # set of mats to run mats = primvars 3 4 5_1 5_2 5_3 5_4 5_5 bytevector thread\ misc cp0 5_6 5_7 5_8 6 io format 7 record hash enum 8 fx fl cfl foreign\ @@ -141,11 +149,13 @@ $(objdir)/%.mo : %.ms mat.so echo '(optimize-level $o)'\ '(#%$$suppress-primitive-inlining #${spi})'\ '(#%$$enable-check-heap #${ehc})'\ + '(#%$$enable-check-prelex-flags #${ecpf})'\ '(compile-profile #$p)'\ '(collect-trip-bytes ${ctb})'\ '(collect-generation-radix ${cgr})'\ '(collect-maximum-generation ${cmg})'\ '(enable-object-counts #${eoc})'\ + '(commonization-level ${cl})'\ '(compile-interpret-simple #${cis})'\ '(set! *examples-directory* "${Examples}")'\ '(enable-cp0 #${cp0})'\ @@ -162,11 +172,13 @@ $(objdir)/%.mo : %.ms mat.so echo '(optimize-level $o)'\ '(#%$$suppress-primitive-inlining #${spi})'\ '(#%$$enable-check-heap #${ehc})'\ + '(#%$$enable-check-prelex-flags #${ecpf})'\ '(compile-profile #$p)'\ '(collect-trip-bytes ${ctb})'\ '(collect-generation-radix ${cgr})'\ '(collect-maximum-generation ${cmg})'\ '(enable-object-counts #${eoc})'\ + '(commonization-level ${cl})'\ '(compile-interpret-simple #${cis})'\ '(set! *examples-directory* "${Examples}")'\ '(enable-cp0 #${cp0})'\ @@ -222,15 +234,15 @@ partialx: allx: prettyclean $(MAKE) allxhelp o=0 $(MAKE) allxhelp o=3 - $(MAKE) allxhelp o=0 cp0=t - $(MAKE) allxhelp o=3 cp0=t + $(MAKE) allxhelp o=0 cp0=t cl=3 + $(MAKE) allxhelp o=3 cp0=t cl=3 $(MAKE) allxhelp o=0 spi=t rmg=2 p=t $(MAKE) allxhelp o=3 spi=t rmg=2 p=t - $(MAKE) allxhelp o=0 eval=interpret - $(MAKE) allxhelp o=3 eval=interpret + $(MAKE) allxhelp o=0 eval=interpret cl=6 + $(MAKE) allxhelp o=3 eval=interpret cl=6 $(MAKE) allxhelp o=0 eval=interpret cp0=t rmg=2 $(MAKE) allxhelp o=3 eval=interpret cp0=t rmg=2 - $(MAKE) allxhelp o=0 eoc=f ehc=t + $(MAKE) allxhelp o=0 eoc=f ehc=t cl=9 $(MAKE) allxhelp o=3 eval=interpret ehc=t rmg=2 just-reports: @@ -252,12 +264,12 @@ bullyx: bully: -$(MAKE) allxhelpnotall spi=t cp0=f - -$(MAKE) allxhelp spi=f cp0=f ctb='(/ (collect-trip-bytes) 64)' ehc=t + -$(MAKE) allxhelp spi=f cp0=f cl=9 ctb='(/ (collect-trip-bytes) 64)' ehc=t -$(MAKE) allxhelp spi=t cp0=f cis=t cmg=1 -$(MAKE) allxhelp spi=f cp0=f cis=t cmg=6 ehc=t -$(MAKE) allxhelp spi=t cp0=t ctb='(/ (collect-trip-bytes) 64)' cgr=6 -$(MAKE) allxhelp spi=t cp0=f p=t eoc=f ehc=t - -$(MAKE) allxhelp spi=f cp0=t p=t ehc=t + -$(MAKE) allxhelp spi=f cp0=t cl=9 p=t ehc=t -$(MAKE) allxhelp eval=interpret spi=f cp0=f -$(MAKE) allxhelp eval=interpret spi=f cp0=t -$(MAKE) allxhelp eval=interpret spi=t cp0=f ctb='(/ (collect-trip-bytes) 64)' ehc=t @@ -272,6 +284,7 @@ doheader: printf "%s" "-------- o=$o" >> summary if [ "$(spi)" != "$(defaultspi)" ] ; then printf " spi=$(spi)" >> summary ; fi if [ "$(ehc)" != "$(defaultehc)" ] ; then printf " ehc=$(ehc)" >> summary ; fi + if [ "$(ecpf)" != "$(defaultecpf)" ] ; then printf " ecpf(ecpf)" >> summary ; fi if [ "$(cp0)" != "$(defaultcp0)" ] ; then printf " cp0=$(cp0)" >> summary ; fi if [ "$(cis)" != "$(defaultcis)" ] ; then printf " cis=$(cis)" >> summary ; fi if [ "$p" != "$(defaultp)" ] ; then printf " p=$p" >> summary ; fi @@ -280,6 +293,7 @@ doheader: if [ "$(cgr)" != "$(defaultcgr)" ] ; then printf " cgr=$(cgr)" >> summary ; fi if [ "$(cmg)" != "$(defaultcmg)" ] ; then printf " cmg=$(cmg)" >> summary ; fi if [ "$(eoc)" != "$(defaulteoc)" ] ; then printf " eoc=$(eoc)" >> summary ; fi + if [ "$(cl)" != "$(defaultcl)" ] ; then printf " cl=$(cl)" >> summary ; fi if [ "$(hdrmsg)" != "" ] ; then printf " $(hdrmsg)" >> summary ; fi dosummary: @@ -312,11 +326,13 @@ script.all$o makescript$o: echo '(optimize-level $o)'\ '(#%$$suppress-primitive-inlining #${spi})'\ '(#%$$enable-check-heap #${ehc})'\ + '(#%$$enable-check-prelex-flags #${ecpf})'\ '(compile-profile #$p)'\ '(collect-trip-bytes ${ctb})'\ '(collect-generation-radix ${cgr})'\ '(collect-maximum-generation ${cmg})'\ '(enable-object-counts #${eoc})'\ + '(commonization-level ${cl})'\ '(compile-interpret-simple #${cis})'\ '(set! *examples-directory* "${Examples}")'\ '(enable-cp0 #${cp0})'\ diff --git a/mats/mat.ss b/mats/mat.ss index 22eb4000ef..4a4e5477b7 100644 --- a/mats/mat.ss +++ b/mats/mat.ss @@ -260,38 +260,52 @@ ; same modulo renaming of gensyms ; procedure in either input is used as predicate for other (lambda (x y) - (let ([alist '()]) - (let e? ([x x] [y y]) - (cond - [(procedure? x) (x y)] - [(procedure? y) (y x)] - [(eqv? x y) #t] - [(pair? x) - (and (pair? y) (e? (car x) (car y)) (e? (cdr x) (cdr y)))] - [(or (and (gensym? x) (symbol? y)) - (and (gensym? y) (symbol? x))) - (cond - [(assq x alist) => (lambda (a) (eq? y (cdr a)))] - [else (set! alist (cons `(,x . ,y) alist)) #t])] - [(string? x) (and (string? y) (string=? x y))] - [(bytevector? x) (and (bytevector? y) (bytevector=? x y))] - [(vector? x) - (and (vector? y) - (fx= (vector-length x) (vector-length y)) - (let f ([i (fx- (vector-length x) 1)]) - (or (fx< i 0) - (and (e? (vector-ref x i) (vector-ref y i)) - (f (fx1- i))))))] - [(fxvector? x) - (and (fxvector? y) - (fx= (fxvector-length x) (fxvector-length y)) - (let f ([i (fx- (fxvector-length x) 1)]) - (if (fx< i 0) - k - (and (fx= (fxvector-ref x i) (fxvector-ref y i)) - (f (fx1- i))))))] - [(box? x) (and (box? y) (e? (unbox x) (unbox y)))] - [else #f]))))) + (let ([alist '()] [oops? #f]) + (or (let e? ([x x] [y y]) + (or (cond + [(procedure? x) (x y)] + [(procedure? y) (y x)] + [(eqv? x y) #t] + [(pair? x) + (and (pair? y) (e? (car x) (car y)) (e? (cdr x) (cdr y)))] + [(or (and (gensym? x) (symbol? y)) + (and (gensym? y) (symbol? x))) + (cond + [(assq x alist) => (lambda (a) (eq? y (cdr a)))] + [else (set! alist (cons `(,x . ,y) alist)) #t])] + [(string? x) (and (string? y) (string=? x y))] + [(bytevector? x) (and (bytevector? y) (bytevector=? x y))] + [(vector? x) + (and (vector? y) + (fx= (vector-length x) (vector-length y)) + (let f ([i (fx- (vector-length x) 1)]) + (or (fx< i 0) + (and (e? (vector-ref x i) (vector-ref y i)) + (f (fx1- i))))))] + [(fxvector? x) + (and (fxvector? y) + (fx= (fxvector-length x) (fxvector-length y)) + (let f ([i (fx- (fxvector-length x) 1)]) + (if (fx< i 0) + k + (and (fx= (fxvector-ref x i) (fxvector-ref y i)) + (f (fx1- i))))))] + [(box? x) (and (box? y) (e? (unbox x) (unbox y)))] + [else #f]) + (begin + (unless oops? + (set! oops? #t) + (printf "failure in equivalent-expansion?:\n") + (pretty-print x) + (printf "is not equivalent to\n") + (pretty-print y)) + #f))) + (begin + (printf "original expressions:\n") + (pretty-print x) + (printf "is not equivalent to\n") + (pretty-print y) + #f))))) (define *fuzz* 1e-14) diff --git a/mats/record.ms b/mats/record.ms index 04aa251ac7..b657ea1cbb 100644 --- a/mats/record.ms +++ b/mats/record.ms @@ -3132,6 +3132,129 @@ (hashtable-ref h graph1 #f) (hashtable-ref h graph2 #f) (not (hashtable-ref h graph3 #f)) + + (begin + (define record-hash + (lambda (x hash) + (let ([rtd (record-rtd x)]) + (do ([field-name* (csv7:record-type-field-names rtd) (cdr field-name*)] + [i 0 (fx+ i 1)] + [h 0 (+ h (hash ((csv7:record-field-accessor rtd i) x)))]) + ((null? field-name*) h))))) + (define record-equal? + (lambda (x y e?) + (let ([rtd (record-rtd x)]) + (and (eq? (record-rtd y) rtd) + (let f ([field-name* (csv7:record-type-field-names rtd)] [i 0]) + (or (null? field-name*) + (and (let ([accessor (csv7:record-field-accessor rtd i)]) + (e? (accessor x) (accessor y))) + (f (cdr field-name*) (fx+ i 1))))))))) + (define equiv? + (lambda (x y) + (parameterize ([default-record-equal-procedure record-equal?]) + (equal? x y)))) + (define equiv-hash + (lambda (x) + (parameterize ([default-record-hash-procedure record-hash]) + (equal-hash x)))) + (define-record-type frob (fields (mutable q))) + (define-record-type frub (fields (mutable x) y z)) + (define frob-hash + (lambda (x hash) + (raise 'frob-hash))) + (define frob-equal? + (lambda (x y e?) + #f)) + (define rthp + (lambda (rtd) + (case-lambda + [() (record-type-hash-procedure rtd)] + [(x) (record-type-hash-procedure rtd x)]))) + (define rtep + (lambda (rtd) + (case-lambda + [() (record-type-equal-procedure rtd)] + [(x) (record-type-equal-procedure rtd x)]))) + #t) + (not (record-type-equal-procedure (record-type-descriptor frob))) + (not (record-type-hash-procedure (record-type-descriptor frob))) + (not (record-type-equal-procedure (record-type-descriptor frub))) + (not (record-type-hash-procedure (record-type-descriptor frub))) + (equal? + (parameterize ([(rthp (record-type-descriptor frob)) record-hash]) + (list + (record-hash-procedure (make-frob #\q)) + (record-hash-procedure (make-frub 1 2 3)))) + (list record-hash #f)) + (equal? + (parameterize ([(rtep (record-type-descriptor frob)) record-equal?]) + (list + (record-equal-procedure (make-frub 1 2 3) (make-frub 1 2 3)) + (record-equal-procedure (make-frub 1 2 3) (make-frob #\q)) + (record-equal-procedure (make-frob #\q) (make-frub 1 2 3)) + (record-equal-procedure (make-frob #\q) (make-frob #\q)))) + (list #f #f #f record-equal?)) + (equal? + (parameterize ([default-record-hash-procedure record-hash]) + (list + (record-hash-procedure (make-frob #\q)) + (record-hash-procedure (make-frub 1 2 3)))) + (list record-hash record-hash)) + (equal? + (parameterize ([default-record-equal-procedure record-equal?]) + (list + (record-equal-procedure (make-frub 1 2 3) (make-frub 1 2 3)) + (record-equal-procedure (make-frub 1 2 3) (make-frob #\q)) + (record-equal-procedure (make-frob #\q) (make-frub 1 2 3)) + (record-equal-procedure (make-frob #\q) (make-frob #\q)))) + (list record-equal? record-equal? record-equal? record-equal?)) + (equal? + (parameterize ([default-record-hash-procedure record-hash] + [(rthp (record-type-descriptor frob)) frob-hash]) + (list + (record-hash-procedure (make-frob #\q)) + (record-hash-procedure (make-frub 1 2 3)))) + (list frob-hash record-hash)) + (equal? + (parameterize ([default-record-equal-procedure record-equal?] + [(rtep (record-type-descriptor frob)) frob-equal?]) + (list + (record-equal-procedure (make-frub 1 2 3) (make-frub 1 2 3)) + (record-equal-procedure (make-frub 1 2 3) (make-frob #\q)) + (record-equal-procedure (make-frob #\q) (make-frub 1 2 3)) + (record-equal-procedure (make-frob #\q) (make-frob #\q)))) + (list record-equal? #f #f frob-equal?)) + ((lambda (x) (and (integer? x) (exact? x) (nonnegative? x))) + (parameterize ([default-record-hash-procedure record-hash]) + (equal-hash (vector 1 2 (make-frub 1 2 3) 5 (make-frob #\q) 7)))) + (eq? + (guard (c [(eq? c 'frob-hash) 'yup] [else (raise c)]) + (parameterize ([default-record-hash-procedure record-hash] + [(rthp (record-type-descriptor frob)) frob-hash]) + (equal-hash (list "hello" (make-frob #\q))))) + 'yup) + ((lambda (x) (and (integer? x) (exact? x) (nonnegative? x))) + (parameterize ([default-record-hash-procedure record-hash] + [(rthp (record-type-descriptor frob)) frob-hash]) + (equal-hash (vector 1 2 (make-frub 1 2 3) 5 6)))) + (equiv? (make-frob #\q) (make-frob #\q)) + (equiv? (make-frub 1 2 3) (make-frub 1 2 3)) + (not (parameterize ([(rtep (record-type-descriptor frob)) frob-equal?]) + (equiv? (make-frob #\q) (make-frob #\q)))) + (parameterize ([(rtep (record-type-descriptor frob)) frob-equal?]) + (equiv? (make-frub 1 2 3) (make-frub 1 2 3))) + (equal? + (let ([ht (make-hashtable equiv-hash equiv?)]) + (hashtable-set! ht (make-frob #\q) 'one) + (hashtable-set! ht (make-frub 1 2 3) 'two) + (hashtable-set! ht (make-frub 'a 'b 'c) 'three) + (list + (hashtable-ref ht (make-frob #\q) #f) + (hashtable-ref ht (make-frub 1 2 3) #f) + (hashtable-ref ht (make-frub 'a 'b 'c) #f) + (hashtable-ref ht (make-frub 'x 'y 'z) #f))) + '(one two three #f)) ) (mat record19 @@ -7569,7 +7692,7 @@ '(#($cpoint 3 4 (rgb . red)) (rgb . red) #($point -8 -15)))))) `(begin (set! $color->rgb (lambda (c) (#2%cons 'rgb c))) - (let ([g7 (lambda (n) n)]) + (letrec ([g7 (lambda (n) n)]) (#3%$set-top-level-value! 'rcd1 (#3%$make-record-constructor-descriptor ',record-type-descriptor? #f g7 'define-record-type))) @@ -7643,7 +7766,7 @@ '(#($cpoint 3 4 (rgb . red)) (rgb . red) #($point -8 -15)))))) `(begin (set! $color->rgb (lambda (c) (#3%cons 'rgb c))) - (let ([g7 (lambda (n) n)]) + (letrec ([g7 (lambda (n) n)]) (#3%$set-top-level-value! 'rcd1 (#3%$make-record-constructor-descriptor ',record-type-descriptor? #f g7 'define-record-type))) @@ -8711,7 +8834,7 @@ (new q x))))))) (make-foo 3)))) `(let ([ctr 0]) - (let ([g0 (lambda (new) (lambda (q) (new q (begin (set! ctr (#2%+ 1 xtr)) ctr))))]) + (letrec ([g0 (lambda (new) (lambda (q) (new q (begin (set! ctr (#2%+ 1 xtr)) ctr))))]) (#3%$make-record-constructor-descriptor ',record-type-descriptor? #f g0 'define-record-type) (#3%$record ',record-type-descriptor? 3 (begin (set! ctr (#2%+ 1 xtr)) ctr))))) (equivalent-expansion? @@ -8730,7 +8853,7 @@ (new q x))))))) (make-foo 3)))) `(let ([ctr 0]) - (let ([g0 (lambda (new) (lambda (q) (new q (begin (set! ctr (#3%+ 1 xtr)) ctr))))]) + (letrec ([g0 (lambda (new) (lambda (q) (new q (begin (set! ctr (#3%+ 1 xtr)) ctr))))]) (#3%$make-record-constructor-descriptor ',record-type-descriptor? #f g0 'define-record-type) (#3%$record ',record-type-descriptor? 3 (begin (set! ctr (#3%+ 1 xtr)) ctr))))) (error? ; invalid uid diff --git a/release_notes/release_notes.stex b/release_notes/release_notes.stex index 2f7f287b56..ecc4ae8c98 100644 --- a/release_notes/release_notes.stex +++ b/release_notes/release_notes.stex @@ -58,15 +58,22 @@ Online versions of both books can be found at %----------------------------------------------------------------------------- \section{Functionality Changes}\label{section:functionality} -\subsection{Record equality and hashing (9.5)} +\subsection{Record equality and hashing (9.5, 9.5.1)} -The new procedures \scheme{record-type-equal-procedure} and +Several new procedures and parameters allow a program to control what +\scheme{equal?} and \scheme{equal-hash} do when applied +to structures containing record instances. +The procedures \scheme{record-type-equal-procedure} and \scheme{record-type-hash-procedure} can be used to customize the -handling of records by \scheme{equal?} and \scheme{hash}, and -the new procedures \scheme{record-equal-procedure} and +handling of records of specific types by \scheme{equal?} and \scheme{hash}, and +the procedures \scheme{record-equal-procedure} and \scheme{record-hash-procedure} can be used to look up the applicable (possibly inherited) equality and hashing procedures for specific record instances. +The parameters \scheme{default-record-equal-procedure} and +\scheme{default-record-hash-procedure} can be used to control +the default behavior when comparing or hashing records without +type-specific equality and hashing procedures. \subsection{Immutable vectors, fxvectors, bytevectors, strings, and boxes (9.5)} @@ -1768,6 +1775,18 @@ x86\_64 has been fixed. %----------------------------------------------------------------------------- \section{Performance Enhancements}\label{section:performance} +\subsection{Lambda commonization (9.5.1)} + +After running the main source optimization pass (cp0), the +compiler optionally runs a \emph{commonization} pass, which +commonizes code for similar lambda expressions. +The parameter \scheme{commonization-level} controls whether the +commonization pass is run and, if so, how aggressive it is. +The parameter's value must be a nonnegative exact integer ranging +from 0 through 9. When the parameter is set to 0, the default, +commonization is not run. Otherwise, higher values result in more +commonization. + \subsection{Improved compile times (9.5.1)} Compile times are now lower, sometimes by an order of magnitude or diff --git a/s/Mf-base b/s/Mf-base index ba99af842c..35fce73394 100644 --- a/s/Mf-base +++ b/s/Mf-base @@ -24,6 +24,9 @@ o = 3 # d is the debug level at which the system should be built d = 0 +# cl (xcl) determines the commonization level +cl = (commonization-level) + # i determines whether inspector-information is generated: f for false, t for true i = f @@ -102,7 +105,7 @@ patch = patch # putting cpnanopass.patch early for maximum make --jobs=2 benefit patchobj = patch.patch cpnanopass.patch cprep.patch cpcheck.patch\ - cp0.patch cpvalid.patch cpletrec.patch\ + cp0.patch cpvalid.patch cpcommonize.patch cpletrec.patch\ reloc.patch\ compile.patch fasl.patch syntax.patch env.patch\ read.patch interpret.patch ftype.patch strip.patch\ @@ -124,7 +127,7 @@ basesrc =\ strnum.ss bytevector.ss 5_4.ss 5_6.ss 5_7.ss\ event.ss 4.ss front.ss foreign.ss 6.ss print.ss newhash.ss\ format.ss date.ss 7.ss cafe.ss trace.ss engine.ss\ - interpret.ss cprep.ss cpcheck.ss cp0.ss cpvalid.ss cpletrec.ss inspect.ss\ + interpret.ss cprep.ss cpcheck.ss cp0.ss cpvalid.ss cpcommonize.ss cpletrec.ss inspect.ss\ enum.ss io.ss read.ss primvars.ss syntax.ss costctr.ss expeditor.ss\ exceptions.ss pretty.ss env.ss\ fasl.ss reloc.ss pdhtml.ss strip.ss ftype.ss back.ss @@ -205,6 +208,7 @@ clean: profileclean echo '(reset-handler abort)'\ '(optimize-level $o)'\ '(debug-level $d)'\ + '(commonization-level $(cl))'\ '(when #$p (compile-profile (quote source)))'\ '(when #$(bp) (compile-profile (quote block)))'\ '(when #$(loadspd) (profile-load-data "${ProfileDumpSource}"))'\ @@ -228,6 +232,7 @@ clean: profileclean echo '(reset-handler abort)'\ '(optimize-level $o)'\ '(debug-level $d)'\ + '(commonization-level $(cl))'\ '(when #$p (compile-profile (quote source)))'\ '(when #$(bp) (compile-profile (quote block)))'\ '(when #$(loadspd) (profile-load-data "${ProfileDumpSource}"))'\ @@ -254,6 +259,7 @@ clean: profileclean '(keyboard-interrupt-handler (lambda () (display "interrupted---aborting\n") (reset)))'\ '(optimize-level $o)'\ '(debug-level $d)'\ + '(commonization-level $(cl))'\ '(generate-inspector-information #$i)'\ '(subset-mode (quote system))'\ '(compile-file "$*.ss" "$*.so")'\ @@ -263,6 +269,7 @@ clean: profileclean echo '(reset-handler abort)'\ '(optimize-level $o)'\ '(debug-level $d)'\ + '(commonization-level $(cl))'\ '(when #$(xp) (compile-profile (quote source)))'\ '(when #$(xbp) (compile-profile (quote block)))'\ '(generate-inspector-information #$i)'\ @@ -331,6 +338,7 @@ cmacros.so: cmacros.ss machine.def layout.ss '(keyboard-interrupt-handler (lambda () (display "interrupted---aborting\n") (reset)))'\ '(optimize-level $o)'\ '(debug-level $d)'\ + '(commonization-level $(cl))'\ '(generate-inspector-information #$i)'\ '(subset-mode (quote system))'\ '(compile-file "$*.ss" "$*.so")'\ @@ -342,6 +350,7 @@ priminfo.so: priminfo.ss primdata.ss cmacros.so '(keyboard-interrupt-handler (lambda () (display "interrupted---aborting\n") (reset)))'\ '(optimize-level $o)'\ '(debug-level $d)'\ + '(commonization-level $(cl))'\ '(generate-inspector-information #$i)'\ '(subset-mode (quote system))'\ '(compile-file "$*.ss" "$*.so")'\ @@ -354,6 +363,7 @@ mkheader.so: mkheader.ss cmacros.so primvars.so env.so '(keyboard-interrupt-handler (lambda () (display "interrupted---aborting\n") (reset)))'\ '(optimize-level $o)'\ '(debug-level $d)'\ + '(commonization-level $(cl))'\ '(generate-inspector-information #$i)'\ '(subset-mode (quote system))'\ '(compile-file "$*.ss" "$*.so")'\ @@ -365,6 +375,7 @@ nanopass.so: $(shell echo ../nanopass/nanopass/*) ../nanopass/nanopass.ss '(keyboard-interrupt-handler (lambda () (display "interrupted---aborting\n") (reset)))'\ '(optimize-level $o)'\ '(debug-level $d)'\ + '(commonization-level $(cl))'\ '(generate-inspector-information #$i)'\ '(collect-trip-bytes (expt 2 24))'\ '(collect-request-handler (lambda () (collect 0 1)))'\ @@ -387,6 +398,7 @@ script.all makescript: '(for-each load (command-line-arguments))'\ '(optimize-level $o)'\ '(debug-level $d)'\ + '(commonization-level $(cl))'\ '(when #$p (compile-profile (quote source)))'\ '(when #$(bp) (compile-profile (quote block)))'\ '(when #$(loadspd) (profile-load-data "${ProfileDumpSource}"))'\ @@ -422,6 +434,7 @@ script-static.all: '(for-each load (command-line-arguments))'\ '(optimize-level $o)'\ '(debug-level $d)'\ + '(commonization-level $(cl))'\ '(when #$p (compile-profile (quote source)))'\ '(when #$(bp) (compile-profile (quote block)))'\ '(generate-inspector-information #$i)'\ @@ -443,6 +456,7 @@ script-dynamic.all: '(for-each load (command-line-arguments))'\ '(optimize-level $o)'\ '(debug-level $d)'\ + '(commonization-level $(cl))'\ '(when #$p (compile-profile (quote source)))'\ '(when #$(bp) (compile-profile (quote block)))'\ '(generate-inspector-information #$i)'\ diff --git a/s/Mf-cross b/s/Mf-cross index da7e442d16..c466f7fa66 100644 --- a/s/Mf-cross +++ b/s/Mf-cross @@ -20,7 +20,7 @@ what = all examples base = ../.. -doitformebaby: xboot +xdoit: xboot include Mf-${xm} diff --git a/s/back.ss b/s/back.ss index ad18b522c0..c932edd766 100644 --- a/s/back.ss +++ b/s/back.ss @@ -119,6 +119,11 @@ (lambda (x) (and x #t)))) +(define $enable-check-prelex-flags + ($make-thread-parameter #f + (lambda (x) + (and x #t)))) + (define-who run-cp0 ($make-thread-parameter (default-run-cp0) diff --git a/s/cmacros.ss b/s/cmacros.ss index 822d50d59f..f7b668fc01 100644 --- a/s/cmacros.ss +++ b/s/cmacros.ss @@ -1366,6 +1366,8 @@ [ptr optimize-level] [ptr subset-mode] [ptr suppress-primitive-inlining] + [ptr default-record-equal-procedure] + [ptr default-record-hash-procedure] [U64 instr-counter] [U64 alloc-counter] [ptr parameters])) diff --git a/s/compile.ss b/s/compile.ss index e012607bf3..c56e3195a4 100644 --- a/s/compile.ss +++ b/s/compile.ss @@ -545,6 +545,11 @@ (lambda (x) (set-box! (cdr x) (symbol-hashtable-ref ht (car x) '())))))) +(define check-prelex-flags + (lambda (x after) + (when ($enable-check-prelex-flags) + ($pass-time 'cpcheck-prelex-flags (lambda () (do-trace $cpcheck-prelex-flags x 'uncprep)))))) + (define compile-file-help (lambda (op hostop wpoop machine sfd do-read outfn) (include "types.ss") @@ -592,7 +597,9 @@ (let ([x1 ($pass-time 'expand (lambda () (expand x0 (if (eq? (subset-mode) 'system) ($system-environment) (interaction-environment)) #t #t outfn)))]) + (check-prelex-flags x1 'expand) ($uncprep x1 #t) ; populate preinfo sexpr fields + (check-prelex-flags x1 'uncprep) (when wpoop ; cross-library optimization locs might be set by cp0 during the expander's compile-time ; evaluation of library forms. since we have no need for the optimization information in @@ -631,16 +638,28 @@ (let loop ([chunk* (expand-Lexpand x1)] [rx2b* '()] [rfinal* '()]) (define finish-compile (lambda (x1 f) - (let* ([x2 ($pass-time 'cpvalid (lambda () (do-trace $cpvalid x1)))] + (let* ([waste (check-prelex-flags x1 'before-cpvalid)] + [x2 ($pass-time 'cpvalid (lambda () (do-trace $cpvalid x1)))] + [waste (check-prelex-flags x2 'cpvalid)] [x2a (let ([cpletrec-ran? #f]) (let ([x ((run-cp0) (lambda (x) (set! cpletrec-ran? #t) - (let ([x ($pass-time 'cp0 (lambda () (do-trace $cp0 x)))]) - ($pass-time 'cpletrec (lambda () (do-trace $cpletrec x))))) + (let* ([x ($pass-time 'cp0 (lambda () (do-trace $cp0 x)))] + [waste (check-prelex-flags x 'cp0)] + [x ($pass-time 'cpletrec (lambda () (do-trace $cpletrec x)))] + [waste (check-prelex-flags x 'cpletrec)]) + x)) x2)]) - (if cpletrec-ran? x ($pass-time 'cpletrec (lambda () (do-trace $cpletrec x))))))] + (if cpletrec-ran? + x + (let ([x ($pass-time 'cpletrec (lambda () (do-trace $cpletrec x)))]) + (check-prelex-flags x 'cpletrec) + x))))] [x2b ($pass-time 'cpcheck (lambda () (do-trace $cpcheck x2a)))] + [waste (check-prelex-flags x2b 'cpcheck)] + [x2b ($pass-time 'cpcommonize (lambda () (do-trace $cpcommonize x2b)))] + [waste (check-prelex-flags x2b 'cpcommonize)] [x7 (do-trace $np-compile x2b #t)] [x8 ($c-make-closure x7)]) (loop (cdr chunk*) (cons (f x2b) rx2b*) (cons (f x8) rfinal*))))) @@ -1030,24 +1049,6 @@ (define build-void (let ([void-rec `(quote ,(void))]) (lambda () void-rec))) - (define build-cluster* - (lambda (node*) - (define (s-entry/binary node* rcluster*) - (if (null? node*) - (reverse rcluster*) - (let ([node (car node*)]) - (if (library-node-binary? node) - (s-entry/binary (cdr node*) rcluster*) - (s-source (cdr node*) (list node) rcluster*))))) - (define (s-source node* rnode* rcluster*) - (if (null? node*) - (reverse (cons (reverse rnode*) rcluster*)) - (let ([node (car node*)]) - (if (library-node-binary? node) - (s-entry/binary (cdr node*) (cons (reverse rnode*) rcluster*)) - (s-source (cdr node*) (cons node rnode*) rcluster*))))) - (s-entry/binary node* '()))) - (define build-lambda (lambda (ids body) `(case-lambda ,(make-preinfo-lambda) @@ -1067,12 +1068,60 @@ (build-primcall '$install-library/rt-code `(quote ,(library-node-uid node)) thunk))) (define-pass patch : Lsrc (ir env) -> Lsrc () + (definitions + (define with-initialized-ids + (lambda (old-id* proc) + (let ([new-id* (map (lambda (old-id) + (let ([new-id (make-prelex + (prelex-name old-id) + (let ([flags (prelex-flags old-id)]) + (fxlogor + (fxlogand flags (constant prelex-sticky-mask)) + (fxsll (fxlogand flags (constant prelex-is-mask)) + (constant prelex-was-flags-offset)))) + (prelex-source old-id) + #f)]) + (prelex-operand-set! old-id new-id) + new-id)) + old-id*)]) + (let-values ([v* (proc new-id*)]) + (for-each (lambda (old-id) (prelex-operand-set! old-id #f)) old-id*) + (apply values v*))))) + (define build-ref + (case-lambda + [(x) (build-ref #f x)] + [(src x) + (let ([x (prelex-operand x)]) + (safe-assert (prelex? x)) + (if (prelex-referenced x) + (set-prelex-multiply-referenced! x #t) + (set-prelex-referenced! x #t)) + `(ref ,src ,x))]))) (Expr : Expr (ir) -> Expr () + [(ref ,maybe-src ,x) (build-ref maybe-src x)] [(call ,preinfo ,pr (quote ,d)) (guard (eq? (primref-name pr) '$top-level-value) (symbol? d)) (cond - [(symbol-hashtable-ref env d #f) => (lambda (x) `(ref ,(preinfo-src preinfo) ,x))] - [else ir])])) + [(symbol-hashtable-ref env d #f) => (lambda (x) (build-ref (preinfo-src preinfo) x))] + [else ir])] + [(set! ,maybe-src ,x ,[e]) + (let ([x (prelex-operand x)]) + (safe-assert (prelex? x)) + (set-prelex-assigned! x #t) + `(set! ,maybe-src ,x ,e))] + [(letrec ([,x* ,e*] ...) ,body) + (with-initialized-ids x* + (lambda (x*) + `(letrec ([,x* ,(map Expr e*)] ...) ,(Expr body))))] + [(letrec* ([,x* ,e*] ...) ,body) + (with-initialized-ids x* + (lambda (x*) + `(letrec* ([,x* ,(map Expr e*)] ...) ,(Expr body))))]) + (CaseLambdaClause : CaseLambdaClause (ir) -> CaseLambdaClause () + [(clause (,x* ...) ,interface ,body) + (with-initialized-ids x* + (lambda (x*) + `(clause (,x* ...) ,interface ,(Expr body))))])) (define build-top-level-set!* (lambda (node) @@ -1082,7 +1131,6 @@ (lambda (dl db dv body) (if dl `(seq ,(build-primcall '$set-top-level-value! `(quote ,dl) - ;; not using build-ref here because we don't want to change the ref/multiply refed flags `(cte-optimization-loc ,db (ref #f ,dv))) ,body) body)) @@ -1105,7 +1153,7 @@ (define build-combined-program-ir (lambda (program node*) - (let ([patch-env (make-patch-env node*)]) + (patch (fold-right (lambda (node combined-body) (if (library-node-binary? node) @@ -1117,8 +1165,8 @@ ,combined-body) (nanopass-case (Lexpand rtLibrary) (library-node-rtir node) [(library/rt ,uid (,dl* ...) (,db* ...) (,dv* ...) (,de* ...) ,body) - `(letrec* ([,dv* ,(map (lambda (de) (patch de patch-env)) de*)] ...) - (seq ,(patch body patch-env) + `(letrec* ([,dv* ,de*] ...) + (seq ,body (seq ,(build-install-library/rt-code node (if (library-node-visible? node) @@ -1126,8 +1174,9 @@ void-pr)) ,combined-body)))]))) (nanopass-case (Lexpand Program) (program-node-ir program) - [(program ,uid ,body) (patch body patch-env)]) - node*)))) + [(program ,uid ,body) body]) + node*) + (make-patch-env node*)))) (define build-combined-library-ir (lambda (node*) @@ -1135,34 +1184,41 @@ (define build-let (lambda (ids exprs body) `(call ,(make-preinfo) ,(build-lambda ids body) ,exprs ...))) - (define build-ref - (lambda (x) - (when (prelex-referenced x) - (set-prelex-multiply-referenced! x #t)) - (set-prelex-referenced! x #t) - `(ref #f ,x))) - (define build-set! - (lambda (x e) - (set-prelex-assigned! x #t) - `(set! #f ,x ,e))) (define build-mark-invoked! (lambda (node) (build-primcall '$mark-invoked! `(quote ,(library-node-uid node))))) - (let ([patch-env (make-patch-env node*)]) - (define build-cluster - (lambda (node* cluster-body) - (fold-right - (lambda (node cluster-body) - (nanopass-case (Lexpand rtLibrary) (library-node-rtir node) - [(library/rt ,uid (,dl* ...) (,db* ...) (,dv* ...) (,de* ...) ,body) - `(letrec* ([,dv* ,(map (lambda (de) (patch de patch-env)) de*)] ...) - (seq ,(patch body patch-env) - (seq - ,(if (library-node-visible? node) - `(seq ,(build-top-level-set!* node) ,(build-mark-invoked! node)) - (build-mark-invoked! node)) - ,cluster-body)))])) - cluster-body node*))) + (define build-cluster* + (lambda (node*) + (define (s-entry/binary node* rcluster*) + (if (null? node*) + (reverse rcluster*) + (let ([node (car node*)]) + (if (library-node-binary? node) + (s-entry/binary (cdr node*) rcluster*) + (s-source (cdr node*) (list node) rcluster*))))) + (define (s-source node* rnode* rcluster*) + (if (null? node*) + (reverse (cons (reverse rnode*) rcluster*)) + (let ([node (car node*)]) + (if (library-node-binary? node) + (s-entry/binary (cdr node*) (cons (reverse rnode*) rcluster*)) + (s-source (cdr node*) (cons node rnode*) rcluster*))))) + (s-entry/binary node* '()))) + (define build-cluster + (lambda (node* cluster-body) + (fold-right + (lambda (node cluster-body) + (nanopass-case (Lexpand rtLibrary) (library-node-rtir node) + [(library/rt ,uid (,dl* ...) (,db* ...) (,dv* ...) (,de* ...) ,body) + `(letrec* ([,dv* ,de*] ...) + (seq ,body + (seq + ,(if (library-node-visible? node) + `(seq ,(build-top-level-set!* node) ,(build-mark-invoked! node)) + (build-mark-invoked! node)) + ,cluster-body)))])) + cluster-body node*))) + (patch ; example: D imports C; C imports A, B; B imports A; A imports nothing ; have wpos for D, A, B; obj for C ; (let ([lib-f (void)]) @@ -1190,31 +1246,32 @@ (let ([cluster-idx* (enumerate cluster*)]) (build-let (list lib-f) (list (build-void)) `(seq - ,(build-set! lib-f - (let f ([cluster* cluster*] [cluster-idx* cluster-idx*]) + (set! #f ,lib-f + ,(let f ([cluster* cluster*] [cluster-idx* cluster-idx*]) (let ([idx (gen-var 'idx)]) (build-lambda (list idx) (build-cluster (car cluster*) (let ([cluster* (cdr cluster*)]) (if (null? cluster*) (let ([idx (gen-var 'idx)]) - (build-set! lib-f (build-lambda (list idx) (build-void)))) + `(set! #f ,lib-f ,(build-lambda (list idx) (build-void)))) (let ([t (gen-var 't)]) (build-let (list t) (list (f cluster* (cdr cluster-idx*))) - `(if ,(build-primcall 'eqv? (build-ref idx) `(quote ,(car cluster-idx*))) - ,(build-set! lib-f (build-ref t)) - ,(build-call (build-ref t) (build-ref idx)))))))))))) + `(if ,(build-primcall 'eqv? `(ref #f ,idx) `(quote ,(car cluster-idx*))) + (set! #f ,lib-f (ref #f ,t)) + ,(build-call `(ref #f ,t) `(ref #f ,idx)))))))))))) ,(fold-right (lambda (cluster cluster-idx body) (fold-right (lambda (node body) `(seq ,(build-install-library/rt-code node (if (library-node-visible? node) (build-lambda '() - (build-call (build-ref lib-f) `(quote ,cluster-idx))) + (build-call `(ref #f ,lib-f) `(quote ,cluster-idx))) void-pr)) ,body)) body cluster)) - (build-void) cluster* cluster-idx*))))))))) + (build-void) cluster* cluster-idx*))))) + (make-patch-env node*))))) (with-output-language (Lexpand Outer) (define add-library-records @@ -1416,7 +1473,8 @@ ($pass-time 'cpletrec (lambda () ($cpletrec x))))) x2)]) (if cpletrec-ran? x ($pass-time 'cpletrec (lambda () ($cpletrec x))))))] - [x2b ($pass-time 'cpcheck (lambda () ($cpcheck x2a)))]) + [x2b ($pass-time 'cpcheck (lambda () ($cpcheck x2a)))] + [x2b ($pass-time 'cpcommonize (lambda () ($cpcommonize x2b)))]) (when (and (expand/optimize-output) (not ($noexpand? x0))) (pretty-print ($uncprep x2b) (expand/optimize-output))) (if (and (compile-interpret-simple) diff --git a/s/cp0.ss b/s/cp0.ss index 3ceea44923..95bf069107 100644 --- a/s/cp0.ss +++ b/s/cp0.ss @@ -933,7 +933,7 @@ [(seq ,e1 ,e2) (pure-call? e1 e2)] [else (pure-call? #f e)]))] [(quote ,d) #t] - [,pr #t] + [,pr (all-set? (prim-mask proc) (primref-flags pr))] [(case-lambda ,preinfo ,cl* ...) #t] [(if ,e1 ,e2 ,e3) (memoize (and (pure? e1) (pure? e2) (pure? e3)))] [(seq ,e1 ,e2) (memoize (and (pure? e1) (pure? e2)))] @@ -991,7 +991,7 @@ [(seq ,e1 ,e2) (ivory-call? e1 e2)] [else (ivory-call? #f e)]))] [(quote ,d) #t] - [,pr #t] + [,pr (all-set? (prim-mask proc) (primref-flags pr))] [(case-lambda ,preinfo ,cl* ...) #t] [(if ,e1 ,e2 ,e3) (memoize (and (ivory? e1) (ivory? e2) (ivory? e3)))] [(seq ,e1 ,e2) (memoize (and (ivory? e1) (ivory? e2)))] diff --git a/s/cpletrec.ss b/s/cpletrec.ss index 4681aa01f8..37f7f52d5c 100644 --- a/s/cpletrec.ss +++ b/s/cpletrec.ss @@ -109,14 +109,24 @@ Handling letrec and letrec* (define-pass cpletrec : Lsrc (ir) -> Lsrc () (definitions - (define initialize-id! - (lambda (id) - (prelex-flags-set! id - (let ([flags (prelex-flags id)]) - (fxlogor - (fxlogand flags (constant prelex-sticky-mask)) - (fxsll (fxlogand flags (constant prelex-is-mask)) - (constant prelex-was-flags-offset))))))) + (define with-initialized-ids + (lambda (old-id* proc) + (let ([new-id* (map (lambda (old-id) + (let ([new-id (make-prelex + (prelex-name old-id) + (let ([flags (prelex-flags old-id)]) + (fxlogor + (fxlogand flags (constant prelex-sticky-mask)) + (fxsll (fxlogand flags (constant prelex-is-mask)) + (constant prelex-was-flags-offset)))) + (prelex-source old-id) + #f)]) + (prelex-operand-set! old-id new-id) + new-id)) + old-id*)]) + (let-values ([v* (proc new-id*)]) + (for-each (lambda (old-id) (prelex-operand-set! old-id #f)) old-id*) + (apply values v*))))) (define (Expr* e*) (if (null? e*) (values '() #t) @@ -243,9 +253,7 @@ Handling letrec and letrec* (cond [(and (not (prelex-referenced/assigned lhs)) (binding-pure? b)) body] [(and (not (prelex-assigned lhs)) (lambda? rhs)) - (if (binding-recursive? b) - (build-letrec (list lhs) (list rhs) body) - (build-let (make-preinfo) (make-preinfo-lambda) (list lhs) (list rhs) body))] + (build-letrec (list lhs) (list rhs) body)] [(not (memq b (node-link* b))) (build-let (make-preinfo) (make-preinfo-lambda) (list lhs) (list rhs) body)] [else (grisly-letrec '() b* body)])) @@ -272,32 +280,34 @@ Handling letrec and letrec* (and body-pure? (andmap binding-pure? b*))))))))) (Expr : Expr (ir) -> Expr (#t) [(ref ,maybe-src ,x) - (safe-assert (not (prelex-operand x))) - (safe-assert (prelex-was-referenced x)) - (when (prelex-referenced x) - (safe-assert (prelex-was-multiply-referenced x)) - (set-prelex-multiply-referenced! x #t)) - (set-prelex-seen/referenced! x #t) - (values ir (not (prelex-was-assigned x)))] + (let ([x (prelex-operand x)]) + (safe-assert (prelex? x)) + (safe-assert (prelex-was-referenced x)) + (when (prelex-referenced x) + (safe-assert (prelex-was-multiply-referenced x)) + (set-prelex-multiply-referenced! x #t)) + (set-prelex-seen/referenced! x #t) + (values `(ref ,maybe-src ,x) (not (prelex-was-assigned x))))] [(quote ,d) (values ir #t)] [(call ,preinfo0 (case-lambda ,preinfo1 (clause (,x* ...) ,interface ,body)) ,e* ...) (guard (fx= (length e*) interface)) - (for-each initialize-id! x*) - (let-values ([(body body-pure?) (Expr body)]) - (let-values ([(pre* lhs* rhs* pure?) - (let f ([x* x*] [e* e*]) - (if (null? x*) - (values '() '() '() #t) - (let ([x (car x*)]) - (let-values ([(e e-pure?) (Expr (car e*))] - [(pre* lhs* rhs* pure?) (f (cdr x*) (cdr e*))]) - (if (prelex-referenced/assigned x) - (values pre* (cons x lhs*) (cons e rhs*) (and e-pure? pure?)) - (values (if e-pure? pre* (cons e pre*)) - lhs* rhs* (and e-pure? pure?)))))))]) - (values - (build-seq pre* (build-let preinfo0 preinfo1 lhs* rhs* body)) - (and body-pure? pure?))))] + (with-initialized-ids x* + (lambda (x*) + (let-values ([(body body-pure?) (Expr body)]) + (let-values ([(pre* lhs* rhs* pure?) + (let f ([x* x*] [e* e*]) + (if (null? x*) + (values '() '() '() #t) + (let ([x (car x*)]) + (let-values ([(e e-pure?) (Expr (car e*))] + [(pre* lhs* rhs* pure?) (f (cdr x*) (cdr e*))]) + (if (prelex-referenced/assigned x) + (values pre* (cons x lhs*) (cons e rhs*) (and e-pure? pure?)) + (values (if e-pure? pre* (cons e pre*)) + lhs* rhs* (and e-pure? pure?)))))))]) + (values + (build-seq pre* (build-let preinfo0 preinfo1 lhs* rhs* body)) + (and body-pure? pure?))))))] [(call ,preinfo ,pr ,e* ...) (let () (define (arity-okay? arity n) @@ -321,19 +331,23 @@ Handling letrec and letrec* [(seq ,[e1 e1-pure?] ,[e2 e2-pure?]) (values `(seq ,e1 ,e2) (and e1-pure? e2-pure?))] [(set! ,maybe-src ,x ,[e pure?]) - (safe-assert (prelex-was-assigned x)) - ; NB: cpletrec-letrec assumes assignments to unreferenced ids are dropped - (if (prelex-was-referenced x) - (begin - (set-prelex-seen/assigned! x #t) - (values `(set! ,maybe-src ,x ,e) #f)) - (if pure? (values `(quote ,(void)) #t) (values `(seq ,e (quote ,(void))) #f)))] + (let ([x (prelex-operand x)]) + (safe-assert (prelex? x)) + (safe-assert (prelex-was-assigned x)) + ; NB: cpletrec-letrec assumes assignments to unreferenced ids are dropped + (if (prelex-was-referenced x) + (begin + (set-prelex-seen/assigned! x #t) + (values `(set! ,maybe-src ,x ,e) #f)) + (if pure? (values `(quote ,(void)) #t) (values `(seq ,e (quote ,(void))) #f))))] [(letrec ([,x* ,e*] ...) ,body) - (for-each initialize-id! x*) - (cpletrec-letrec #f x* e* body)] + (with-initialized-ids x* + (lambda (x*) + (cpletrec-letrec #f x* e* body)))] [(letrec* ([,x* ,e*] ...) ,body) - (for-each initialize-id! x*) - (cpletrec-letrec #t x* e* body)] + (with-initialized-ids x* + (lambda (x*) + (cpletrec-letrec #t x* e* body)))] [(foreign ,conv ,name ,[e pure?] (,arg-type* ...) ,result-type) (values `(foreign ,conv ,name ,e (,arg-type* ...) ,result-type) (and (fx= (optimize-level) 3) pure?))] @@ -367,9 +381,10 @@ Handling letrec and letrec* [else (sorry! who "unhandled record ~s" ir)]) (CaseLambdaClause : CaseLambdaClause (ir) -> CaseLambdaClause () [(clause (,x* ...) ,interface ,body) - (for-each initialize-id! x*) - (let-values ([(body pure?) (Expr body)]) - `(clause (,x* ...) ,interface ,body))]) + (with-initialized-ids x* + (lambda (x*) + (let-values ([(body pure?) (Expr body)]) + `(clause (,x* ...) ,interface ,body))))]) (let-values ([(ir pure?) (Expr ir)]) ir)) (lambda (x) diff --git a/s/cpnanopass.ss b/s/cpnanopass.ss index 071285692f..e3edbe1973 100644 --- a/s/cpnanopass.ss +++ b/s/cpnanopass.ss @@ -5335,6 +5335,8 @@ (define-tc-parameter $target-machine target-machine) (define-tc-parameter $current-stack-link stack-link) (define-tc-parameter $current-winders winders) + (define-tc-parameter default-record-equal-procedure default-record-equal-procedure) + (define-tc-parameter default-record-hash-procedure default-record-hash-procedure) ) (define-inline 3 $install-guardian diff --git a/s/cprep.ss b/s/cprep.ss index 09e76f3431..2ed568961e 100644 --- a/s/cprep.ss +++ b/s/cprep.ss @@ -215,14 +215,15 @@ (lambda (who cte? x env) (define (go x) ($uncprep - ($cpcheck - (let ([cpletrec-ran? #f]) - (let ([x ((run-cp0) - (lambda (x) - (set! cpletrec-ran? #t) - ($cpletrec ($cp0 x $compiler-is-loaded?))) - ($cpvalid x))]) - (if cpletrec-ran? x ($cpletrec x))))))) + ($cpcommonize + ($cpcheck + (let ([cpletrec-ran? #f]) + (let ([x ((run-cp0) + (lambda (x) + (set! cpletrec-ran? #t) + ($cpletrec ($cp0 x $compiler-is-loaded?))) + ($cpvalid x))]) + (if cpletrec-ran? x ($cpletrec x)))))))) (unless (environment? env) ($oops who "~s is not an environment" env)) ; claim compiling-a-file to get cte as well as run-time code @@ -243,4 +244,48 @@ (unless (environment? env) ($oops who "~s is not an environment" env)) ; claim compiling-a-file to get cte as well as run-time code - ($uncprep (expand x env #t #t))]))))) + ($uncprep (expand x env #t #t))])))) + + (set-who! $cpcheck-prelex-flags + (lambda (x after-pass) + (import (nanopass)) + (include "base-lang.ss") + + (define-pass cpcheck-prelex-flags : Lsrc (ir) -> Lsrc () + (definitions + (define sorry! + (lambda (who str . arg*) + (apply fprintf (console-output-port) str arg*) + (newline (console-output-port)))) + (define initialize-id! + (lambda (id) + (prelex-flags-set! id + (let ([flags (prelex-flags id)]) + (fxlogor + (fxlogand flags (constant prelex-sticky-mask)) + (fxsll (fxlogand flags (constant prelex-is-mask)) + (constant prelex-was-flags-offset)))))))) + (Expr : Expr (ir) -> Expr () + [(ref ,maybe-src ,x) + (when (prelex-operand x) (sorry! who "~s has an operand after ~s (src ~s)" x after-pass maybe-src)) + (unless (prelex-was-referenced x) (sorry! who "~s referenced but not so marked after ~s (src ~s)" x after-pass maybe-src)) + (when (prelex-referenced x) + (unless (prelex-was-multiply-referenced x) (sorry! who "~s multiply referenced but not so marked after ~s (src ~s)" x after-pass maybe-src)) + (set-prelex-multiply-referenced! x #t)) + (set-prelex-referenced! x #t) + `(ref ,maybe-src ,x)] + [(set! ,maybe-src ,x ,[e]) + (unless (prelex-was-assigned x) (sorry! who "~s assigned but not so marked after ~s (src ~s)" x after-pass maybe-src)) + (set-prelex-assigned! x #t) + `(set! ,maybe-src ,x ,e)] + [(letrec ([,x* ,e*] ...) ,body) + (for-each initialize-id! x*) + `(letrec ([,x* ,(map Expr e*)] ...) ,(Expr body))] + [(letrec* ([,x* ,e*] ...) ,body) + (for-each initialize-id! x*) + `(letrec* ([,x* ,(map Expr e*)] ...) ,(Expr body))]) + (CaseLambdaClause : CaseLambdaClause (ir) -> CaseLambdaClause () + [(clause (,x* ...) ,interface ,body) + (for-each initialize-id! x*) + `(clause (,x* ...) ,interface ,(Expr body))])) + (Lexpand-to-go x cpcheck-prelex-flags)))) diff --git a/s/ftype.ss b/s/ftype.ss index 27b2e54517..c49b866f4c 100644 --- a/s/ftype.ss +++ b/s/ftype.ss @@ -728,7 +728,10 @@ ftype operators: [else x])) #'?addr)]) #`($make-fptr '#,ftd - #,(if (fx= (optimize-level) 3) + #,(if (or (fx= (optimize-level) 3) + (syntax-case #'addr-expr (ftype-pointer-address) + [(ftype-pointer-address x) #t] + [else #f])) #'addr-expr #'(let ([addr addr-expr]) ($verify-ftype-address 'make-ftype addr) diff --git a/s/interpret.ss b/s/interpret.ss index 055890d507..ec382314d3 100644 --- a/s/interpret.ss +++ b/s/interpret.ss @@ -657,7 +657,8 @@ ($cpletrec ($cp0 x #f))) x2)]) (if cpletrec-ran? x ($cpletrec x))))] - [x2b ($cpcheck x2a)]) + [x2b ($cpcheck x2a)] + [x2b ($cpcommonize x2b)]) (when eoo (pretty-print ($uncprep x2b) eoo)) (ip2 (ip1 x2b)))) ([a0 0] [a1 0] [fp 0] [cp 0])))) diff --git a/s/newhash.ss b/s/newhash.ss index 9348043096..0449609c7c 100644 --- a/s/newhash.ss +++ b/s/newhash.ss @@ -1145,14 +1145,15 @@ Documentation notes: (let () (define (lookup-equal-procedure record1 record2) (let ([e/h (lookup-equal/hash record1 'equal-proc)]) - (and e/h - (let ([proc (equal/hash-maybe-proc e/h)]) - (and proc - (let ([rtd (equal/hash-rtd e/h)]) - (let ([e/h (lookup-equal/hash record2 'equal-proc)]) - (and e/h - (eq? (equal/hash-rtd e/h) rtd) - proc)))))))) + (let ([proc (equal/hash-maybe-proc e/h)]) + (if proc + (and + (eq? (equal/hash-rtd (lookup-equal/hash record2 'equal-proc)) (equal/hash-rtd e/h)) + proc) + (let ([default-proc (default-record-equal-procedure)]) + (and default-proc + (not (equal/hash-maybe-proc (lookup-equal/hash record2 'equal-proc))) + default-proc)))))) (set-who! $record-equal-procedure (lambda (record1 record2) (lookup-equal-procedure record1 record2))) @@ -1163,8 +1164,8 @@ Documentation notes: (lookup-equal-procedure record1 record2)))) (let () (define (lookup-hash-procedure record) - (let ([e/h (lookup-equal/hash record 'hash-proc)]) - (and e/h (equal/hash-maybe-proc e/h)))) + (or (equal/hash-maybe-proc (lookup-equal/hash record 'hash-proc)) + (default-record-hash-procedure))) (set-who! $record-hash-procedure (lambda (record) (lookup-hash-procedure record))) diff --git a/s/primdata.ss b/s/primdata.ss index 349ad75b14..0c89595c5c 100644 --- a/s/primdata.ss +++ b/s/primdata.ss @@ -917,6 +917,7 @@ (collect-trip-bytes [sig [() -> (ufixnum)] [(ufixnum) -> (void)]] [flags]) (command-line [sig [() -> (list)] [(sub-list) -> (void)]] [flags]) ; not restricted to 1 argument (command-line-arguments [sig [() -> (list)] [(sub-list) -> (void)]] [flags]) + (commonization-level [sig [() -> (ufixnum)] [(sub-ufixnum) -> (void)]] [flags]) (compile-compressed [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted]) (compile-file-message [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted]) (compile-interpret-simple [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted]) @@ -943,6 +944,8 @@ (custom-port-buffer-size [sig [() -> (ufixnum)] [(sub-fixnum) -> (void)]] [flags]) (debug-level [sig [() -> (ufixnum)] [(sub-ufixnum) -> (void)]] [flags]) (debug-on-exception [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted]) + (default-record-equal-procedure [sig [() -> (maybe-procedure)] [(maybe-procedure) -> (void)]] [flags]) + (default-record-hash-procedure [sig [() -> (maybe-procedure)] [(maybe-procedure) -> (void)]] [flags]) (enable-cross-library-optimization [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted]) (enable-object-counts [sig [() -> (boolean)] [(ptr) -> (void)]] [flags]) (eval-syntax-expanders-when [sig [() -> (list)] [(sub-list) -> (void)]] [flags]) @@ -1761,6 +1764,8 @@ ($continuation-winders [flags]) ($cp0 [flags]) ($cpcheck [flags]) + ($cpcheck-prelex-flags [flags]) + ($cpcommonize [flags]) ($cpletrec [flags]) ($cpvalid [flags]) ($c-stlv! [flags]) @@ -1773,6 +1778,7 @@ ($do-wind [flags]) ($dynamic-closure-counts [flags alloc]) ; added for closure instrumentation ($enum-set-members [flags]) + ($eol-style? [flags]) ($eq-hashtable-clear! [flags true]) ($eq-hashtable-copy [flags true discard]) ($eq-hashtable-entries [flags discard]) @@ -1780,6 +1786,7 @@ ($eq-hashtable-values [flags true discard]) ($errno [flags]) ($errno->string [flags]) + ($error-handling-mode? [flags]) ($event [flags]) ($exactnum? [flags]) ($exactnum-imag-part [flags]) @@ -2240,6 +2247,7 @@ ($cp0-polyvariant #;[sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted]) ($current-mso [flags]) ($enable-check-heap [flags]) + ($enable-check-prelex-flags [flags]) ($enable-expeditor [feature expeditor] [flags]) ($enable-pass-timing [flags]) ($expeditor-history-file [feature expeditor] [flags]) @@ -2259,9 +2267,7 @@ ($console-error-port [flags]) ($console-input-port [flags]) ($console-output-port [flags]) - ($eol-style? [flags]) ($eq-ht-rtd [flags]) - ($error-handling-mode? [flags]) ($heap-reserve-ratio [flags]) ($interrupt [flags]) ($nuate [flags]) diff --git a/s/prims.ss b/s/prims.ss index 04eda43f44..9728743ef6 100644 --- a/s/prims.ss +++ b/s/prims.ss @@ -1647,6 +1647,8 @@ (define-tc-parameter optimize-level (lambda (x) (and (fixnum? x) (fx<= 0 x 3))) "valid optimize level" 0) (define-tc-parameter $compile-profile (lambda (x) (memq x '(#f source block))) "valid compile-profile flag" #f) (define-tc-parameter subset-mode (lambda (mode) (memq mode '(#f system))) "valid subset mode" #f) + (define-tc-parameter default-record-equal-procedure (lambda (x) (or (eq? x #f) (procedure? x))) "a procedure or #f" #f) + (define-tc-parameter default-record-hash-procedure (lambda (x) (or (eq? x #f) (procedure? x))) "a procedure or #f" #f) ) (define-who compile-profile diff --git a/s/syntax.ss b/s/syntax.ss index bbec064e3a..08bc0176f1 100644 --- a/s/syntax.ss +++ b/s/syntax.ss @@ -582,9 +582,9 @@ (define build-lexical-reference (lambda (ae prelex) - (when (prelex-referenced prelex) - (set-prelex-multiply-referenced! prelex #t)) - (set-prelex-referenced! prelex #t) + (if (prelex-referenced prelex) + (set-prelex-multiply-referenced! prelex #t) + (set-prelex-referenced! prelex #t)) (build-profile ae `(ref ,(ae->src ae) ,prelex)))) (define build-lexical-assignment From 5933a80445ba4389feb3ec5c3ddcf0d9f717eaa6 Mon Sep 17 00:00:00 2001 From: dybvig Date: Mon, 29 Jan 2018 16:01:25 -0500 Subject: [PATCH 03/21] Adding missing file cpcommonize.ss. original commit: f94b55e92e329a5ea81938b04b217cb267f4f7af --- s/cpcommonize.ss | 578 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 578 insertions(+) create mode 100644 s/cpcommonize.ss diff --git a/s/cpcommonize.ss b/s/cpcommonize.ss new file mode 100644 index 0000000000..d08cc205b8 --- /dev/null +++ b/s/cpcommonize.ss @@ -0,0 +1,578 @@ +"cpcommonize.ss" +;;; cpcommonize.ss +;;; Copyright 1984-2017 Cisco Systems, Inc. +;;; +;;; Licensed under the Apache License, Version 2.0 (the "License"); +;;; you may not use this file except in compliance with the License. +;;; You may obtain a copy of the License at +;;; +;;; http://www.apache.org/licenses/LICENSE-2.0 +;;; +;;; Unless required by applicable law or agreed to in writing, software +;;; distributed under the License is distributed on an "AS IS" BASIS, +;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;;; See the License for the specific language governing permissions and +;;; limitations under the License. + +(define-who commonization-level + ($make-thread-parameter + 0 + (lambda (x) + (unless (and (fixnum? x) (<= 0 x 9)) + ($oops who "invalid level ~s" x)) + x))) + +(define $cpcommonize + (let () + (import (nanopass)) + (include "base-lang.ss") + + (define-record-type binding + (nongenerative) + (sealed #t) + (fields x (mutable e) size helper-box (mutable helper-b) (mutable helper-arg*)) + (protocol + (lambda (new) + (lambda (x e size helper-box) + (new x e size helper-box #f #f))))) + + (define-language Lcommonize1 (extends Lsrc) + (terminals + (+ (fixnum (size)))) + (Expr (e body rtd-expr) + (- (letrec ([x* e*] ...) body)) + (+ (letrec ([x* e* size] ...) body)))) + + (define-language Lcommonize2 (extends Lcommonize1) + (terminals + (- (fixnum (size))) + (+ (binding (b helper-b)))) + (Expr (e body rtd-expr) + (- (letrec ([x* e* size] ...) body)) + (+ (letrec (helper-b* ...) (b* ...) body)))) + + (define-syntax iffalse + (syntax-rules () + [(_ e1 e2) e1 #;(or e1 (begin e2 #f))])) + + (define-syntax iftrue + (syntax-rules () + [(_ e1 e2) e1 #;(let ([t e1]) (and t (begin e2 t)))])) + + (define Lcommonize1-lambda? + (lambda (e) + (nanopass-case (Lcommonize1 Expr) e + [(case-lambda ,preinfo ,cl* ...) #t] + [else #f]))) + + (define-pass cpcommonize0 : Lsrc (ir) -> Lcommonize1 () + (Expr : Expr (ir) -> Expr (1) + [(set! ,maybe-src ,x ,[e size]) + (values `(set! ,maybe-src ,x ,e) (fx+ 1 size))] + [(seq ,[e1 size1] ,[e2 size2]) + (values `(seq ,e1 ,e2) (fx+ size1 size2))] + [(if ,[e1 size1] ,[e2 size2] ,[e3 size3]) + (values `(if ,e1 ,e2 ,e3) (fx+ size1 size2 size3))] + [(foreign ,conv ,name ,[e size] (,arg-type* ...) ,result-type) + (values `(foreign ,conv ,name ,e (,arg-type* ...) ,result-type) (fx+ 1 size))] + [(fcallable ,conv ,[e size] (,arg-type* ...) ,result-type) + (values `(fcallable ,conv ,e (,arg-type* ...) ,result-type) (fx+ 1 size))] + ; ($top-level-value 'x) adds just 1 to the size + [(call ,preinfo ,pr (quote ,d)) + (guard (eq? (primref-name pr) '$top-level-value)) + (values `(call ,preinfo ,pr (quote ,d)) 1)] + ; (let ([x* e*] ...) body) splits into letrec binding unassigned variables to lambdas plus a let for the remaining bindings + [(call ,preinfo1 (case-lambda ,preinfo2 (clause (,x* ...) ,interface ,[body size])) ,[e* -> e* size*] ...) + (guard (fx= (length e*) interface)) + (define-record-type fudge (nongenerative) (sealed #t) (fields x e size)) + (let-values ([(lb* ob*) (partition + (lambda (b) + (and (not (prelex-assigned (fudge-x b))) + (Lcommonize1-lambda? (fudge-e b)))) + (map make-fudge x* e* size*))]) + (values + (let ([body (if (null? ob*) + body + `(call ,preinfo1 + (case-lambda ,preinfo2 + (clause (,(map fudge-x ob*) ...) ,(length ob*) ,body)) + ,(map fudge-e ob*) ...))]) + (if (null? lb*) + body + `(letrec ([,(map fudge-x lb*) ,(map fudge-e lb*) ,(map fudge-size lb*)] ...) ,body))) + (apply fx+ size size*)))] + [(call ,preinfo ,[e size] ,[e* size*] ...) + (values `(call ,preinfo ,e ,e* ...) (apply fx+ size size*))] + [(case-lambda ,preinfo (clause (,x** ...) ,interface* ,[body* size*]) ...) + (values `(case-lambda ,preinfo (clause (,x** ...) ,interface* ,body*) ...) (apply fx+ 1 size*))] + [(letrec ([,x* ,[e* size*]] ...) ,[body size]) + (values `(letrec ([,x* ,e* ,size*] ...) ,body) (apply fx+ size size*))] + [(record-ref ,rtd ,type ,index ,[e size]) + (values `(record-ref ,rtd ,type ,index ,e) (fx+ size 1))] + [(record-set! ,rtd ,type ,index ,[e1 size1] ,[e2 size2]) + (values `(record-set! ,rtd ,type ,index ,e1 ,e2) (fx+ size1 size2 1))] + [(record ,rtd ,[rtd-expr size] ,[e* size*] ...) + (values `(record ,rtd ,rtd-expr ,e* ...) (apply fx+ size size*))] + [(cte-optimization-loc ,box ,[e size]) + (values `(cte-optimization-loc ,box ,e) size)] + [(immutable-list (,[e* size*] ...) ,[e size]) + (values `(immutable-list (,e* ...) ,e) (apply fx+ size size*))] + [(quote ,d) (values `(quote ,d) 1)] + [(ref ,maybe-src ,x) (values `(ref ,maybe-src ,x) 1)] + [,pr (values pr 1)] + [(moi) (values `(moi) 1)] + [(pariah) (values `(pariah) 0)] + [(profile ,src) (values `(profile ,src) 0)] + [else (sorry! who "unhandled record ~s" ir)]) + (let-values ([(e size) (Expr ir)]) e)) + + (define-pass cpcommonize1 : Lcommonize1 (ir worthwhile-size) -> Lcommonize2 () + (definitions + (define worthwhile-size? + (lambda (expr-size) + (fx>= expr-size worthwhile-size))) + (define worthwhile-ratio? + (lambda (expr-size subst-count) + (or (fx= subst-count 0) + (fx>= (div expr-size subst-count) 4)))) + (define-record-type subst + (nongenerative) + (sealed #t) + (fields t e1 e2)) + (define-record-type frob + (nongenerative) + (sealed #t) + (fields subst* e b)) + (define ht (make-hashtable values fx=)) + (define make-sym + (lambda x* + (string->symbol (apply string-append (map (lambda (x) (if (prelex? x) (symbol->string (prelex-name x)) x)) x*))))) + (define same-preinfo? + (lambda (p1 p2) + ; ignore differences in src and sexpr + #t)) + (define same-preinfo-lambda? + (lambda (p1 p2) + ; ignore differences src, sexpr, and name + (eq? (preinfo-lambda-libspec p1) (preinfo-lambda-libspec p2)))) + (define-who same-type? + (lambda (ty1 ty2) + (nanopass-case (Ltype Type) ty1 + [(fp-integer ,bits1) + (nanopass-case (Ltype Type) ty2 + [(fp-integer ,bits2) (= bits1 bits2)] + [else #f])] + [(fp-unsigned ,bits1) + (nanopass-case (Ltype Type) ty2 + [(fp-unsigned ,bits2) (= bits1 bits2)] + [else #f])] + [(fp-void) + (nanopass-case (Ltype Type) ty2 + [(fp-void) #t] + [else #f])] + [(fp-scheme-object) + (nanopass-case (Ltype Type) ty2 + [(fp-scheme-object) #t] + [else #f])] + [(fp-u8*) + (nanopass-case (Ltype Type) ty2 + [(fp-u8*) #t] + [else #f])] + [(fp-u16*) + (nanopass-case (Ltype Type) ty2 + [(fp-u16*) #t] + [else #f])] + [(fp-u32*) + (nanopass-case (Ltype Type) ty2 + [(fp-u32*) #t] + [else #f])] + [(fp-fixnum) + (nanopass-case (Ltype Type) ty2 + [(fp-fixnum) #t] + [else #f])] + [(fp-double-float) + (nanopass-case (Ltype Type) ty2 + [(fp-double-float) #t] + [else #f])] + [(fp-single-float) + (nanopass-case (Ltype Type) ty2 + [(fp-single-float) #t] + [else #f])] + [(fp-ftd ,ftd1) + (nanopass-case (Ltype Type) ty2 + [(fp-ftd ,ftd2) (eq? ftd1 ftd2)] + [else #f])] + [else (sorry! who "unhandled foreign type ~s" ty1)]))) + (define okay-to-subst? + (lambda (e) + (define free? + (lambda (x) + (and (not (prelex-operand x)) #t))) + (nanopass-case (Lcommonize1 Expr) e + [(ref ,maybe-src1 ,x1) (and (not (prelex-assigned x1)) (free? x1))] + [(quote ,d) #t] + [,pr (all-set? (prim-mask proc) (primref-flags pr))] + [else #f]))) + (define constant-equal? + (lambda (x y) + (define record-equal? + (lambda (x y e?) + (let ([rtd ($record-type-descriptor x)]) + (and (eq? ($record-type-descriptor y) rtd) + (let f ([field-name* (csv7:record-type-field-names rtd)] [i 0]) + (or (null? field-name*) + (and (let ([accessor (csv7:record-field-accessor rtd i)]) + (e? (accessor x) (accessor y))) + (f (cdr field-name*) (fx+ i 1))))))))) + (parameterize ([default-record-equal-procedure record-equal?]) + ; equal? should be okay since even mutable constants aren't supposed to be mutated + (equal? x y)))) + (define same? + (lambda (e1 e2) + (nanopass-case (Lcommonize1 Expr) e1 + [(ref ,maybe-src1 ,x1) + (nanopass-case (Lcommonize1 Expr) e2 + [(ref ,maybe-src2 ,x2) + (or (eq? x1 x2) + (eq? (prelex-operand x1) x2))] + [else #f])] + [(quote ,d1) + (nanopass-case (Lcommonize1 Expr) e2 + [(quote ,d2) (constant-equal? d1 d2)] + [else #f])] + [,pr1 + (nanopass-case (Lcommonize1 Expr) e2 + [,pr2 (eq? pr1 pr2)] + [else #f])] + [(moi) + (nanopass-case (Lcommonize1 Expr) e2 + [(moi) #t] + [else #f])] + [(pariah) + (nanopass-case (Lcommonize1 Expr) e2 + [(pariah) #t] + [else #f])] + [(profile ,src1) + (nanopass-case (Lcommonize1 Expr) e2 + [(profile ,src2) (eq? src1 src2)] + [else #f])] + [(call ,preinfo1 ,pr1 (quote ,d1)) + (guard (eq? (primref-name pr1) '$top-level-value)) + (nanopass-case (Lcommonize1 Expr) e2 + [(call ,preinfo2 ,pr2 (quote ,d2)) + (guard (eq? (primref-name pr2) '$top-level-value)) + (and (same-preinfo? preinfo1 preinfo2) (eq? d1 d2))] + [else #f])] + [else #f]))) + (define-who unify + (lambda (e1 e2) + (module (with-env) + (define $with-env + (lambda (x1* x2* th) + (dynamic-wind + (lambda () (map (lambda (x1 x2) (prelex-operand-set! x1 x2) (prelex-operand-set! x2 #t)) x1* x2*)) + th + (lambda () (map (lambda (x1 x2) (prelex-operand-set! x1 #f) (prelex-operand-set! x2 #f)) x1* x2*))))) + (define-syntax with-env + (syntax-rules () + [(_ x1* x2* e) ($with-env x1* x2* (lambda () e))]))) + (call/cc + (lambda (return) + (let ([subst* '()]) + (define lookup-subst + (lambda (e1 e2) + (define same-subst? + (lambda (x) + (and (same? (subst-e1 x) e1) (same? (subst-e2 x) e2)))) + (cond + [(find same-subst? subst*) => + (lambda (subst) + (let ([t (subst-t subst)]) + (set-prelex-multiply-referenced! t #t) + t))] + [else #f]))) + (let ([e (with-output-language (Lcommonize1 Expr) + (let () + (define fclause + (lambda (cl1 cl2) + (nanopass-case (Lcommonize1 CaseLambdaClause) cl1 + [(clause (,x1* ...) ,interface1 ,body1) + (nanopass-case (Lcommonize1 CaseLambdaClause) cl2 + [(clause (,x2* ...) ,interface2 ,body2) + (if (fx= interface1 interface2) + (with-env x1* x2* + (with-output-language (Lcommonize1 CaseLambdaClause) + `(clause (,x1* ...) ,interface1 ,(f body1 body2)))) + (return (iffalse #f (printf "lambda interfaces don't match\n")) '()))])]))) + (define f + (case-lambda + [(e1 e2) (f e1 e2 #f)] + [(e1 e2 call-position?) + (or (cond + [(same? e1 e2) e1] + [(and (not call-position?) (okay-to-subst? e1) (okay-to-subst? e2)) + `(ref #f ,(or (lookup-subst e1 e2) + (let ([t (make-prelex*)]) + (set-prelex-referenced! t #t) + (set! subst* (cons (make-subst t e1 e2) subst*)) + t)))] + [else + (nanopass-case (Lcommonize1 Expr) e1 + [(ref ,maybe-src1 ,x1) #f] + [(quote ,d) #f] + [,pr #f] + [(moi) #f] + [(profile ,src1) #f] + ; reject non-same top-level-value calls with constant symbol so they + ; don't end up being abstracted over the symbol in the residual code + [(call ,preinfo ,pr (quote ,d)) + (guard (eq? (primref-name pr) '$top-level-value)) + #f] + ; don't allow abstraction of first (type) argument to $object-ref, foreign-ref, etc., + ; since they can't be inlined without a constant type. + ; ditto for $tc-field's first (field) argument. + ; there are many other primitives we don't catch here for which the compiler generates + ; more efficient code when certain arguments are constant. + [(call ,preinfo1 ,pr1 (quote ,d1) ,e1* ...) + (guard (memq (primref-name pr1) '($object-ref $swap-object-ref $object-set foreign-ref foreign-set! $tc-field))) + (nanopass-case (Lcommonize1 Expr) e2 + [(call ,preinfo2 ,pr2 (quote ,d2) ,e2* ...) + (guard (eq? pr2 pr1) (eq? d1 d2)) + (and (same-preinfo? preinfo1 preinfo2) + (fx= (length e1*) (length e2*)) + `(call ,preinfo1 ,pr1 (quote ,d1) ,(map f e1* e2*) ...))] + [else #f])] + [(call ,preinfo1 ,e1 ,e1* ...) + (nanopass-case (Lcommonize1 Expr) e2 + [(call ,preinfo2 ,e2 ,e2* ...) + (and (fx= (length e1*) (length e2*)) + (same-preinfo? preinfo1 preinfo2) + `(call ,preinfo1 ,(f e1 e2 #t) ,(map f e1* e2*) ...))] + [else #f])] + [(if ,e10 ,e11 ,e12) + (nanopass-case (Lcommonize1 Expr) e2 + [(if ,e20 ,e21 ,e22) + `(if ,(f e10 e20) ,(f e11 e21) ,(f e12 e22))] + [else #f])] + [(case-lambda ,preinfo1 ,cl1* ...) + (nanopass-case (Lcommonize1 Expr) e2 + [(case-lambda ,preinfo2 ,cl2* ...) + (and (fx= (length cl1*) (length cl2*)) + (same-preinfo-lambda? preinfo1 preinfo2) + `(case-lambda ,preinfo1 ,(map fclause cl1* cl2*) ...))] + [else #f])] + [(seq ,e11 ,e12) + (nanopass-case (Lcommonize1 Expr) e2 + [(seq ,e21 ,e22) `(seq ,(f e11 e21) ,(f e12 e22))] + [else #f])] + [(set! ,maybe-src1 ,x1 ,e1) + (nanopass-case (Lcommonize1 Expr) e2 + [(set! ,maybe-src2 ,x2 ,e2) + (and (eq? x1 x2) + `(set! ,maybe-src1 ,x1 ,(f e1 e2)))] + [else #f])] + [(letrec ([,x1* ,e1* ,size1*] ...) ,body1) + (nanopass-case (Lcommonize1 Expr) e2 + [(letrec ([,x2* ,e2* ,size2*] ...) ,body2) + (and (fx= (length x2*) (length x1*)) + (andmap fx= size1* size2*) + (with-env x1* x2* + `(letrec ([,x1* ,(map f e1* e2*) ,size1*] ...) ,(f body1 body2))))] + [else #f])] + [(foreign ,conv1 ,name1 ,e1 (,arg-type1* ...) ,result-type1) + (nanopass-case (Lcommonize1 Expr) e2 + [(foreign ,conv2 ,name2 ,e2 (,arg-type2* ...) ,result-type2) + (and (eq? conv1 conv2) + (equal? name1 name2) + (fx= (length arg-type1*) (length arg-type2*)) + (andmap same-type? arg-type1* arg-type2*) + (same-type? result-type1 result-type2) + `(foreign ,conv1 ,name1 ,(f e1 e2) (,arg-type1* ...) ,result-type1))] + [else #f])] + [(fcallable ,conv1 ,e1 (,arg-type1* ...) ,result-type1) + (nanopass-case (Lcommonize1 Expr) e2 + [(fcallable ,conv2 ,e2 (,arg-type2* ...) ,result-type2) + (and (eq? conv1 conv2) + (fx= (length arg-type1*) (length arg-type2*)) + (andmap same-type? arg-type1* arg-type2*) + (same-type? result-type1 result-type2) + `(fcallable ,conv1 ,(f e1 e2) (,arg-type1* ...) ,result-type1))] + [else #f])] + [(cte-optimization-loc ,box1 ,e1) + (nanopass-case (Lcommonize1 Expr) e2 + [(cte-optimization-loc ,box2 ,e2) + (and (eq? box1 box2) + `(cte-optimization-loc ,box1 ,(f e1 e2)))] + [else #f])] + [else (sorry! who "unhandled record ~s" e1)])]) + (return (iffalse #f (parameterize ([print-level 3] [print-length 5]) (printf "unify failed for ~s and ~s (call-position ~s)\n" e1 e2 call-position?))) '()))])) + (f e1 e2)))]) + (values e subst*))))))) + (define sort-substs + ; reestablish original argument order for substituted variables where possible + ; so the arguments to an abstracted procedure aren't shuffled around in the + ; call to the generated helper. + (lambda (subst0* x1* x2*) + (define (this? x x*) (and (not (null? x*)) (eq? x (car x*)))) + (define (next x*) (if (null? x*) x* (cdr x*))) + (let-values ([(new-subst* subst*) (let f ([x1* x1*] [x2* x2*] [subst* subst0*] [n (length subst0*)]) + (cond + [(fx= n 0) (values '() subst*)] + [(find (lambda (subst) + (define (is-this-arg? e x*) + (nanopass-case (Lcommonize1 Expr) e + [(ref ,maybe-src ,x) (this? x x*)] + [else #f])) + (or (is-this-arg? (subst-e1 subst) x1*) + (is-this-arg? (subst-e2 subst) x2*))) + subst*) => + (lambda (subst) + (let-values ([(new-subst* subst*) (f (next x1*) (next x2*) (remq subst subst*) (fx- n 1))]) + (values (cons subst new-subst*) subst*)))] + [else + (let-values ([(new-subst* subst*) (f (next x1*) (next x2*) subst* (fx- n 1))]) + (values (cons (car subst*) new-subst*) (cdr subst*)))]))]) + (safe-assert (null? subst*)) + (safe-assert (fx= (length new-subst*) (length subst0*))) + new-subst*))) + (define find-match + (lambda (b1 ht) + (and (iffalse (worthwhile-size? (binding-size b1)) (printf "skipping b1: under worthwhile size ~s ~s\n" (binding-size b1) worthwhile-size)) + (ormap (lambda (b2) + (iffalse #f (printf "checking ~s & ~s:" (prelex-name (binding-x b1)) (prelex-name (binding-x b2)))) + (nanopass-case (Lcommonize1 Expr) (binding-e b1) + ; NB: restricting to one clause for now...handling multiple + ; NB: clauses should be straightforward with a helper per + ; NB: common clause. + [(case-lambda ,preinfo1 (clause (,x1* ...) ,interface1 ,body1)) + ; NB: no rest interface for now. should be straightforward + (guard (fxnonnegative? interface1)) + (and + (nanopass-case (Lcommonize1 Expr) (binding-e b2) + [(case-lambda ,preinfo2 (clause (,x2* ...) ,interface2 ,body2)) + (guard (fxnonnegative? interface2)) + (let-values ([(e subst*) (unify body1 body2)]) + (and e + (iffalse (worthwhile-ratio? (binding-size b1) (length subst*)) (printf " no, not worthwhile ratio ~s ~s\n" (binding-size b1) (length subst*))) + (let ([subst* (sort-substs subst* x1* x2*)]) + (iffalse #f (printf " yes\n")) + (make-frob subst* e b2))))] + [else (iffalse #f (printf " no, b2 does not meet lambda restrictions\n"))]))] + [else (iffalse #f (printf " no, b1 does not meet lambda restrictions\n"))])) + (hashtable-ref ht (binding-size b1) '()))))) + (define record-helper! + (lambda (b next e*) + (binding-helper-b-set! b next) + (binding-helper-arg*-set! b e*))) + (define build-helper + (lambda (t t* body size helper-box) + (make-binding t + (with-output-language (Lcommonize1 Expr) + `(case-lambda ,(make-preinfo-lambda) (clause (,t* ...) ,(length t*) ,body))) + size + helper-box))) + (define commonize-letrec + (lambda (x* e* size* body) ; e* and body have not been processed + (define (prune-and-process! b) + (let ([b* (remq b (hashtable-ref ht (binding-size b) '()))]) + (if (null? b*) + (hashtable-delete! ht (binding-size b)) + (hashtable-set! ht (binding-size b) b*))) + (unless (binding-helper-b b) (binding-e-set! b (Expr (binding-e b))))) + (if (null? x*) + body + (let ([helper-box (box '())]) + (let ([b* (map (lambda (x e size) (make-binding x e size helper-box)) x* e* size*)]) + (let ([body (let f ([b* b*]) + (if (null? b*) + (Expr body) + (let ([b (car b*)]) + (let ([frob (find-match b ht)]) + (if frob + (let* ([outer-b (frob-b frob)] + [helper-box (binding-helper-box outer-b)] + [helper-b (let ([t (make-prelex* (make-sym (binding-x b) "&" (binding-x outer-b)))]) + (build-helper t (map subst-t (frob-subst* frob)) (frob-e frob) (binding-size outer-b) helper-box))]) + (set-box! helper-box (cons helper-b (unbox helper-box))) + (record-helper! b helper-b (map subst-e1 (frob-subst* frob))) + (record-helper! outer-b helper-b (map subst-e2 (frob-subst* frob))) + (hashtable-update! ht (binding-size outer-b) (lambda (b*) (cons helper-b (remq outer-b b*))) '()) + (f (cdr b*))) + (begin + (hashtable-update! ht (binding-size b) (lambda (b*) (cons b b*)) '()) + (let ([body (f (cdr b*))]) + (prune-and-process! b) + body)))))))]) + (let ([helper-b* (unbox helper-box)]) + (for-each prune-and-process! helper-b*) + (with-output-language (Lcommonize2 Expr) + `(letrec (,helper-b* ...) (,b* ...) ,body)))))))))) + (Expr : Expr (ir) -> Expr () + [(letrec ([,x* ,e* ,size*] ...) ,body) + ; only unassigned lambda bindings post-cpletrec + (safe-assert (andmap (lambda (x) (not (prelex-assigned x))) x*)) + (safe-assert (andmap (lambda (e) (Lcommonize1-lambda? e)) e*)) + (commonize-letrec x* e* size* body)] + [(letrec* ([,x* ,e*] ...) ,body) + ; no letrec* run post-cpletrec + (assert #f)])) + + (define-pass cpcommonize2 : Lcommonize2 (ir) -> Lsrc () + (definitions + (define build-caller + (lambda (e helper-b helper-arg*) + (define-who Arg + (lambda (e) + (with-output-language (Lsrc Expr) + (nanopass-case (Lcommonize1 Expr) e + [(ref ,maybe-src ,x) `(ref ,maybe-src ,x)] + [(quote ,d) `(quote ,d)] + [else (sorry! who "unexpected helper arg ~s" e)])))) + (define propagate + (lambda (alist) + (lambda (e) + (nanopass-case (Lsrc Expr) e + [(ref ,maybe-src ,x) + (cond + [(assq x alist) => cdr] + [else e])] + [else e])))) + (nanopass-case (Lcommonize1 Expr) e + [(case-lambda ,preinfo (clause (,x* ...) ,interface ,body)) + (with-output-language (Lsrc Expr) + `(case-lambda ,preinfo + (clause (,x* ...) ,interface + ,(let loop ([helper-b helper-b] [e* (map Arg helper-arg*)]) + (if (binding-helper-b helper-b) + (nanopass-case (Lcommonize1 Expr) (binding-e helper-b) + [(case-lambda ,preinfo (clause (,x* ...) ,interface ,body)) + (loop (binding-helper-b helper-b) (map (propagate (map cons x* e*)) (map Arg (binding-helper-arg* helper-b))))]) + `(call ,(make-preinfo) + ,(let ([t (binding-x helper-b)]) + (if (prelex-referenced t) + (set-prelex-multiply-referenced! t #t) + (set-prelex-referenced! t #t)) + `(ref #f ,t)) + ,e* ...))))))]))) + (define maybe-build-caller + (lambda (b) + (let ([helper-b (binding-helper-b b)] [e (binding-e b)]) + (if helper-b + (build-caller e helper-b (binding-helper-arg* b)) + (Expr e)))))) + (Expr : Expr (ir) -> Expr () + [(letrec (,helper-b* ...) (,b* ...) ,[body]) + (let loop ([rb* (reverse helper-b*)] [x* (map binding-x b*)] [e* (map maybe-build-caller b*)]) + (if (null? rb*) + `(letrec ([,x* ,e*] ...) ,body) + (let ([b (car rb*)] [rb* (cdr rb*)]) + (if (prelex-referenced (binding-x b)) + (loop rb* (cons (binding-x b) x*) (cons (maybe-build-caller b) e*)) + (loop rb* x* e*)))))])) + + (lambda (x) + (let ([level (commonization-level)]) + (if (fx= level 0) + x + (let ([worthwhile-size (expt 2 (fx- 10 level))]) + (cpcommonize2 (cpcommonize1 (cpcommonize0 x) worthwhile-size)))))))) From 34b328092d3870a19cab6d6bcdce0a75021705fd Mon Sep 17 00:00:00 2001 From: dybvig Date: Thu, 1 Feb 2018 00:13:58 -0500 Subject: [PATCH 04/21] Added some adapted charter and contributing text to the user's giude preface and intro. Added Matthew Flatt to the acknowledgements. original commit: 332e015dc2cd96160c468278def7d3b2cf8a1131 --- csug/intro.stex | 11 +++---- csug/preface.stex | 78 ++++++++++++++++++++++++++++++++--------------- 2 files changed, 57 insertions(+), 32 deletions(-) diff --git a/csug/intro.stex b/csug/intro.stex index cc37520ee3..a40bc50e3b 100644 --- a/csug/intro.stex +++ b/csug/intro.stex @@ -13,15 +13,12 @@ % limitations under the License. \chapter{Introduction} -{\ChezScheme} is an implementation of the Revised$^6$ Report on -Scheme~\cite{r6rs} (R6RS) with numerous language and programming environment -extensions. - -This book describes these extensions in detail. +This book describes {\ChezScheme} extensions to the Revised$^6$ +Report on Scheme~\cite{r6rs} (R6RS). It contains as well a concise summary of standard and {\ChezScheme} forms and procedures, which gives the syntax of each form and the number and types of arguments accepted by each procedure. -Details on standard Scheme features can be found in +Details on standard R6RS features can be found in \index{The Scheme Programming Language, 4th Edition@\emph{The Scheme Programming Language, 4th Edition}}\hyperlink{http://www.scheme.com/tspl4/}{\emph{The Scheme Programming Language, 4th Edition}} (TSPL4)~\cite{Dybvig:tspl4} or the Revised$^6$ Report on Scheme. @@ -96,7 +93,7 @@ Online versions and errata for this book and for TSPL4 can be found at \bigskip\noindent \emph{Acknowledgments:} Michael Adams, Mike Ashley, Carl Bruggeman, Bob Burger, Sam -Daniel, George Davidson, Aziz Ghuloum, Bob Hieb, Andy Keep, and Oscar Waddell have +Daniel, George Davidson, Matthew Flatt, Aziz Ghuloum, Bob Hieb, Andy Keep, and Oscar Waddell have contributed substantially to the development of {\ChezScheme}. {\ChezScheme}'s expression editor is based on a command-line editor for Scheme developed from 1989 through 1994 by C.~David Boyer. diff --git a/csug/preface.stex b/csug/preface.stex index 8aa7892be6..135ccf5581 100644 --- a/csug/preface.stex +++ b/csug/preface.stex @@ -13,33 +13,26 @@ % limitations under the License. \chapter{Preface} -{\ChezScheme} Version~9 is a complete implementation of the language of -the Revised$^6$ Report on Scheme (R6RS), with numerous extensions. -The implementation is extensively tested and actively maintained and supported. -It includes a fast compiler that generates efficient native code for each -processor upon which it runs along with a run-time system that provides -automatic storage management, foreign language interfaces, and an +{\ChezScheme} is both a general-purpose programming language and +an implementation of that language, with supporting tools and +documentation. +As a superset of the language described in the Revised$^6$ Report +on Scheme (R6RS), {\ChezScheme} supports all standard features of +Scheme, including first-class procedures, proper treatment of tail +calls, continuations, user-defined records, libraries, exceptions, +and hygienic macro expansion. +{\ChezScheme} supports numerous non-R6RS features. +A few of these are local and top-level modules, +local import, foreign datatypes and procedures, nonblocking I/O, +an interactive top-level, compile-time values and properties, +pretty-printing, and formatted output. + +The implementation includes a compiler that generates native code +for each processor upon which it runs along with a run-time system +that provides automatic storage management, foreign-language +interfaces, source-level debugging, profiling support, and an extensive run-time library. -The compiler has been rewritten for Version~9 and generates -substantially faster code than the earlier compiler at the cost of -additional compile time. -This is the primary difference between Versions~8 and~9. - -This book is a companion to \emph{The Scheme Programming Language, 4th -Edition} (TSPL4). -While TSPL4 describes only standard R6RS features, this book describes -{\ChezScheme} extensions. -For the reader's convenience, the summary of forms and index at the back -of this book contain entries from both books, with each entry from TSPL4 -marked with a ``t'' in front of its page number. -In the online version, the page numbers given in the summary of forms and -index double as direct links into one of the documents or the other. - -Additional documentation for {\ChezScheme} includes release notes, a -manual page, and a number of published papers and articles that describe -various aspects of the system's design and implementation. - The threaded versions of {\ChezScheme} support native threads, allowing Scheme programs to take advantage of multiprocessor or multiple-core systems. @@ -55,4 +48,39 @@ mechanism, and command completion. Unlike most shells that support command-line editing, the expression editor properly supports multiline expressions. +{\ChezScheme} is intended to be as reliable and efficient as possible, +with reliability taking precedence over efficiency if necessary. +Reliability means behaving as designed and documented. +While a {\ChezScheme} program can always fail to work properly +because of a bug in the program, it should never fail because of a +bug in the {\ChezScheme} implementation. +Efficiency means performing at a high level, consuming minimal CPU +time and memory. +Performance should be balanced across features, across run time and +compile time, and across programs and data of different sizes. +These principles guide {\ChezScheme} language and tool design as +well as choice of implementation technique; for example, a language +feature or debugging hook might not exist in {\ChezScheme} because +its presence would reduce reliability, efficiency, or both. + +The compiler has been rewritten for Version~9 and generates +substantially faster code than the earlier compiler at the cost of +greater compile time. +This is the primary difference between Versions~8 and~9. + +This book (CSUG) is a companion to \emph{The Scheme Programming +Language, 4th Edition} (TSPL4). +TSPL4 serves as an introduction to and reference for R6RS, while +CSUG describes {\ChezScheme} features and tools that are not part +of R6RS. +For the reader's convenience, the summary of forms and index at the back +of this book contain entries from both books, with each entry from TSPL4 +marked with a ``t'' in front of its page number. +In the online version, the page numbers given in the summary of forms and +index double as direct links into one of the documents or the other. + +Additional documentation for {\ChezScheme} includes release notes, a +manual page, and a number of published papers and articles that describe +various aspects of the system's design and implementation. + Thank you for using {\ChezScheme}. From af60b1c8dfff6f22400cbeb6fc704f602212f570 Mon Sep 17 00:00:00 2001 From: dybvig Date: Thu, 1 Feb 2018 00:38:14 -0500 Subject: [PATCH 05/21] updaed release-notes date original commit: 1e010f5632306305cf1bd44d86c9c51b33a2e7a1 --- release_notes/release_notes.stex | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/release_notes/release_notes.stex b/release_notes/release_notes.stex index ecc4ae8c98..6e063883b9 100644 --- a/release_notes/release_notes.stex +++ b/release_notes/release_notes.stex @@ -2,8 +2,8 @@ \thisversion{Version 9.5.1} \thatversion{Version 8.4} -\pubmonth{October} -\pubyear{2017} +\pubmonth{January} +\pubyear{2018} \begin{document} From 4991067ed7b901ec23fa1b3d0d09777eaa554f49 Mon Sep 17 00:00:00 2001 From: Gustavo Massaccesi Date: Fri, 9 Feb 2018 10:21:00 -0300 Subject: [PATCH 06/21] Remove special case for (#2%map p '()) in cp0 So the reduced version checks that p is a procedure Also make the same change for #2%for-each. cp0.ss, 4.ms original commit: 5caa11c85bc74c0af25ac215d48b7f5f0c1d3e42 --- LOG | 4 ++++ mats/4.ms | 41 +++++++++++++++++++++++++++++++++++++++++ s/cp0.ss | 25 ++++++++++--------------- 3 files changed, 55 insertions(+), 15 deletions(-) diff --git a/LOG b/LOG index 8f01a213c5..f361b3eb9b 100644 --- a/LOG +++ b/LOG @@ -879,3 +879,7 @@ $verify-ftype-address if the address expression is a call to ftype-pointer-address. ftype.ss +- Remove special case for (#2%map p '()) in cp0 + so the reduced version checks that p is a procedure. + Also make the same change for #2%for-each. + cp0.ss, 4.ms diff --git a/mats/4.ms b/mats/4.ms index cda433d6d8..3177b42044 100644 --- a/mats/4.ms +++ b/mats/4.ms @@ -1079,6 +1079,10 @@ ((1 f k p u a) (2 g l q v b) (3 h m r w c) (4 i n s x d) (5 j o t y e)))) ; make sure compiler doesn't bomb w/two few args (procedure? (lambda (x) (map x))) + (error? ; nonprocedure + (map 3 '())) + (error? ; nonprocedure + (map 3 '() '())) (error? ; nonprocedure (map 3 '(a b c))) (error? ; nonprocedure @@ -1420,6 +1424,10 @@ 21) (procedure? (lambda (x) (fold-left x))) (procedure? (lambda (x) (fold-left x y))) + (error? ; nonprocedure + (for-left 3 0 '())) + (error? ; nonprocedure + (for-left 3 0 '() '())) (error? ; nonprocedure (fold-left 3 0 '(a b c))) (error? ; improper list @@ -1544,6 +1552,10 @@ ; make sure compiler doesn't bomb w/two few args (procedure? (lambda (x) (fold-right x))) (procedure? (lambda (x) (fold-right x y))) + (error? ; nonprocedure + (for-right 3 0 '())) + (error? ; nonprocedure + (for-right 3 0 '() '())) (error? ; nonprocedure (fold-right 3 0 '(a b c))) (error? ; improper list @@ -1722,11 +1734,24 @@ ; make sure compiler doesn't bomb w/two few args (procedure? (lambda (x) (for-each x))) + (error? ; nonprocedure + (for-each 3 '())) + (error? ; nonprocedure + (for-each 3 '() '())) (error? ; nonprocedure (for-each 3 '(a b c))) (error? ; nonprocedure (parameterize ([optimize-level 3]) (eval '(#2%for-each 3 '(a b c))))) + (error? ; nonprocedure + (parameterize ([optimize-level 3]) + (eval + '(let () + (define (f p b) + (unbox b) + (#2%for-each p (if (box? b) '() '(1 2 3))) + (list p (procedure? p))) + (f 7 (box 0)))))) (error? ; improper list (for-each pretty-print 'a)) (error? ; improper list @@ -2232,6 +2257,10 @@ (not (ormap (lambda (x y z) #t) '() '() '())) ; make sure compiler doesn't bomb w/two few args (procedure? (lambda (x) (ormap x))) + (error? ; nonprocedure + (ormap 3 '())) + (error? ; nonprocedure + (ormap 3 '() '())) (error? ; nonprocedure (ormap 3 '(a b c))) (error? ; improper list @@ -2333,6 +2362,10 @@ (eq? (andmap (lambda (x y z) #t) '() '() '()) #t) ; make sure compiler doesn't bomb w/two few args (procedure? (lambda (x) (andmap x))) + (error? ; nonprocedure + (andmap 3 '())) + (error? ; nonprocedure + (andmap 3 '() '())) (error? ; nonprocedure (andmap 3 '(a b c))) (error? ; improper list @@ -2434,6 +2467,10 @@ (not (exists (lambda (x y z) #t) '() '() '())) ; make sure compiler doesn't bomb w/two few args (procedure? (lambda (x) (exists x))) + (error? ; nonprocedure + (exists 3 '())) + (error? ; nonprocedure + (exists 3 '() '())) (error? ; nonprocedure (exists 3 '(a b c))) (error? ; improper list @@ -2535,6 +2572,10 @@ (eq? (for-all (lambda (x y z) #t) '() '() '()) #t) ; make sure compiler doesn't bomb w/two few args (procedure? (lambda (x) (for-all x))) + (error? ; nonprocedure + (for-all 3 '())) + (error? ; nonprocedure + (for-all 3 '() '())) (error? ; nonprocedure (for-all 3 '(a b c))) (error? ; improper list diff --git a/s/cp0.ss b/s/cp0.ss index 95bf069107..c7b3acdfa9 100644 --- a/s/cp0.ss +++ b/s/cp0.ss @@ -3619,14 +3619,18 @@ (cons `(call ,preinfo (ref #f ,p) ,(map (lambda (t*) (build-ref (car t*))) t**) ...) (g (map cdr t**))))))]) - (if (and map? (not (eq? ctxt 'effect))) - (build-primcall lvl 'list results) - (make-seq* ctxt results))) + (if (and map? (not (eq? (app-ctxt ctxt) 'effect))) + (if (null? results) + null-rec + (build-primcall lvl 'list results)) + (if (null? results) + void-rec + (make-seq* (app-ctxt ctxt) results)))) (non-result-exp (value-visit-operand! (car ls*)) (build-let (car t**) (car e**) (f (cdr t**) (cdr e**) (cdr ls*))))))]) (if (fx= lvl 2) - (make-seq ctxt + (make-seq (app-ctxt ctxt) `(if ,(build-primcall 2 'procedure? (list `(ref #f ,p))) ,void-rec ,(build-primcall 3 '$oops (list `(quote ,(if map? 'map 'for-each)) @@ -3642,11 +3646,7 @@ [else #f]))))) (define-inline 2 map [(?p ?ls . ?ls*) - (if (andmap null-rec? (cons ?ls ?ls*)) - (begin - (residualize-seq '() (list* ?p ?ls ?ls*) ctxt) - null-rec) - (inline-lists ?p ?ls ?ls* 2 #t ctxt sc wd name moi))]) + (inline-lists ?p ?ls ?ls* 2 #t ctxt sc wd name moi)]) (define-inline 3 map [(?p ?ls . ?ls*) (cond @@ -3725,12 +3725,7 @@ (define-inline 2 for-each [(?p ?ls . ?ls*) - (cond - [(andmap null-rec? (cons ?ls ?ls*)) - (residualize-seq '() (list* ?p ?ls ?ls*) ctxt) - void-rec] - [else - (inline-lists ?p ?ls ?ls* 2 #f ctxt sc wd name moi)])]) + (inline-lists ?p ?ls ?ls* 2 #f ctxt sc wd name moi)]) (define-inline 3 for-each [(?p ?ls . ?ls*) (cond From 59c87c8e9f61ea4d42a3f2983084bbdf42e5154b Mon Sep 17 00:00:00 2001 From: dyb Date: Sun, 18 Feb 2018 20:41:15 -0500 Subject: [PATCH 07/21] minor corrections to 4.ms; updated root-experr-compile-{0,2}-f-f-f original commit: 86591f9dd45f36aa0e7d320d2286ffdb1b49076e --- mats/4.ms | 8 ++++---- mats/root-experr-compile-0-f-f-f | 17 +++++++++++++++++ mats/root-experr-compile-2-f-f-f | 20 ++++++++++++++++++++ 3 files changed, 41 insertions(+), 4 deletions(-) diff --git a/mats/4.ms b/mats/4.ms index 3177b42044..3d531e227f 100644 --- a/mats/4.ms +++ b/mats/4.ms @@ -1425,9 +1425,9 @@ (procedure? (lambda (x) (fold-left x))) (procedure? (lambda (x) (fold-left x y))) (error? ; nonprocedure - (for-left 3 0 '())) + (fold-left 3 0 '())) (error? ; nonprocedure - (for-left 3 0 '() '())) + (fold-left 3 0 '() '())) (error? ; nonprocedure (fold-left 3 0 '(a b c))) (error? ; improper list @@ -1553,9 +1553,9 @@ (procedure? (lambda (x) (fold-right x))) (procedure? (lambda (x) (fold-right x y))) (error? ; nonprocedure - (for-right 3 0 '())) + (fold-right 3 0 '())) (error? ; nonprocedure - (for-right 3 0 '() '())) + (fold-right 3 0 '() '())) (error? ; nonprocedure (fold-right 3 0 '(a b c))) (error? ; improper list diff --git a/mats/root-experr-compile-0-f-f-f b/mats/root-experr-compile-0-f-f-f index d39d411c69..472415f8e6 100644 --- a/mats/root-experr-compile-0-f-f-f +++ b/mats/root-experr-compile-0-f-f-f @@ -269,6 +269,8 @@ primvars.mo:Expected error in mat trace-output-port: "trace-output-port: # Date: Wed, 21 Feb 2018 11:40:08 -0500 Subject: [PATCH 08/21] fix ftype mats on Windows by unsetting the CL environment variable original commit: 829d7f52e7e35e2277c4c5037b9d70771df4541c --- mats/ftype.ms | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/mats/ftype.ms b/mats/ftype.ms index 3e147cd1cf..e5c6a9d3d6 100644 --- a/mats/ftype.ms +++ b/mats/ftype.ms @@ -557,9 +557,9 @@ [(a6osx a6osx) (system (format "cc -m64 -dynamiclib -o ~a ~a" testfile.so testfile.c))] [(a6nt ta6nt) - (system (format "..\\c\\vs.bat amd64 && cl /DWIN32 /Fe~a /LD /MD /nologo ~a" testfile.so testfile.c))] + (system (format "set cl= && ..\\c\\vs.bat amd64 && cl /DWIN32 /Fe~a /LD /MD /nologo ~a" testfile.so testfile.c))] [(i3nt ti3nt) - (system (format "..\\c\\vs.bat x86 && cl /DWIN32 /Fe~a /LD /MD /nologo ~a" testfile.so testfile.c))] + (system (format "set cl= && ..\\c\\vs.bat x86 && cl /DWIN32 /Fe~a /LD /MD /nologo ~a" testfile.so testfile.c))] [(arm32le tarm32le) (system (format "cc -fPIC -shared -o ~a ~a" testfile.so testfile.c))] [else ; this should work for most intel-based systems that use gcc... From 6b1259cfefaa7d6edcb08f374692531e450e4a73 Mon Sep 17 00:00:00 2001 From: Bob Burger Date: Wed, 21 Feb 2018 16:05:21 -0500 Subject: [PATCH 09/21] Mitigate a race condition in Windows when deleting files and directories. original commit: 1a13def8d6570babe378f4c63b5a488fac58ed3f --- LOG | 2 ++ c/windows.c | 16 ++++++++++++---- release_notes/release_notes.stex | 8 ++++++++ 3 files changed, 22 insertions(+), 4 deletions(-) diff --git a/LOG b/LOG index f361b3eb9b..ac6022ff0a 100644 --- a/LOG +++ b/LOG @@ -883,3 +883,5 @@ so the reduced version checks that p is a procedure. Also make the same change for #2%for-each. cp0.ss, 4.ms +- Mitigate a race condition in Windows when deleting files and directories. + windows.c diff --git a/c/windows.c b/c/windows.c index bf4da57253..42bea92de1 100644 --- a/c/windows.c +++ b/c/windows.c @@ -408,10 +408,14 @@ int S_windows_rename(const char *oldpathname, const char *newpathname) { int S_windows_rmdir(const char *pathname) { wchar_t wpathname[PATH_MAX]; + int rc; if (MultiByteToWideChar(CP_UTF8,0,pathname,-1,wpathname,PATH_MAX) == 0) - return _rmdir(pathname); + rc =_rmdir(pathname); else - return _wrmdir(wpathname); + rc = _wrmdir(wpathname); + if (0 == rc) + Sleep(0); // Give Windows time to delete the directory. + return rc; } int S_windows_stat64(const char *pathname, struct STATBUF *buffer) { @@ -432,10 +436,14 @@ int S_windows_system(const char *command) { int S_windows_unlink(const char *pathname) { wchar_t wpathname[PATH_MAX]; + int rc; if (MultiByteToWideChar(CP_UTF8,0,pathname,-1,wpathname,PATH_MAX) == 0) - return _unlink(pathname); + rc = _unlink(pathname); else - return _wunlink(wpathname); + rc = _wunlink(wpathname); + if (0 == rc) + Sleep(0); // Give Windows time to delete the file. + return rc; } char *S_windows_getcwd(char *buffer, int maxlen) { diff --git a/release_notes/release_notes.stex b/release_notes/release_notes.stex index 6e063883b9..1459130cfc 100644 --- a/release_notes/release_notes.stex +++ b/release_notes/release_notes.stex @@ -1542,6 +1542,14 @@ in fasl files does not generally make sense. %----------------------------------------------------------------------------- \section{Bug Fixes}\label{section:bugfixes} +\subsection{Permission denied after deleting files or directories in Windows} + +In Windows, deleting a file or directory briefly leaves the file or +directory in a state where a subsequent create operation fails with +permission denied. This race condition is now mitigated by a call to +Sleep. +[This bug applies to all versions up to 9.5 on Windows 7 and later.] + \subsection{Incorrect handling of offset in \protect\scheme{date->time-utc} on Windows (9.5)} From fb9d36e050aab36b93752e549ab8a6ddf745392a Mon Sep 17 00:00:00 2001 From: Bob Burger Date: Wed, 21 Feb 2018 16:39:26 -0500 Subject: [PATCH 10/21] Use spin loop instead of Sleep for more robust race condition mitigation original commit: fb9f854d449ee96cccb63a12629a729046f0bee1 --- c/windows.c | 40 +++++++++++++++++++++----------- release_notes/release_notes.stex | 3 +-- 2 files changed, 27 insertions(+), 16 deletions(-) diff --git a/c/windows.c b/c/windows.c index 42bea92de1..f8e31e0286 100644 --- a/c/windows.c +++ b/c/windows.c @@ -408,14 +408,20 @@ int S_windows_rename(const char *oldpathname, const char *newpathname) { int S_windows_rmdir(const char *pathname) { wchar_t wpathname[PATH_MAX]; - int rc; if (MultiByteToWideChar(CP_UTF8,0,pathname,-1,wpathname,PATH_MAX) == 0) - rc =_rmdir(pathname); - else - rc = _wrmdir(wpathname); - if (0 == rc) - Sleep(0); // Give Windows time to delete the directory. - return rc; + return _rmdir(pathname); + else { + int rc; + if (!(rc = _wrmdir(wpathname))) { + // Spin loop until Windows deletes the directory. + int n; + for (n = 100; n > 0; n--) { + if (_wrmdir(wpathname) && (errno == ENOENT)) break; + } + return 0; + } + return rc; + } } int S_windows_stat64(const char *pathname, struct STATBUF *buffer) { @@ -436,14 +442,20 @@ int S_windows_system(const char *command) { int S_windows_unlink(const char *pathname) { wchar_t wpathname[PATH_MAX]; - int rc; if (MultiByteToWideChar(CP_UTF8,0,pathname,-1,wpathname,PATH_MAX) == 0) - rc = _unlink(pathname); - else - rc = _wunlink(wpathname); - if (0 == rc) - Sleep(0); // Give Windows time to delete the file. - return rc; + return _unlink(pathname); + else { + int rc; + if (!(rc = _wunlink(wpathname))) { + // Spin loop until Windows deletes the file. + int n; + for (n = 100; n > 0; n--) { + if (_wunlink(wpathname) && (errno == ENOENT)) break; + } + return 0; + } + return rc; + } } char *S_windows_getcwd(char *buffer, int maxlen) { diff --git a/release_notes/release_notes.stex b/release_notes/release_notes.stex index 1459130cfc..8a5bb3fb5f 100644 --- a/release_notes/release_notes.stex +++ b/release_notes/release_notes.stex @@ -1546,8 +1546,7 @@ in fasl files does not generally make sense. In Windows, deleting a file or directory briefly leaves the file or directory in a state where a subsequent create operation fails with -permission denied. This race condition is now mitigated by a call to -Sleep. +permission denied. This race condition is now mitigated. [This bug applies to all versions up to 9.5 on Windows 7 and later.] \subsection{Incorrect handling of offset in From 743800bbb57abd83f6a445a9a8bd6b3bd9e0ef2c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 14 Nov 2017 09:46:03 -0700 Subject: [PATCH 11/21] support struct args to and results from foreign procedures original commit: f0a94bdb9f57c1bf7ffbb66693fb5476a6f0e65b --- LOG | 7 + c/externs.h | 15 +- c/prim.c | 13 +- c/scheme.c | 2 +- c/schlib.c | 80 +---- csug/foreign.stex | 30 +- mats/Mf-a6fb | 4 +- mats/Mf-a6le | 4 +- mats/Mf-a6nb | 4 +- mats/Mf-a6nt | 4 +- mats/Mf-a6ob | 4 +- mats/Mf-a6osx | 2 +- mats/Mf-a6s2 | 4 +- mats/Mf-arm32le | 4 +- mats/Mf-i3fb | 4 +- mats/Mf-i3le | 4 +- mats/Mf-i3nb | 4 +- mats/Mf-i3nt | 2 +- mats/Mf-i3ob | 4 +- mats/Mf-i3osx | 2 +- mats/Mf-i3qnx | 4 +- mats/Mf-i3s2 | 4 +- mats/Mf-ppc32le | 4 +- mats/Mf-ta6fb | 4 +- mats/Mf-ta6le | 4 +- mats/Mf-ta6nb | 4 +- mats/Mf-ta6nt | 2 +- mats/Mf-ta6ob | 4 +- mats/Mf-ta6osx | 2 +- mats/Mf-ta6s2 | 4 +- mats/Mf-ti3fb | 4 +- mats/Mf-ti3le | 4 +- mats/Mf-ti3nb | 4 +- mats/Mf-ti3nt | 2 +- mats/Mf-ti3ob | 4 +- mats/Mf-ti3osx | 2 +- mats/Mf-ti3s2 | 4 +- mats/Mf-tppc32le | 4 +- mats/foreign.ms | 281 +++++++++++++++- mats/foreign4.c | 288 +++++++++++++++++ release_notes/release_notes.stex | 12 + s/arm32.ss | 523 ++++++++++++++++++++++++++---- s/base-lang.ss | 5 +- s/cmacros.ss | 13 +- s/cpnanopass.ss | 134 +++++--- s/cprep.ss | 3 +- s/ftype.ss | 122 +++++-- s/np-languages.ss | 16 +- s/ppc32.ss | 484 ++++++++++++++++++++++------ s/primdata.ss | 6 + s/syntax.ss | 120 +++++-- s/x86.ss | 397 ++++++++++++++++++----- s/x86_64.ss | 535 +++++++++++++++++++++++++++---- 53 files changed, 2624 insertions(+), 576 deletions(-) create mode 100644 mats/foreign4.c diff --git a/LOG b/LOG index ac6022ff0a..89a15ea1a7 100644 --- a/LOG +++ b/LOG @@ -885,3 +885,10 @@ cp0.ss, 4.ms - Mitigate a race condition in Windows when deleting files and directories. windows.c +- add (& ftype) argument/result for foreign-procedure, which supports + struct arguments and results for foreign calls + syntax.ss, ftype.ss, cpnanopass.ss, x86.ss, x86_64.ss, + base-lang.ss, np-languages.ss, cprep.ss, primdata.ss, + schlib.c, prim.c, externs.h + mats/foreign4.c, mats/foreign.ms mats/Mf-* + foreign.stex, release_notes.stex diff --git a/c/externs.h b/c/externs.h index 45b8b02ad9..a5df075499 100644 --- a/c/externs.h +++ b/c/externs.h @@ -338,18 +338,9 @@ extern void S_machine_init PROTO((void)); extern void S_initframe PROTO((ptr tc, iptr n)); extern void S_put_arg PROTO((ptr tc, iptr i, ptr x)); extern void S_return PROTO((void)); -extern void S_call_help PROTO((ptr tc, IBOOL singlep)); -extern void S_call_void PROTO((void)); -extern ptr S_call_ptr PROTO((void)); -extern iptr S_call_fixnum PROTO((void)); -extern I32 S_call_int32 PROTO((void)); -extern U32 S_call_uns32 PROTO((void)); -extern double S_call_double PROTO((void)); -extern float S_call_single PROTO((void)); -extern U8 *S_call_bytevector PROTO((void)); -extern I64 S_call_int64 PROTO((void)); -extern U64 S_call_uns64 PROTO((void)); -extern uptr S_call_fptr PROTO((void)); +extern void S_call_help PROTO((ptr tc, IBOOL singlep, IBOOL lock_ts)); +extern void S_call_one_result PROTO((void)); +extern void S_call_any_results PROTO((void)); #ifdef WIN32 /* windows.c */ diff --git a/c/prim.c b/c/prim.c index 3b22818e71..0041012a81 100644 --- a/c/prim.c +++ b/c/prim.c @@ -134,17 +134,8 @@ static void create_c_entry_vector() { install_c_entry(CENTRY_scan_remembered_set, proc2ptr(S_scan_remembered_set)); install_c_entry(CENTRY_instantiate_code_object, proc2ptr(s_instantiate_code_object)); install_c_entry(CENTRY_Sreturn, proc2ptr(S_return)); - install_c_entry(CENTRY_Scall_ptr, proc2ptr(S_call_ptr)); - install_c_entry(CENTRY_Scall_fptr, proc2ptr(S_call_fptr)); - install_c_entry(CENTRY_Scall_bytevector, proc2ptr(S_call_bytevector)); - install_c_entry(CENTRY_Scall_fixnum, proc2ptr(S_call_fixnum)); - install_c_entry(CENTRY_Scall_int32, proc2ptr(S_call_int32)); - install_c_entry(CENTRY_Scall_uns32, proc2ptr(S_call_uns32)); - install_c_entry(CENTRY_Scall_double, proc2ptr(S_call_double)); - install_c_entry(CENTRY_Scall_single, proc2ptr(S_call_single)); - install_c_entry(CENTRY_Scall_int64, proc2ptr(S_call_int64)); - install_c_entry(CENTRY_Scall_uns64, proc2ptr(S_call_uns64)); - install_c_entry(CENTRY_Scall_void, proc2ptr(S_call_void)); + install_c_entry(CENTRY_Scall_one_result, proc2ptr(S_call_one_result)); + install_c_entry(CENTRY_Scall_any_results, proc2ptr(S_call_any_results)); for (i = 0; i < c_entry_vector_size; i++) { #ifndef PTHREADS diff --git a/c/scheme.c b/c/scheme.c index 7717f581a9..2dbef6eb57 100644 --- a/c/scheme.c +++ b/c/scheme.c @@ -320,7 +320,7 @@ static ptr boot_call(tc, p, n) ptr tc; ptr p; INT n; { CP(tc) = Svoid; /* don't have calling code object */ AC0(tc) = (ptr)(uptr)n; - S_call_help(tc, 0); + S_call_help(tc, 0, 0); check_ap(tc); CP(tc) = Svoid; /* leave clean so direct Scall won't choke */ diff --git a/c/schlib.c b/c/schlib.c index ad0de89052..be9259ad45 100644 --- a/c/schlib.c +++ b/c/schlib.c @@ -199,14 +199,14 @@ ptr Scall(cp, argcnt) ptr cp; iptr argcnt; { static ptr S_call(tc, cp, argcnt) ptr tc; ptr cp; iptr argcnt; { AC0(tc) = (ptr)argcnt; AC1(tc) = cp; - S_call_help(tc, 1); + S_call_help(tc, 1, 0); return AC0(tc); } /* args are set up, argcnt in ac0, closure in ac1 */ -void S_call_help(tc, singlep) ptr tc; IBOOL singlep; { +void S_call_help(tc, singlep, lock_ts) ptr tc; IBOOL singlep; IBOOL lock_ts; { /* declaring code volatile should be unnecessary, but it quiets gcc */ - void *jb; volatile ptr code; + void *jb; volatile ptr code; /* lock caller's code object, since his return address is sitting in the C stack and we may end up in a garbage collection */ @@ -220,6 +220,12 @@ void S_call_help(tc, singlep) ptr tc; IBOOL singlep; { if (jb == NULL) S_error_abort("unable to allocate memory for jump buffer"); FRAME(tc, -1) = CCHAIN(tc) = Scons(Scons(jb, code), CCHAIN(tc)); + if (lock_ts) { + /* Lock a code object passed in TS, which is a more immediate + caller whose return address is on the C stack */ + Slock_object(TS(tc)); + CCHAIN(tc) = Scons(Scons(NULL, TS(tc)), CCHAIN(tc)); + } switch (SETJMP(jb)) { case 0: /* first time */ @@ -252,75 +258,21 @@ void S_call_help(tc, singlep) ptr tc; IBOOL singlep; { CP(tc) = code; } -void S_call_void() { +void S_call_one_result() { ptr tc = get_thread_context(); - S_call_help(tc, 0); + S_call_help(tc, 1, 1); } -ptr S_call_ptr() { +void S_call_any_results() { ptr tc = get_thread_context(); - S_call_help(tc, 1); - return AC0(tc); -} - -iptr S_call_fixnum() { - ptr tc = get_thread_context(); - S_call_help(tc, 1); - return Sfixnum_value(AC0(tc)); -} - -I32 S_call_int32() { - ptr tc = get_thread_context(); - S_call_help(tc, 1); - return (I32)Sinteger_value(AC0(tc)); -} - -U32 S_call_uns32() { - ptr tc = get_thread_context(); - S_call_help(tc, 1); - return (U32)Sinteger_value(AC0(tc)); -} - -I64 S_call_int64() { - ptr tc = get_thread_context(); - S_call_help(tc, 1); - return S_int64_value("foreign-callable", AC0(tc)); -} - -U64 S_call_uns64() { - ptr tc = get_thread_context(); - S_call_help(tc, 1); - return S_int64_value("foreign-callable", AC0(tc)); -} - -double S_call_double() { - ptr tc = get_thread_context(); - S_call_help(tc, 1); - return Sflonum_value(AC0(tc)); -} - -float S_call_single() { - ptr tc = get_thread_context(); - S_call_help(tc, 1); - return (float)Sflonum_value(AC0(tc)); -} - -U8 *S_call_bytevector() { - ptr tc = get_thread_context(); - S_call_help(tc, 1); - return (U8 *)&BVIT(AC0(tc),0); -} - -uptr S_call_fptr() { - ptr tc = get_thread_context(); - S_call_help(tc, 1); - return (uptr)RECORDINSTIT(AC0(tc),0); + S_call_help(tc, 0, 1); } /* cchain = ((jb . co) ...) */ void S_return() { ptr tc = get_thread_context(); ptr xp, yp; + void *jb; SFP(tc) = (ptr)((ptr *)SFP(tc) - 2); @@ -336,7 +288,9 @@ void S_return() { for (xp = CCHAIN(tc); ; xp = Scdr(xp)) { Sunlock_object(CDAR(xp)); if (xp == yp) break; - FREEJMPBUF(CAAR(xp)); + jb = CAAR(xp); + if (jb != NULL) + FREEJMPBUF(jb); } /* reset cchain and return via longjmp */ diff --git a/csug/foreign.stex b/csug/foreign.stex index ecac576d7a..f0dc71dd2b 100644 --- a/csug/foreign.stex +++ b/csug/foreign.stex @@ -550,12 +550,24 @@ under Windows running on Intel hardware. \foreigntype{\scheme{(* \var{ftype})}} \index{ftype}This type allows a pointer to a foreign type (ftype) to be passed. -The argument must be an ftype pointer of with type \var{ftype}, +The argument must be an ftype pointer of type \var{ftype}, and the actual argument is the address encapsulated in the ftype pointer. See Section~\ref{SECTFOREIGNDATA} for a description of foreign types. +\foreigntype{\scheme{(& \var{ftype})}} +\index{ftype}This type allows a foreign +type (ftype) to be passed as a value, but represented +on the Scheme side as a pointer to the foreign-type data. +That is, a \scheme{(& \var{ftype})} argument is represented on +the Scheme side the same as a \scheme{(* \var{ftype})} argument, +but a \scheme{(& \var{ftype})} argument is passed to the foreign procedure as the +content at the foreign pointer's address instead of as the +address. For example, if \var{ftype} is a \scheme{struct} type, +then \scheme{(& \var{ftype})} passes a struct argument instead of +a struct-pointer argument. The \var{ftype} cannot refer to an array type. + \medskip\noindent The result types are similar to the parameter types with the addition of a \index{\scheme{void}}\scheme{void} type. @@ -814,6 +826,16 @@ ftype pointer encapsulating the address is returned. See Section~\ref{SECTFOREIGNDATA} for a description of foreign types. +\foreigntype{\scheme{(& \var{ftype})}} +\index{ftype}The result is interpreted as a foreign object +whose structure is described by \var{ftype}, where the foreign +procedure returns a \var{ftype} result, but the caller +must provide an extra \scheme{(* \var{ftype})} argument before +all other arguments to receive the result. An unspecified Scheme object +is returned when the foreign procedure is called, since the result +is instead written into storage referenced by the extra argument. + The \var{ftype} cannot refer to an array type. + \medskip\noindent Consider a C identity procedure: \schemedisplay @@ -969,6 +991,12 @@ except that the requirements and conversions are effectively reversed, e.g., the conversions described for \scheme{foreign-procedure} arguments are performed for \scheme{foreign-callable} return values. +A \scheme{(& \var{ftype})} argument to the callable refers to an address +that is valid only during the dynamic extent of the callback invocation. +A \scheme{(& \var{ftype})} result type for a callable causes the Scheme +procedure to receive an extra \scheme{(& \var{ftype})} argument before +all others; the Scheme procedure should write a result into the extra +argument, and the direct result of the Scheme procedure is ignored. Type checking is performed for result values but not argument values, since the parameter values are provided by the foreign code and must be assumed to be diff --git a/mats/Mf-a6fb b/mats/Mf-a6fb index eb39b33701..b16d1b60da 100644 --- a/mats/Mf-a6fb +++ b/mats/Mf-a6fb @@ -15,13 +15,13 @@ m = a6fb -fsrc = foreign1.c foreign2.c foreign3.c +fsrc = foreign1.c foreign2.c foreign3.c foreign4.c fobj = foreign1.so include Mf-base foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -fPIC -shared -I${Include} -o foreign1.so foreign1.c foreign2.c foreign3.c + cc -fPIC -shared -I${Include} -o foreign1.so ${fsrc} cat_flush: cat_flush.c cc -o cat_flush cat_flush.c diff --git a/mats/Mf-a6le b/mats/Mf-a6le index c209d33f7b..d6fee09cd6 100644 --- a/mats/Mf-a6le +++ b/mats/Mf-a6le @@ -15,13 +15,13 @@ m = a6le -fsrc = foreign1.c foreign2.c foreign3.c +fsrc = foreign1.c foreign2.c foreign3.c foreign4.c fobj = foreign1.so include Mf-base foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -m64 -fPIC -shared -I${Include} -o foreign1.so foreign1.c foreign2.c foreign3.c + cc -m64 -fPIC -shared -I${Include} -o foreign1.so ${fsrc} cat_flush: cat_flush.c cc -o cat_flush cat_flush.c diff --git a/mats/Mf-a6nb b/mats/Mf-a6nb index 75dc3bdf60..48187ef9b2 100644 --- a/mats/Mf-a6nb +++ b/mats/Mf-a6nb @@ -15,13 +15,13 @@ m = a6nb -fsrc = foreign1.c foreign2.c foreign3.c +fsrc = foreign1.c foreign2.c foreign3.c foreign4.c fobj = foreign1.so include Mf-base foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -fPIC -shared -I${Include} -o foreign1.so foreign1.c foreign2.c foreign3.c + cc -fPIC -shared -I${Include} -o foreign1.so ${fsrc} cat_flush: cat_flush.c cc -o cat_flush cat_flush.c diff --git a/mats/Mf-a6nt b/mats/Mf-a6nt index 093d0c3071..51957fad69 100644 --- a/mats/Mf-a6nt +++ b/mats/Mf-a6nt @@ -15,9 +15,9 @@ m = a6nt -fsrc = foreign1.c foreign2.c foreign3.c +fsrc = foreign1.c foreign2.c foreign3.c foreign4.c fobj = foreign1.so -mdclean = cat_flush.exe cat_flush.obj foreign1.exp foreign1.lib foreign1.obj foreign2.obj foreign3.obj +mdclean = cat_flush.exe cat_flush.obj foreign1.exp foreign1.lib foreign1.obj foreign2.obj foreign3.obj foreign4.obj include Mf-base diff --git a/mats/Mf-a6ob b/mats/Mf-a6ob index 8d19133639..12758f303d 100644 --- a/mats/Mf-a6ob +++ b/mats/Mf-a6ob @@ -15,13 +15,13 @@ m = a6ob -fsrc = foreign1.c foreign2.c foreign3.c +fsrc = foreign1.c foreign2.c foreign3.c foreign4.c fobj = foreign1.so include Mf-base foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -fPIC -shared -I${Include} -o foreign1.so foreign1.c foreign2.c foreign3.c + cc -fPIC -shared -I${Include} -o foreign1.so ${fsrc} cat_flush: cat_flush.c cc -o cat_flush cat_flush.c diff --git a/mats/Mf-a6osx b/mats/Mf-a6osx index 0a607e43ee..f1dbf85dc4 100644 --- a/mats/Mf-a6osx +++ b/mats/Mf-a6osx @@ -15,7 +15,7 @@ m = a6osx -fsrc = foreign1.c foreign2.c foreign3.c +fsrc = foreign1.c foreign2.c foreign3.c foreign4.c fobj = foreign1.so include Mf-base diff --git a/mats/Mf-a6s2 b/mats/Mf-a6s2 index 22ae90038a..eccb7d86f0 100644 --- a/mats/Mf-a6s2 +++ b/mats/Mf-a6s2 @@ -15,13 +15,13 @@ m = a6s2 -fsrc = foreign1.c foreign2.c foreign3.c +fsrc = foreign1.c foreign2.c foreign3.c foreign4.c fobj = foreign1.so include Mf-base foreign1.so: ${fsrc} ../boot/$m/scheme.h - gcc -m64 -fPIC -shared -I${Include} -o foreign1.so foreign1.c foreign2.c foreign3.c + gcc -m64 -fPIC -shared -I${Include} -o foreign1.so ${fsrc} cat_flush: cat_flush.c gcc -o cat_flush cat_flush.c diff --git a/mats/Mf-arm32le b/mats/Mf-arm32le index 652435163a..ce547827ee 100644 --- a/mats/Mf-arm32le +++ b/mats/Mf-arm32le @@ -15,13 +15,13 @@ m = arm32le -fsrc = foreign1.c foreign2.c foreign3.c +fsrc = foreign1.c foreign2.c foreign3.c foreign4.c fobj = foreign1.so include Mf-base foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -fPIC -shared -I${Include} -o foreign1.so foreign1.c foreign2.c foreign3.c + cc -fPIC -shared -I${Include} -o foreign1.so ${fsrc} cat_flush: cat_flush.c cc -o cat_flush cat_flush.c diff --git a/mats/Mf-i3fb b/mats/Mf-i3fb index 1bc79ff08c..150cedbf44 100644 --- a/mats/Mf-i3fb +++ b/mats/Mf-i3fb @@ -15,13 +15,13 @@ m = i3fb -fsrc = foreign1.c foreign2.c foreign3.c +fsrc = foreign1.c foreign2.c foreign3.c foreign4.c fobj = foreign1.so include Mf-base foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -fPIC -shared -I${Include} -o foreign1.so foreign1.c foreign2.c foreign3.c + cc -fPIC -shared -I${Include} -o foreign1.so ${fsrc} cat_flush: cat_flush.c cc -o cat_flush cat_flush.c diff --git a/mats/Mf-i3le b/mats/Mf-i3le index 7a0aa01b76..8f521c8fd9 100644 --- a/mats/Mf-i3le +++ b/mats/Mf-i3le @@ -15,13 +15,13 @@ m = i3le -fsrc = foreign1.c foreign2.c foreign3.c +fsrc = foreign1.c foreign2.c foreign3.c foreign4.c fobj = foreign1.so include Mf-base foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -m32 -fPIC -shared -I${Include} -o foreign1.so foreign1.c foreign2.c foreign3.c + cc -m32 -fPIC -shared -I${Include} -o foreign1.so ${fsrc} cat_flush: cat_flush.c cc -o cat_flush cat_flush.c diff --git a/mats/Mf-i3nb b/mats/Mf-i3nb index ecd2301de1..e81f6ff862 100644 --- a/mats/Mf-i3nb +++ b/mats/Mf-i3nb @@ -15,13 +15,13 @@ m = i3nb -fsrc = foreign1.c foreign2.c foreign3.c +fsrc = foreign1.c foreign2.c foreign3.c foreign4.c fobj = foreign1.so include Mf-base foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -fPIC -shared -I${Include} -o foreign1.so foreign1.c foreign2.c foreign3.c + cc -fPIC -shared -I${Include} -o foreign1.so ${fsrc} cat_flush: cat_flush.c cc -o cat_flush cat_flush.c diff --git a/mats/Mf-i3nt b/mats/Mf-i3nt index 572f66aeb6..52e9d3e093 100644 --- a/mats/Mf-i3nt +++ b/mats/Mf-i3nt @@ -15,7 +15,7 @@ m = i3nt -fsrc = foreign1.c foreign2.c foreign3.c +fsrc = foreign1.c foreign2.c foreign3.c foreign4.c fobj = foreign1.so mdclean = cat_flush.exe cat_flush.obj foreign1.exp foreign1.lib foreign1.obj foreign2.obj foreign3.obj diff --git a/mats/Mf-i3ob b/mats/Mf-i3ob index c660dd4c3b..4e3ee1b32d 100644 --- a/mats/Mf-i3ob +++ b/mats/Mf-i3ob @@ -15,13 +15,13 @@ m = i3ob -fsrc = foreign1.c foreign2.c foreign3.c +fsrc = foreign1.c foreign2.c foreign3.c foreign4.c fobj = foreign1.so include Mf-base foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -fPIC -shared -I${Include} -o foreign1.so foreign1.c foreign2.c foreign3.c + cc -fPIC -shared -I${Include} -o foreign1.so ${fsrc} cat_flush: cat_flush.c cc -o cat_flush cat_flush.c diff --git a/mats/Mf-i3osx b/mats/Mf-i3osx index 95b41f33e7..53c7d4ab31 100644 --- a/mats/Mf-i3osx +++ b/mats/Mf-i3osx @@ -15,7 +15,7 @@ m = i3osx -fsrc = foreign1.c foreign2.c foreign3.c +fsrc = foreign1.c foreign2.c foreign3.c foreign4.c fobj = foreign1.so include Mf-base diff --git a/mats/Mf-i3qnx b/mats/Mf-i3qnx index d476e51dc6..724f2dbb84 100644 --- a/mats/Mf-i3qnx +++ b/mats/Mf-i3qnx @@ -15,13 +15,13 @@ m = i3qnx -fsrc = foreign1.c foreign2.c foreign3.c +fsrc = foreign1.c foreign2.c foreign3.c foreign4.c fobj = foreign1.so include Mf-base foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -m32 -fPIC -shared -I${Include} -o foreign1.so foreign1.c foreign2.c foreign3.c + cc -m32 -fPIC -shared -I${Include} -o foreign1.so ${fsrc} cat_flush: cat_flush.c cc -o cat_flush cat_flush.c diff --git a/mats/Mf-i3s2 b/mats/Mf-i3s2 index 76148d108a..c39fffec98 100644 --- a/mats/Mf-i3s2 +++ b/mats/Mf-i3s2 @@ -15,13 +15,13 @@ m = i3s2 -fsrc = foreign1.c foreign2.c foreign3.c +fsrc = foreign1.c foreign2.c foreign3.c foreign4.c fobj = foreign1.so include Mf-base foreign1.so: ${fsrc} ../boot/$m/scheme.h - gcc -m32 -fPIC -shared -I${Include} -o foreign1.so foreign1.c foreign2.c foreign3.c + gcc -m32 -fPIC -shared -I${Include} -o foreign1.so ${fsrc} cat_flush: cat_flush.c gcc -o cat_flush cat_flush.c diff --git a/mats/Mf-ppc32le b/mats/Mf-ppc32le index 7a6b4e3b53..28151a8376 100644 --- a/mats/Mf-ppc32le +++ b/mats/Mf-ppc32le @@ -15,13 +15,13 @@ m = ppc32le -fsrc = foreign1.c foreign2.c foreign3.c +fsrc = foreign1.c foreign2.c foreign3.c foreign4.c fobj = foreign1.so include Mf-base foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -m32 -fPIC -shared -I${Include} -o foreign1.so foreign1.c foreign2.c foreign3.c + cc -m32 -fPIC -shared -I${Include} -o foreign1.so ${fsrc} cat_flush: cat_flush.c cc -o cat_flush cat_flush.c diff --git a/mats/Mf-ta6fb b/mats/Mf-ta6fb index 6e9f75f9fc..fe3a659010 100644 --- a/mats/Mf-ta6fb +++ b/mats/Mf-ta6fb @@ -15,13 +15,13 @@ m = ta6fb -fsrc = foreign1.c foreign2.c foreign3.c +fsrc = foreign1.c foreign2.c foreign3.c foreign4.c fobj = foreign1.so include Mf-base foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -fPIC -shared -I${Include} -o foreign1.so foreign1.c foreign2.c foreign3.c + cc -fPIC -shared -I${Include} -o foreign1.so ${fsrc} cat_flush: cat_flush.c cc -o cat_flush cat_flush.c diff --git a/mats/Mf-ta6le b/mats/Mf-ta6le index cb29256f36..dc214ea4cb 100644 --- a/mats/Mf-ta6le +++ b/mats/Mf-ta6le @@ -15,13 +15,13 @@ m = ta6le -fsrc = foreign1.c foreign2.c foreign3.c +fsrc = foreign1.c foreign2.c foreign3.c foreign4.c fobj = foreign1.so include Mf-base foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -m64 -fPIC -shared -I${Include} -o foreign1.so foreign1.c foreign2.c foreign3.c + cc -m64 -fPIC -shared -I${Include} -o foreign1.so ${fsrc} cat_flush: cat_flush.c cc -o cat_flush cat_flush.c diff --git a/mats/Mf-ta6nb b/mats/Mf-ta6nb index e43e832e4b..49ca02b48b 100644 --- a/mats/Mf-ta6nb +++ b/mats/Mf-ta6nb @@ -15,13 +15,13 @@ m = ta6nb -fsrc = foreign1.c foreign2.c foreign3.c +fsrc = foreign1.c foreign2.c foreign3.c foreign4.c fobj = foreign1.so include Mf-base foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -fPIC -shared -I${Include} -o foreign1.so foreign1.c foreign2.c foreign3.c + cc -fPIC -shared -I${Include} -o foreign1.so ${fsrc} cat_flush: cat_flush.c cc -o cat_flush cat_flush.c diff --git a/mats/Mf-ta6nt b/mats/Mf-ta6nt index 16733d74c1..177a78aed0 100644 --- a/mats/Mf-ta6nt +++ b/mats/Mf-ta6nt @@ -15,7 +15,7 @@ m = ta6nt -fsrc = foreign1.c foreign2.c foreign3.c +fsrc = foreign1.c foreign2.c foreign3.c foreign4.c fobj = foreign1.so mdclean = cat_flush.exe cat_flush.obj foreign1.exp foreign1.lib foreign1.obj foreign2.obj foreign3.obj diff --git a/mats/Mf-ta6ob b/mats/Mf-ta6ob index 54efe04478..f6381ebeef 100644 --- a/mats/Mf-ta6ob +++ b/mats/Mf-ta6ob @@ -15,13 +15,13 @@ m = ta6ob -fsrc = foreign1.c foreign2.c foreign3.c +fsrc = foreign1.c foreign2.c foreign3.c foreign4.c fobj = foreign1.so include Mf-base foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -fPIC -shared -I${Include} -o foreign1.so foreign1.c foreign2.c foreign3.c + cc -fPIC -shared -I${Include} -o foreign1.so ${fsrc} cat_flush: cat_flush.c cc -o cat_flush cat_flush.c diff --git a/mats/Mf-ta6osx b/mats/Mf-ta6osx index 8f9cba4ed8..fe6e8c7ce5 100644 --- a/mats/Mf-ta6osx +++ b/mats/Mf-ta6osx @@ -15,7 +15,7 @@ m = ta6osx -fsrc = foreign1.c foreign2.c foreign3.c +fsrc = foreign1.c foreign2.c foreign3.c foreign4.c fobj = foreign1.so include Mf-base diff --git a/mats/Mf-ta6s2 b/mats/Mf-ta6s2 index 35212dd35d..08233c261e 100644 --- a/mats/Mf-ta6s2 +++ b/mats/Mf-ta6s2 @@ -15,13 +15,13 @@ m = ta6s2 -fsrc = foreign1.c foreign2.c foreign3.c +fsrc = foreign1.c foreign2.c foreign3.c foreign4.c fobj = foreign1.so include Mf-base foreign1.so: ${fsrc} ../boot/$m/scheme.h - gcc -m64 -fPIC -shared -I${Include} -o foreign1.so foreign1.c foreign2.c foreign3.c + gcc -m64 -fPIC -shared -I${Include} -o foreign1.so ${fsrc} cat_flush: cat_flush.c gcc -o cat_flush cat_flush.c diff --git a/mats/Mf-ti3fb b/mats/Mf-ti3fb index 2f01d79ca6..4e77f7590e 100644 --- a/mats/Mf-ti3fb +++ b/mats/Mf-ti3fb @@ -15,13 +15,13 @@ m = ti3fb -fsrc = foreign1.c foreign2.c foreign3.c +fsrc = foreign1.c foreign2.c foreign3.c foreign4.c fobj = foreign1.so include Mf-base foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -fPIC -shared -I${Include} -o foreign1.so foreign1.c foreign2.c foreign3.c + cc -fPIC -shared -I${Include} -o foreign1.so ${fsrc} cat_flush: cat_flush.c cc -o cat_flush cat_flush.c diff --git a/mats/Mf-ti3le b/mats/Mf-ti3le index 8d62aa997a..1f2d31aec6 100644 --- a/mats/Mf-ti3le +++ b/mats/Mf-ti3le @@ -15,13 +15,13 @@ m = ti3le -fsrc = foreign1.c foreign2.c foreign3.c +fsrc = foreign1.c foreign2.c foreign3.c foreign4.c fobj = foreign1.so include Mf-base foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -m32 -fPIC -shared -I${Include} -o foreign1.so foreign1.c foreign2.c foreign3.c + cc -m32 -fPIC -shared -I${Include} -o foreign1.so ${fsrc} cat_flush: cat_flush.c cc -o cat_flush cat_flush.c diff --git a/mats/Mf-ti3nb b/mats/Mf-ti3nb index a56b37bdb4..94ccf0102c 100644 --- a/mats/Mf-ti3nb +++ b/mats/Mf-ti3nb @@ -15,13 +15,13 @@ m = ti3nb -fsrc = foreign1.c foreign2.c foreign3.c +fsrc = foreign1.c foreign2.c foreign3.c foreign4.c fobj = foreign1.so include Mf-base foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -fPIC -shared -I${Include} -o foreign1.so foreign1.c foreign2.c foreign3.c + cc -fPIC -shared -I${Include} -o foreign1.so ${fsrc} cat_flush: cat_flush.c cc -o cat_flush cat_flush.c diff --git a/mats/Mf-ti3nt b/mats/Mf-ti3nt index 5059169016..ab61f72a34 100644 --- a/mats/Mf-ti3nt +++ b/mats/Mf-ti3nt @@ -15,7 +15,7 @@ m = ti3nt -fsrc = foreign1.c foreign2.c foreign3.c +fsrc = foreign1.c foreign2.c foreign3.c foreign4.c fobj = foreign1.so mdclean = cat_flush.exe cat_flush.obj foreign1.exp foreign1.lib foreign1.obj foreign2.obj foreign3.obj diff --git a/mats/Mf-ti3ob b/mats/Mf-ti3ob index e023a17dbe..fca1378175 100644 --- a/mats/Mf-ti3ob +++ b/mats/Mf-ti3ob @@ -15,13 +15,13 @@ m = ti3ob -fsrc = foreign1.c foreign2.c foreign3.c +fsrc = foreign1.c foreign2.c foreign3.c foreign4.c fobj = foreign1.so include Mf-base foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -fPIC -shared -I${Include} -o foreign1.so foreign1.c foreign2.c foreign3.c + cc -fPIC -shared -I${Include} -o foreign1.so ${fsrc} cat_flush: cat_flush.c cc -o cat_flush cat_flush.c diff --git a/mats/Mf-ti3osx b/mats/Mf-ti3osx index baeaaa40ba..9bb964e5d8 100644 --- a/mats/Mf-ti3osx +++ b/mats/Mf-ti3osx @@ -15,7 +15,7 @@ m = ti3osx -fsrc = foreign1.c foreign2.c foreign3.c +fsrc = foreign1.c foreign2.c foreign3.c foreign4.c fobj = foreign1.so include Mf-base diff --git a/mats/Mf-ti3s2 b/mats/Mf-ti3s2 index 4bf6059990..2514adf351 100644 --- a/mats/Mf-ti3s2 +++ b/mats/Mf-ti3s2 @@ -15,13 +15,13 @@ m = ti3s2 -fsrc = foreign1.c foreign2.c foreign3.c +fsrc = foreign1.c foreign2.c foreign3.c foreign4.c fobj = foreign1.so include Mf-base foreign1.so: ${fsrc} ../boot/$m/scheme.h - gcc -m32 -fPIC -shared -I${Include} -o foreign1.so foreign1.c foreign2.c foreign3.c + gcc -m32 -fPIC -shared -I${Include} -o foreign1.so ${fsrc} cat_flush: cat_flush.c gcc -o cat_flush cat_flush.c diff --git a/mats/Mf-tppc32le b/mats/Mf-tppc32le index fdbca7a5eb..6c8945ca64 100644 --- a/mats/Mf-tppc32le +++ b/mats/Mf-tppc32le @@ -15,13 +15,13 @@ m = tppc32le -fsrc = foreign1.c foreign2.c foreign3.c +fsrc = foreign1.c foreign2.c foreign3.c foreign4.c fobj = foreign1.so include Mf-base foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -m32 -fPIC -shared -I${Include} -o foreign1.so foreign1.c foreign2.c foreign3.c + cc -m32 -fPIC -shared -I${Include} -o foreign1.so ${fsrc} cat_flush: cat_flush.c cc -o cat_flush cat_flush.c diff --git a/mats/foreign.ms b/mats/foreign.ms index c4f93fb672..effc4ffc9d 100644 --- a/mats/foreign.ms +++ b/mats/foreign.ms @@ -2018,7 +2018,7 @@ (foreign-callable (lambda (x y) (collect) - (let ([ls (make-list 20000 #\z)]) + (let ([ls (map (lambda (x) (make-vector 200 x)) (make-list 100))]) (collect) (collect) (collect) @@ -2028,8 +2028,13 @@ (scheme-object iptr) scheme-object)) (define (go) (Sinvoke2 Fcons 4 5)) - (go)) - '(20000 4 . 5)) + (define initial-result (go)) + (let loop ([i 100]) + (if (zero? i) + initial-result + (and (equal? initial-result (go)) + (loop (sub1 i)))))) + '(100 4 . 5)) (eqv? (let () (define Sinvoke2 @@ -2486,6 +2491,31 @@ (ftype-pointer-address fptr))) *m*) (+ $stack-depth $base-value))) + ;; Make sure that a callable is suitably locked, and that it's + ;; unlocked when the C stack is popped by an escape + (equal? + (let () + (define Sinvoke2 + (foreign-procedure "Sinvoke2" + (scheme-object scheme-object iptr) + scheme-object)) + (define Fcons + (foreign-callable + (lambda (k y) + ;; Escape with locked, which should be #t + ;; because a callable is locked while it's + ;; called: + (k (locked-object? Fcons))) + (scheme-object iptr) + scheme-object)) + (list + ;; Call and normal callable return: + (let ([v (Sinvoke2 Fcons (lambda (x) x) 5)]) + (list v (locked-object? Fcons))) + ;; Escape from callable: + (let ([v ($with-exit-proc (lambda (k) (Sinvoke2 Fcons k 5)))]) + (list v (locked-object? Fcons))))) + '((#t #f) (#t #f))) ) (machine-case @@ -2643,3 +2673,248 @@ read) '(3.5 2.5 -1.5 6.75 8.25 -9.5 1e32 -4.5 7.25 -0.5)) ) + +(mat structs + (begin + (define-ftype i8 integer-8) + (define-ftype u8 unsigned-8) + (define-ftype u16 unsigned-16) + (define-ftype i64 integer-64) + (define-syntax check* + (syntax-rules () + [(_ T s [vi ...] [T-ref ...] [T-set! ...]) + (let () + (define-ftype callback (function ((& T)) double)) + (define-ftype callback-two (function ((& T) (& T)) double)) + (define-ftype pre-int-callback (function (int (& T)) double)) + (define-ftype pre-double-callback (function (double (& T)) double)) + (define-ftype callback-r (function () (& T))) + (define get (foreign-procedure (format "f4_get~a" s) + () (& T))) + (define sum (foreign-procedure (format "f4_sum~a" s) + ((& T)) double)) + (define sum_two (foreign-procedure (format "f4_sum_two~a" s) + ((& T) (& T)) double)) + (define sum_pre_int (foreign-procedure (format "f4_sum_pre_int~a" s) + (int (& T)) double)) + (define sum_pre_int_int (foreign-procedure (format "f4_sum_pre_int_int~a" s) + (int int (& T)) double)) + (define sum_pre_int_int_int_int (foreign-procedure (format "f4_sum_pre_int_int_int_int~a" s) + (int int int int (& T)) double)) + (define sum_pre_int_int_int_int_int_int (foreign-procedure (format "f4_sum_pre_int_int_int_int_int_int~a" s) + (int int int int int int (& T)) double)) + (define sum_post_int (foreign-procedure (format "f4_sum~a_post_int" s) + ((& T) int) double)) + (define sum_pre_double (foreign-procedure (format "f4_sum_pre_double~a" s) + (double (& T)) double)) + (define sum_pre_double_double (foreign-procedure (format "f4_sum_pre_double_double~a" s) + (double double (& T)) double)) + (define sum_pre_double_double_double_double (foreign-procedure (format "f4_sum_pre_double_double_double_double~a" s) + (double double double double (& T)) double)) + (define sum_pre_double_double_double_double_double_double_double_double + (foreign-procedure (format "f4_sum_pre_double_double_double_double_double_double_double_double~a" s) + (double double double double double double double double (& T)) double)) + (define sum_post_double (foreign-procedure (format "f4_sum~a_post_double" s) + ((& T) double) double)) + (define cb_send (foreign-procedure (format "f4_cb_send~a" s) + ((* callback)) double)) + (define cb_send_two (foreign-procedure (format "f4_cb_send_two~a" s) + ((* callback-two)) double)) + (define cb_send_pre_int (foreign-procedure (format "f4_cb_send_pre_int~a" s) + ((* pre-int-callback)) double)) + (define cb_send_pre_double (foreign-procedure (format "f4_cb_send_pre_double~a" s) + ((* pre-double-callback)) double)) + (define sum_cb (foreign-procedure (format "f4_sum_cb~a" s) + ((* callback-r)) double)) + (define-syntax with-callback + (syntax-rules () + [(_ ([id rhs]) + body) + (let ([id rhs]) + (let ([v body]) + (unlock-object + (foreign-callable-code-object + (ftype-pointer-address id))) + v))])) + (and (let ([v (make-ftype-pointer T (foreign-alloc (ftype-sizeof T)))]) + (get v) + (and (= (T-ref v) vi) + ... + (begin + (foreign-free (ftype-pointer-address v)) + #t))) + (let ([a (make-ftype-pointer T (malloc_at_boundary (ftype-sizeof T)))]) + (T-set! a) ... + (and (= (+ vi ...) (sum a)) + (= (+ vi ... vi ...) (sum_two a a)) + (= (+ 8 vi ...) (sum_pre_int 8 a)) + (= (+ 8 9 vi ...) (sum_pre_int_int 8 9 a)) + (= (+ 8 9 10 11 vi ...) (sum_pre_int_int_int_int 8 9 10 11 a)) + (= (+ 8 9 10 11 12 13 vi ...) (sum_pre_int_int_int_int_int_int 8 9 10 11 12 13 a)) + (= (+ 8 vi ...) (sum_post_int a 8)) + (= (+ 8.25 vi ...) (sum_pre_double 8.25 a)) + (= (+ 8.25 9.25 vi ...) (sum_pre_double_double 8.25 9.25 a)) + (= (+ 8.25 9.25 10.25 11.25 vi ...) (sum_pre_double_double_double_double 8.25 9.25 10.25 11.25 a)) + (= (+ 8.25 9.25 10.25 11.25 12.25 13.25 14.25 15.25 vi ...) + (sum_pre_double_double_double_double_double_double_double_double + 8.25 9.25 10.25 11.25 12.25 13.25 14.25 15.25 a)) + (= (+ 8.25 vi ...) (sum_post_double a 8.25)) + (= (+ 1.0 vi ...) (with-callback ([cb (make-ftype-pointer + callback + (lambda (r) + (exact->inexact (+ (T-ref r) ...))))]) + (cb_send cb))) + (= (+ 1.0 vi ... vi ...) (with-callback ([cb (make-ftype-pointer + callback-two + (lambda (r1 r2) + (exact->inexact (+ (T-ref r1) ... + (T-ref r2) ...))))]) + (cb_send_two cb))) + (= (+ 1.0 8 vi ...) (with-callback ([cb (make-ftype-pointer + pre-int-callback + (lambda (v r) + (exact->inexact (+ v (T-ref r) ...))))]) + (cb_send_pre_int cb))) + (= (+ 1.0 8.25 vi ...) (with-callback ([cb (make-ftype-pointer + pre-double-callback + (lambda (v r) + (exact->inexact (+ v (T-ref r) ...))))]) + (cb_send_pre_double cb))) + (= (+ vi ...) (with-callback ([cb (make-ftype-pointer + callback-r + (lambda (r) + (T-set! r) ...))]) + (sum_cb cb))) + (begin + (free_at_boundary (ftype-pointer-address a)) + #t)))))])) + (define-syntax check-n + (syntax-rules () + [(_ [ni ti vi] ...) + (let () + (define-ftype T (struct [ni ti] ...)) + (define s (apply string-append + "_struct" + (let loop ([l '(ti ...)]) + (cond + [(null? l) '()] + [else (cons (format "_~a" (car l)) + (loop (cdr l)))])))) + (check* T s + [vi ...] + [(lambda (a) (ftype-ref T (ni) a)) ...] + [(lambda (a) (ftype-set! T (ni) a vi)) ...]))])) + (define-syntax check + (syntax-rules () + [(_ t1 v1) + (check* t1 (format "_~a" 't1) + [v1] + [(lambda (a) (ftype-ref t1 () a))] + [(lambda (a) (ftype-set! t1 () a v1))])])) + (define-syntax check-union + (syntax-rules () + [(_ [n0 t0 v0] [ni ti vi] ...) + (let () + (define-ftype T (union [n0 t0] [ni ti] ...)) + (define s (apply string-append + "_union" + (let loop ([l '(t0 ti ...)]) + (cond + [(null? l) '()] + [else (cons (format "_~a" (car l)) + (loop (cdr l)))])))) + (check* T s + [v0] + [(lambda (a) (ftype-ref T (n0) a))] + [(lambda (a) (ftype-set! T (n0) a v0))]))])) + (define-syntax check-1 + (syntax-rules () + [(_ t1 v1) + (check-n [x t1 v1])])) + (define-syntax check-2 + (syntax-rules () + [(_ t1 t2 v1 v2) + (check-n [x t1 v1] [y t2 v2])])) + (define-syntax check-2-set + (syntax-rules () + [(_ t x) + (and + (check-2 t i8 (+ 1 x) 10) + (check-2 t short (+ 2 x) 20) + (check-2 t long (+ 3 x) 30) + (check-2 t i64 (+ 5 x) 50) + (check-2 short t 6 (+ 60 x)) + (check-2 long t 7 (+ 70 x)) + (check-2 i64 t 9 (+ 90 x)) + (check-2 i8 t 10 (+ 100 x)))])) + (define-syntax check-3 + (syntax-rules () + [(_ t1 t2 t3 v1 v2 v3) + (check-n [x t1 v1] [y t2 v2] [z t3 v3])])) + (define-syntax check-3-set + (syntax-rules () + [(_ t x) + (and + (check-3 t i8 int (+ 1 x) 10 100) + (check-3 t short int (+ 2 x) 20 200) + (check-3 t long int (+ 3 x) 30 300) + (check-3 t i64 int (+ 5 x) 50 500) + (check-3 short t int 6 (+ 60 x) 600) + (check-3 long t int 7 (+ 70 x) 700) + (check-3 i64 t int 9 (+ 90 x) 900) + (check-3 i8 t int 10 (+ 100 x) 1000))])) + (define malloc_at_boundary (foreign-procedure "malloc_at_boundary" + (int) uptr)) + (define free_at_boundary (foreign-procedure "free_at_boundary" + (uptr) void)) + #t) + (check i8 -11) + (check u8 129) + (check short -22) + (check u16 33022) + (check long 33) + (check int 44) + (check i64 49) + (check float 55.0) + (check double 66.0) + (check-1 i8 -12) + (check-1 u8 212) + (check-1 short -23) + (check-1 u16 33023) + (check-1 long 34) + (check-1 int 45) + (check-1 i64 48) + (check-1 float 56.0) + (check-1 double 67.0) + (check-2-set int 0) + (check-2-set float 0.5) + (check-2-set double 0.25) + (check-2 int int 4 40) + (check-2 float float 4.5 40.5) + (check-2 double double 4.25 40.25) + (check-3-set int 0) + (check-3-set float 0.5) + (check-3-set double 0.25) + (check-3 i8 i8 i8 4 38 127) + (check-3 short short short 4 39 399) + (check-3 int int int 4 40 400) + (check-3 float float float 4.5 40.5 400.5) + (check-3 double double double 4.25 40.25 400.25) + (check-n [x i8 1] [y i8 2] [z i8 3] [w i8 4] [q i8 5]) + (check-n [x i8 1] [y i8 2] [z i8 3] [w i8 4] [q i8 5] [r i8 6] [s i8 7]) + (check-union [x i8 -17]) + (check-union [x u8 217]) + (check-union [x short -27]) + (check-union [x u16 33027]) + (check-union [x long 37]) + (check-union [x int 47]) + (check-union [x i64 49]) + (check-union [x float 57.0]) + (check-union [x double 77.0]) + (check-union [x i8 18] [y int 0]) + (check-union [x short 28] [y int 0]) + (check-union [x long 38] [y int 0]) + (check-union [x int 48] [y int 0]) + (check-union [x i64 43] [y int 0]) + (check-union [x float 58.0] [y int 0]) + (check-union [x double 68.0] [y int 0])) diff --git a/mats/foreign4.c b/mats/foreign4.c new file mode 100644 index 0000000000..b2bfb62f0b --- /dev/null +++ b/mats/foreign4.c @@ -0,0 +1,288 @@ +/* foreign4.c + * Copyright 1984-2017 Cisco Systems, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + */ + +#include +#include + +typedef signed char i8; +typedef unsigned char u8; +typedef unsigned short u16; +#ifdef _WIN32 +typedef __int64 i64; +# define EXPORT extern __declspec (dllexport) +#else +typedef long long i64; +# define EXPORT +#endif + +/* To help make sure that argument and result handling doens't + read or write too far, try to provide functions that allocate + a structure at the end of a memory page (where the next page is + likely to be unmapped) */ +#if defined(__linux__) || (defined(__APPLE__) && defined(__MACH__)) +# include +# include +# include +# include + +EXPORT void *malloc_at_boundary(int sz) +{ + intptr_t alloc_size = getpagesize(); + char *p; + p = mmap(NULL, alloc_size, PROT_READ | PROT_WRITE, MAP_ANON | MAP_PRIVATE, -1, 0); + return p + alloc_size - sz; +} + +EXPORT void free_at_boundary(void *p) +{ + intptr_t alloc_size = getpagesize(); + munmap((void *)(((intptr_t)p) & ~(alloc_size-1)), alloc_size); +} +#else +EXPORT void *malloc_at_boundary(int sz) +{ + return malloc(sz); +} + +EXPORT void free_at_boundary(void *p) +{ + free(p); +} +#endif + +#define GEN(ts, init, sum) \ + EXPORT ts f4_get_ ## ts () { \ + ts r = init; \ + return r; \ + } \ + EXPORT double f4_sum_ ## ts (ts v) { \ + return sum(v); \ + } \ + EXPORT double f4_sum_two_ ## ts (ts v1, ts v2) { \ + return sum(v1) + sum(v2); \ + } \ + EXPORT double f4_sum_pre_double_ ## ts (double v0, ts v) { \ + return v0 + sum(v); \ + } \ + EXPORT double f4_sum_pre_double_double_ ## ts (double v0, double v1, ts v) { \ + return v0 + v1 + sum(v); \ + } \ + EXPORT double f4_sum_pre_double_double_double_double_ ## ts (double v0, double v1, double v2, double v3, ts v) { \ + return v0 + v1 + v2 + v3 + sum(v); \ + } \ + EXPORT double f4_sum_pre_double_double_double_double_double_double_double_double_ ## ts \ + (double v0, double v1, double v2, double v3, double v4, double v5, double v6, double v7, ts v) { \ + return v0 + v1 + v2 + v3 + v4 + v5 + v6 + v7 + sum(v); \ + } \ + EXPORT double f4_sum_ ## ts ## _post_double (ts v, double v0) { \ + return v0 + sum(v); \ + } \ + EXPORT double f4_sum_pre_int_ ## ts (int v0, ts v) { \ + return (double)v0 + sum(v); \ + } \ + EXPORT double f4_sum_pre_int_int_ ## ts (int v0, int v1, ts v) { \ + return (double)v0 + (double)v1 + sum(v); \ + } \ + EXPORT double f4_sum_pre_int_int_int_int_ ## ts (int v0, int v1, int v2, int v3, ts v) { \ + return (double)v0 + (double)v1 + (double)v2 + (double)v3 + sum(v); \ + } \ + EXPORT double f4_sum_pre_int_int_int_int_int_int_ ## ts (int v0, int v1, int v2, int v3, int v4, int v5, ts v) { \ + return (double)v0 + (double)v1 + (double)v2 + (double)v3 + (double)v4 + (double)v5 + sum(v); \ + } \ + EXPORT double f4_sum_ ## ts ## _post_int (ts v, int v0) { \ + return (double)v0 + sum(v); \ + } \ + EXPORT double f4_cb_send_ ## ts (double (*cb)(ts)) { \ + ts r = init; \ + return cb(r) + 1.0; \ + } \ + EXPORT double f4_cb_send_two_ ## ts (double (*cb)(ts, ts)) { \ + ts r1 = init; \ + ts r2 = init; \ + return cb(r1, r2) + 1.0; \ + } \ + EXPORT double f4_cb_send_pre_int_ ## ts (double (*cb)(int, ts)) { \ + ts r = init; \ + return cb(8, r) + 1.0; \ + } \ + EXPORT double f4_cb_send_pre_int_int_ ## ts (double (*cb)(int, int, ts)) { \ + ts r = init; \ + return cb(8, 9, r) + 1.0; \ + } \ + EXPORT double f4_cb_send_pre_int_int_int_int_ ## ts (double (*cb)(int, int, int, int, ts)) { \ + ts r = init; \ + return cb(8, 9, 10, 11, r) + 1.0; \ + } \ + EXPORT double f4_cb_send_pre_int_int_int_int_int_int_ ## ts (double (*cb)(int, int, int, int, int, int, ts)) { \ + ts r = init; \ + return cb(8, 9, 10, 11, 12, 13, r) + 1.0; \ + } \ + EXPORT double f4_cb_send_pre_double_ ## ts (double (*cb)(double, ts)) { \ + ts r = init; \ + return cb(8.25, r) + 1.0; \ + } \ + EXPORT double f4_cb_send_pre_double_double_ ## ts (double (*cb)(double, double, ts)) { \ + ts r = init; \ + return cb(8.25, 9.25, r) + 1.0; \ + } \ + EXPORT double f4_cb_send_pre_double_double_double_double_ ## ts (double (*cb)(double, double, double, double, ts)) { \ + ts r = init; \ + return cb(8.25, 9.25, 10.25, 11.25, r) + 1.0; \ + } \ + EXPORT double f4_cb_send_pre_double_double_double_double_double_double_double_double_ ## ts \ + (double (*cb)(double, double, double, double, double, double, double, double, ts)) { \ + ts r = init; \ + return cb(8.25, 9.25, 10.25, 11.25, 12.25, 13.25, 14.25, 15.25, r) + 1.0; \ + } \ + EXPORT double f4_sum_cb_ ## ts (ts (*cb)()) { \ + ts v = cb(); \ + return sum(v); \ + } + +#define TO_DOUBLE(x) ((double)(x)) +GEN(i8, -11, TO_DOUBLE) +GEN(u8, 129, TO_DOUBLE) +GEN(short, -22, TO_DOUBLE) +GEN(u16, 33022, TO_DOUBLE) +GEN(long, 33, TO_DOUBLE) +GEN(int, 44, TO_DOUBLE) +GEN(i64, 49, TO_DOUBLE) +GEN(float, 55.0, TO_DOUBLE) +GEN(double, 66.0, TO_DOUBLE) + +/* Some ABIs treat a struct containing a single field different that + just the field */ +#define GEN_1(t1, v1) \ + typedef struct struct_ ## t1 { t1 x; } struct_ ## t1; \ + static double _f4_sum_struct_ ## t1 (struct_ ## t1 v) { \ + return (double)v.x; \ + } \ + static struct_ ## t1 init_struct_ ## t1 = { v1 }; \ + GEN(struct_ ## t1, init_struct_ ## t1, _f4_sum_struct_ ## t1) + +GEN_1(i8, -12) +GEN_1(u8, 212) +GEN_1(short, -23) +GEN_1(u16, 33023) +GEN_1(long, 34) +GEN_1(int, 45) +GEN_1(i64, 48) +GEN_1(float, 56.0) +GEN_1(double, 67.0) + +#define GEN_2(t1, t2, v1, v2) \ + typedef struct struct_ ## t1 ## _ ## t2 { t1 x; t2 y; } struct_ ## t1 ## _ ## t2; \ + static double _f4_sum_struct_ ## t1 ## _ ## t2 (struct_ ## t1 ## _ ## t2 v) { \ + return (double)v.x + (double)v.y; \ + } \ + static struct_ ## t1 ## _ ## t2 init_struct_ ## t1 ## _ ## t2 = { v1, v2 }; \ + GEN(struct_ ## t1 ## _ ## t2, init_struct_ ## t1 ## _ ## t2, _f4_sum_struct_ ## t1 ## _ ## t2) + +#define GEN_2_SET(t, x) \ + GEN_2(t, i8, 1+x, 10) \ + GEN_2(t, short, 2+x, 20) \ + GEN_2(t, long, 3+x, 30) \ + GEN_2(t, i64, 5+x, 50) \ + GEN_2(short, t, 6, 60+x) \ + GEN_2(long, t, 7, 70+x) \ + GEN_2(i64, t, 9, 90+x) \ + GEN_2(i8, t, 10, 100+x) + +GEN_2_SET(int, 0) +GEN_2_SET(float, 0.5) +GEN_2_SET(double, 0.25) + +GEN_2(int, int, 4, 40) +GEN_2(float, float, 4.5, 40.5) +GEN_2(double, double, 4.25, 40.25) + +#define GEN_3(t1, t2, t3, v1, v2, v3) \ + typedef struct struct_ ## t1 ## _ ## t2 ## _ ## t3 { t1 x; t2 y; t3 z; } struct_ ## t1 ## _ ## t2 ## _ ## t3; \ + static double _f4_sum_struct_ ## t1 ## _ ## t2 ## _ ## t3 (struct_ ## t1 ## _ ## t2 ## _ ## t3 v) { \ + return (double)v.x + (double)v.y + (double)v.z; \ + } \ + static struct_ ## t1 ## _ ## t2 ## _ ## t3 init_struct_ ## t1 ## _ ## t2 ## _ ## t3 = { v1, v2, v3 }; \ + GEN(struct_ ## t1 ## _ ## t2 ## _ ## t3, init_struct_ ## t1 ## _ ## t2 ## _ ## t3, _f4_sum_struct_ ## t1 ## _ ## t2 ## _ ## t3) + +#define GEN_3_SET(t, x) \ + GEN_3(t, i8, int, 1+x, 10, 100) \ + GEN_3(t, short, int, 2+x, 20, 200) \ + GEN_3(t, long, int, 3+x, 30, 300) \ + GEN_3(t, i64, int, 5+x, 50, 500) \ + GEN_3(short, t, int, 6, 60+x, 600) \ + GEN_3(long, t, int, 7, 70+x, 700) \ + GEN_3(i64, t, int, 9, 90+x, 900) \ + GEN_3(i8, t, int, 10, 100+x, 1000) + +GEN_3_SET(int, 0) +GEN_3_SET(float, 0.5) +GEN_3_SET(double, 0.25) + +GEN_3(i8, i8, i8, 4, 38, 127) +GEN_3(short, short, short, 4, 39, 399) +GEN_3(int, int, int, 4, 40, 400) +GEN_3(float, float, float, 4.5, 40.5, 400.5) +GEN_3(double, double, double, 4.25, 40.25, 400.25) + +typedef struct struct_i8_i8_i8_i8_i8 { i8 x, y, z, w, q; } struct_i8_i8_i8_i8_i8; +static double _f4_sum_struct_i8_i8_i8_i8_i8 (struct_i8_i8_i8_i8_i8 v) { + return (double)v.x + (double)v.y + (double)v.z + (double)v.w + (double)v.q; +} +static struct struct_i8_i8_i8_i8_i8 init_struct_i8_i8_i8_i8_i8 = { 1, 2, 3, 4, 5 }; +GEN(struct_i8_i8_i8_i8_i8, init_struct_i8_i8_i8_i8_i8, _f4_sum_struct_i8_i8_i8_i8_i8) + +typedef struct struct_i8_i8_i8_i8_i8_i8_i8 { i8 x, y, z, w, q, r, s; } struct_i8_i8_i8_i8_i8_i8_i8; +static double _f4_sum_struct_i8_i8_i8_i8_i8_i8_i8 (struct struct_i8_i8_i8_i8_i8_i8_i8 v) { + return (double)v.x + (double)v.y + (double)v.z + (double)v.w + (double)v.q + (double)v.r + (double)v.s; +} +static struct struct_i8_i8_i8_i8_i8_i8_i8 init_struct_i8_i8_i8_i8_i8_i8_i8 = { 1, 2, 3, 4, 5, 6, 7 }; +GEN(struct_i8_i8_i8_i8_i8_i8_i8, init_struct_i8_i8_i8_i8_i8_i8_i8, _f4_sum_struct_i8_i8_i8_i8_i8_i8_i8) + +/* Some ABIs treat a union containing a single field different that + just the field */ +#define GEN_U1(t1, v1) \ + typedef union union_ ## t1 { t1 x; } union_ ## t1; \ + static double _f4_sum_union_ ## t1 (union_ ## t1 v) { \ + return (double)v.x; \ + } \ + static union_ ## t1 init_union_ ## t1 = { v1 }; \ + GEN(union_ ## t1, init_union_ ## t1, _f4_sum_union_ ## t1) + +GEN_U1(i8, -17) +GEN_U1(u8, 217) +GEN_U1(short, -27) +GEN_U1(u16, 33027) +GEN_U1(long, 37) +GEN_U1(int, 47) +GEN_U1(i64, 49) +GEN_U1(float, 57.0) +GEN_U1(double, 77.0) + +#define GEN_U2(t1, t2, v1) \ + typedef union union_ ## t1 ## _ ## t2 { t1 x; t2 y; } union_ ## t1 ## _ ## t2; \ + static double _f4_sum_union_ ## t1 ## _ ## t2 (union_ ## t1 ## _ ## t2 v) { \ + return (double)v.x; \ + } \ + static union_ ## t1 ## _ ## t2 init_union_ ## t1 ## _ ## t2 = { v1 }; \ + GEN(union_ ## t1 ## _ ## t2, init_union_ ## t1 ## _ ## t2, _f4_sum_union_ ## t1 ## _ ## t2) + +GEN_U2(i8, int, 18) +GEN_U2(short, int, 28) +GEN_U2(long, int, 38) +GEN_U2(int, int, 48) +GEN_U2(i64, int, 43) +GEN_U2(float, int, 58.0) +GEN_U2(double, int, 68.0) diff --git a/release_notes/release_notes.stex b/release_notes/release_notes.stex index 8a5bb3fb5f..c0678c7a0b 100644 --- a/release_notes/release_notes.stex +++ b/release_notes/release_notes.stex @@ -58,6 +58,18 @@ Online versions of both books can be found at %----------------------------------------------------------------------------- \section{Functionality Changes}\label{section:functionality} +\subsection{Foreign-procedure struct arguments and results (9.5.1)} + +A new \scheme{(& \var{ftype})} form allows a struct or union to be +passed between Scheme and a foreign procedure. The Scheme-side +representation of a \scheme{(& \var{ftype})} argument is the +same as a \scheme{(* \var{ftype})} argument, but where +\scheme{(& \var{ftype})} passes an address between the Scheme and C +worlds, \scheme{(& \var{ftype})} passes a copy of the data at the +address. When \scheme{(& \var{ftype})} is used as a result type, +an extra \scheme{(* \var{ftype})} argument must be provided to receive +the copied result, and the directly returned result is unspecified. + \subsection{Record equality and hashing (9.5, 9.5.1)} Several new procedures and parameters allow a program to control what diff --git a/s/arm32.ss b/s/arm32.ss index 9710b6becd..711261939a 100644 --- a/s/arm32.ss +++ b/s/arm32.ss @@ -890,7 +890,7 @@ asm-fl-load/cvt asm-fl-store/cvt asm-flt asm-trunc asm-lock asm-lock+/- asm-flop-2 asm-flsqrt asm-c-simple-call - asm-save-flrv asm-restore-flrv asm-return asm-size + asm-save-flrv asm-restore-flrv asm-return asm-c-return asm-size asm-enter asm-foreign-call asm-foreign-callable asm-read-counter asm-inc-cc-counter @@ -2051,7 +2051,7 @@ (rec asm-c-simple-call-internal (lambda (code* jmp-tmp . ignore) (asm-helper-call code* target save-ra? jmp-tmp)))))) - + (define-who asm-indirect-call (lambda (code* dest lr . ignore) (safe-assert (eq? lr %lr)) @@ -2277,6 +2277,8 @@ ; NB: reads from %lr...should be okay if declare-intrinsics sets up return-live* properly (define asm-return (lambda () (emit bx (cons 'reg %lr) '()))) + (define asm-c-return (lambda (info) (emit bx (cons 'reg %lr) '()))) + (define-who asm-shiftop (lambda (op) (lambda (code* dest src0 src1) @@ -2313,10 +2315,28 @@ (module (asm-foreign-call asm-foreign-callable) (define align (lambda (b x) (let ([k (- b 1)]) (fxlogand (fx+ x k) (fxlognot k))))) + (define (double-member? m) (and (eq? (car m) 'float) + (fx= (cadr m) 8))) + (define (float-member? m) (and (eq? (car m) 'float) + (fx= (cadr m) 4))) + (define (indirect-result-that-fits-in-registers? result-type) + (nanopass-case (Ltype Type) result-type + [(fp-ftd& ,ftd) + (let* ([members ($ftd->members ftd)] + [num-members (length members)]) + (or (fx<= ($ftd-size ftd) 4) + (and (fx= num-members 1) + ;; a struct containing only int64 is not returned in a register + (or (not ($ftd-compound? ftd)))) + (and (fx<= num-members 4) + (or (andmap double-member? members) + (andmap float-member? members)))))] + [else #f])) + (define sgl-regs (lambda () (list %Cfparg1 %Cfparg1b %Cfparg2 %Cfparg2b %Cfparg3 %Cfparg3b %Cfparg4 %Cfparg4b + %Cfparg5 %Cfparg5b %Cfparg6 %Cfparg6b %Cfparg7 %Cfparg7b %Cfparg8 %Cfparg8b))) (define-who asm-foreign-call (with-output-language (L13 Effect) (define int-regs (lambda () (list %Carg1 %Carg2 %Carg3 %Carg4))) - (define sgl-regs (lambda () (list %Cfparg1 %Cfparg1b %Cfparg2 %Cfparg2b %Cfparg3 %Cfparg3b %Cfparg4 %Cfparg4b %Cfparg5 %Cfparg5b %Cfparg6 %Cfparg6b %Cfparg7 %Cfparg7b %Cfparg8 %Cfparg8b))) (letrec ([load-double-stack (lambda (offset) (lambda (x) ; requires var @@ -2327,7 +2347,7 @@ (lambda (offset) (lambda (x) ; requires var (%seq - (inline ,(make-info-loadfl %flreg1) ,%load-double->single ,x ,%zero ,(%constant flonum-data-disp)) + (inline ,(make-info-loadfl %flreg1) ,%load-double->single ,x ,%zero ,(%constant flonum-data-disp)) (inline ,(make-info-loadfl %flreg1) ,%store-single ,%sp ,%zero (immediate ,offset)))))] [load-int-stack (lambda (offset) @@ -2339,14 +2359,33 @@ (%seq (set! ,(%mref ,%sp ,offset) ,lorhs) (set! ,(%mref ,%sp ,(fx+ offset 4)) ,hirhs))))] + [load-int-indirect-stack + (lambda (offset from-offset size) + (lambda (x) ; requires var + (case size + [(3) + (%seq + (set! ,(%mref ,%sp ,offset) (inline ,(make-info-load 'integer-16 #f) ,%load ,x ,%zero (immediate ,from-offset))) + (set! ,(%mref ,%sp ,(fx+ offset 2)) (inline ,(make-info-load 'integer-8 #f) ,%load ,x ,%zero (immediate ,(fx+ from-offset 2)))))] + [else + `(set! ,(%mref ,%sp ,offset) ,(case size + [(1) `(inline ,(make-info-load 'integer-8 #f) ,%load ,x ,%zero (immediate ,from-offset))] + [(2) `(inline ,(make-info-load 'integer-16 #f) ,%load ,x ,%zero (immediate ,from-offset))] + [(4) (%mref ,x ,from-offset)]))])))] + [load-int64-indirect-stack + (lambda (offset from-offset) + (lambda (x) ; requires var + (%seq + (set! ,(%mref ,%sp ,offset) ,(%mref ,x ,from-offset)) + (set! ,(%mref ,%sp ,(fx+ offset 4)) ,(%mref ,x ,(fx+ from-offset 4))))))] [load-double-reg - (lambda (fpreg) + (lambda (fpreg fp-disp) (lambda (x) ; requires var - `(inline ,(make-info-loadfl fpreg) ,%load-double ,x ,%zero ,(%constant flonum-data-disp))))] + `(inline ,(make-info-loadfl fpreg) ,%load-double ,x ,%zero (immediate ,fp-disp))))] [load-single-reg - (lambda (fpreg) + (lambda (fpreg fp-disp single?) (lambda (x) ; requires var - `(inline ,(make-info-loadfl fpreg) ,%load-double->single ,x ,%zero ,(%constant flonum-data-disp))))] + `(inline ,(make-info-loadfl fpreg) ,(if single? %load-single %load-double->single) ,x ,%zero (immediate ,fp-disp))))] [load-int-reg (lambda (ireg) (lambda (x) @@ -2357,6 +2396,28 @@ (%seq (set! ,loreg ,lo) (set! ,hireg ,hi))))] + [load-int-indirect-reg + (lambda (ireg from-offset size) + (lambda (x) + (case size + [(3) + (let ([tmp %lr]) ; ok to use %lr here? + (%seq + (set! ,ireg (inline ,(make-info-load 'integer-16 #f) ,%load ,x ,%zero (immediate ,from-offset))) + (set! ,tmp (inline ,(make-info-load 'integer-8 #f) ,%load ,x ,%zero (immediate ,(fx+ from-offset 2)))) + (set! ,tmp ,(%inline sll ,tmp (immediate 16))) + (set! ,ireg ,(%inline + ,ireg ,tmp))))] + [else + `(set! ,ireg ,(case size + [(1) `(inline ,(make-info-load 'integer-8 #f) ,%load ,x ,%zero (immediate ,from-offset))] + [(2) `(inline ,(make-info-load 'integer-16 #f) ,%load ,x ,%zero (immediate ,from-offset))] + [(4) (%mref ,x ,from-offset)]))])))] + [load-int64-indirect-reg + (lambda (loreg hireg from-offset) + (lambda (x) + (%seq + (set! ,loreg ,(%mref ,x ,from-offset)) + (set! ,hireg ,(%mref ,x ,(fx+ from-offset 4))))))] [do-args (lambda (types) ; sgl* is always of even-length, i.e., has a sgl/dbl reg first @@ -2372,21 +2433,97 @@ (cons (load-double-stack isp) locs) live* int* '() #f (fx+ isp 8))) (loop (cdr types) - (cons (load-double-reg (car sgl*)) locs) + (cons (load-double-reg (car sgl*) (constant flonum-data-disp)) locs) live* int* (cddr sgl*) bsgl isp))] [(fp-single-float) (if bsgl (loop (cdr types) - (cons (load-single-reg bsgl) locs) + (cons (load-single-reg bsgl (constant flonum-data-disp) #f) locs) live* int* sgl* #f isp) (if (null? sgl*) (loop (cdr types) (cons (load-single-stack isp) locs) live* int* '() #f (fx+ isp 4)) (loop (cdr types) - (cons (load-single-reg (car sgl*)) locs) + (cons (load-single-reg (car sgl*) (constant flonum-data-disp) #f) locs) live* int* (cddr sgl*) (cadr sgl*) isp)))] - [else + [(fp-ftd& ,ftd) + (let ([size ($ftd-size ftd)] + [members ($ftd->members ftd)] + [combine-loc (lambda (loc f) + (if loc + (lambda (x) (%seq ,(loc x) ,(f x))) + f))]) + (case ($ftd-alignment ftd) + [(8) + (let* ([int* (if (even? (length int*)) int* (cdr int*))] + [num-members (length members)] + [doubles? (and (fx<= num-members 4) + (andmap double-member? members))]) + ;; Sequence of up to 4 doubles that fits in registers? + (cond + [(and doubles? + (fx>= (length sgl*) (fx* 2 num-members))) + ;; Allocate each double to a register + (let dbl-loop ([size size] [offset 0] [sgl* sgl*] [loc #f]) + (cond + [(fx= size 0) + (loop (cdr types) (cons loc locs) live* int* sgl* #f isp)] + [else + (dbl-loop (fx- size 8) (fx+ offset 8) (cddr sgl*) + (combine-loc loc (load-double-reg (car sgl*) offset)))]))] + [else + ;; General case; for non-doubles, use integer registers while available, + ;; possibly splitting between registers and stack + (let obj-loop ([size size] [offset 0] [loc #f] + [live* live*] [int* int*] [isp isp]) + (cond + [(fx= size 0) + (loop (cdr types) (cons loc locs) live* int* sgl* bsgl isp)] + [else + (if (or (null? int*) doubles?) + (let ([isp (align 8 isp)]) + (obj-loop (fx- size 8) (fx+ offset 8) + (combine-loc loc (load-int64-indirect-stack isp offset)) + live* int* (fx+ isp 8))) + (obj-loop (fx- size 8) (fx+ offset 8) + (combine-loc loc (load-int64-indirect-reg (car int*) (cadr int*) offset)) + (cons* (car int*) (cadr int*) live*) (cddr int*) isp))]))]))] + [else + (let* ([num-members (length members)] + [floats? (and (fx<= num-members 4) + (andmap float-member? members))]) + ;; Sequence of up to 4 floats that fits in registers? + (cond + [(and floats? + (fx>= (fx+ (length sgl*) (if bsgl 1 0)) num-members)) + ;; Allocate each float to register + (let flt-loop ([size size] [offset 0] [sgl* sgl*] [bsgl bsgl] [loc #f]) + (cond + [(fx= size 0) + (loop (cdr types) (cons loc locs) live* int* sgl* bsgl isp)] + [else + (flt-loop (fx- size 4) (fx+ offset 4) + (if bsgl sgl* (cddr sgl*)) + (if bsgl #f (cadr sgl*)) + (combine-loc loc (load-single-reg (or bsgl (car sgl*)) offset #t)))]))] + [else + ;; General case; use integer registers while available, + ;; possibly splitting between registers and stack + (let obj-loop ([size size] [offset 0] [loc #f] + [live* live*] [int* int*] [isp isp]) + (cond + [(fx<= size 0) + (loop (cdr types) (cons loc locs) live* int* sgl* bsgl isp)] + [else + (if (or (null? int*) floats?) + (obj-loop (fx- size 4) (fx+ offset 4) + (combine-loc loc (load-int-indirect-stack isp offset (fxmin size 4))) + live* int* (fx+ isp 4)) + (obj-loop (fx- size 4) (fx+ offset 4) + (combine-loc loc (load-int-indirect-reg (car int*) offset (fxmin size 4))) + (cons (car int*) live*) (cdr int*) isp))]))]))]))] + [else (if (nanopass-case (Ltype Type) (car types) [(fp-integer ,bits) (fx= bits 64)] [(fp-unsigned ,bits) (fx= bits 64)] @@ -2406,14 +2543,62 @@ live* '() sgl* bsgl (fx+ isp 4)) (loop (cdr types) (cons (load-int-reg (car int*)) locs) - (cons (car int*) live*) (cdr int*) sgl* bsgl isp)))]))))]) + (cons (car int*) live*) (cdr int*) sgl* bsgl isp)))]))))] + [add-fill-result + (lambda (fill-result-here? result-type args-frame-size e) + (cond + [fill-result-here? + (nanopass-case (Ltype Type) result-type + [(fp-ftd& ,ftd) + (let* ([members ($ftd->members ftd)] + [num-members (length members)] + ;; result pointer is stashed on the stack after all arguments: + [dest-x %r2] + [init-dest-e `(seq ,e (set! ,dest-x ,(%mref ,%sp ,args-frame-size)))]) + (cond + [(and (fx<= num-members 4) + (or (andmap double-member? members) + (andmap float-member? members))) + ;; double/float results are in floating-point registers + (let ([double? (and (pair? members) (double-member? (car members)))]) + (let loop ([members members] [sgl* (sgl-regs)] [offset 0] [e init-dest-e]) + (cond + [(null? members) e] + [else + (loop (cdr members) + (if double? (cddr sgl*) (cdr sgl*)) + (fx+ offset (if double? 8 4)) + `(seq + ,e + (inline ,(make-info-loadfl (car sgl*)) ,(if double? %store-double %store-single) + ,dest-x ,%zero (immediate ,offset))))])))] + [else + ;; result is in %Cretval and maybe %r1 + `(seq + ,init-dest-e + ,(case ($ftd-size ftd) + [(1) `(inline ,(make-info-load 'integer-8 #f) ,%store ,dest-x ,%zero (immediate 0) ,%Cretval)] + [(2) `(inline ,(make-info-load 'integer-16 #f) ,%store ,dest-x ,%zero (immediate 0) ,%Cretval)] + [(3) (%seq + (inline ,(make-info-load 'integer-16 #f) ,%store ,dest-x ,%zero (immediate 0) ,%Cretval) + (set! ,%Cretval ,(%inline srl ,%Cretval (immediate 16))) + (inline ,(make-info-load 'integer-8 #f) ,%store ,dest-x ,%zero (immediate 2) ,%Cretval))] + [(4) `(set! ,(%mref ,dest-x ,0) ,%Cretval)] + [(8) `(seq + (set! ,(%mref ,dest-x ,0) ,%Cretval) + (set! ,(%mref ,dest-x ,4) ,%r1))]))]))])] + [else e]))]) (lambda (info) (safe-assert (reg-callee-save? %tc)) ; no need to save-restore - (let ([arg-type* (info-foreign-arg-type* info)] - [result-type (info-foreign-result-type info)]) - (with-values (do-args arg-type*) - (lambda (frame-size locs live*) - (let* ([frame-size (align 8 frame-size)] + (let* ([arg-type* (info-foreign-arg-type* info)] + [result-type (info-foreign-result-type info)] + [fill-result-here? (indirect-result-that-fits-in-registers? result-type)]) + (with-values (do-args (if fill-result-here? (cdr arg-type*) arg-type*)) + (lambda (args-frame-size locs live*) + (let* ([frame-size (align 8 (+ args-frame-size + (if fill-result-here? + 4 + 0)))] [adjust-frame (lambda (op) (lambda () (if (fx= frame-size 0) @@ -2421,9 +2606,15 @@ `(set! ,%sp (inline ,null-info ,op ,%sp (immediate ,frame-size))))))]) (values (adjust-frame %-) - (reverse locs) + (let ([locs (reverse locs)]) + (cond + [fill-result-here? + ;; stash extra argument on the stack to be retrieved after call and filled with the result: + (cons (load-int-stack args-frame-size) locs)] + [else locs])) (lambda (t0) - `(inline ,(make-info-kill*-live* (reg-list %r0) live*) ,%c-call ,t0)) + (add-fill-result fill-result-here? result-type args-frame-size + `(inline ,(make-info-kill*-live* (reg-list %r0) live*) ,%c-call ,t0))) (nanopass-case (Ltype Type) result-type [(fp-double-float) (lambda (lvalue) @@ -2463,18 +2654,26 @@ +---------------------------+ | | | incoming stack args | - sp+36+X+Y+Z: | | - +---------------------------+<- 8-byte boundary - | | - | saved float reg args | 0-16 words - sp+36+X+Y: | | + sp+36+R+X+Y+Z+W: | | +---------------------------+<- 8-byte boundary | | | saved int reg args | 0-4 words - sp+36+X: | | + sp+36+R+X+Y+Z: | | +---------------------------+ | | | pad word if necessary | 0-1 words + sp+36+R+X+Y: | | + +---------------------------+<- 8-byte boundary + | | + | saved float reg args | 0-16 words + sp+36+R+X: | | + +---------------------------+<- 8-byte boundary + | | + | &-return space | up to 8 words + sp+36+R: | | + +---------------------------+<- 8-byte boundary + | | + | pad word if necessary | 0-1 words sp+36: | | +---------------------------+ | | @@ -2523,10 +2722,14 @@ (%seq (set! ,lolvalue ,(%mref ,%sp ,offset)) (set! ,hilvalue ,(%mref ,%sp ,(fx+ offset 4))))))) + (define load-stack-address + (lambda (offset) + (lambda (lvalue) + `(set! ,lvalue ,(%inline + ,%sp (immediate ,offset)))))) (define count-reg-args - (lambda (types) + (lambda (types synthesize-first?) ; bsgl? is #t iff we have a "b" single (second half of double) float reg to fill - (let f ([types types] [iint 0] [idbl 0] [bsgl? #f]) + (let f ([types types] [iint (if synthesize-first? -1 0)] [idbl 0] [bsgl? #f]) (if (null? types) (values iint idbl) (nanopass-case (Ltype Type) (car types) @@ -2540,6 +2743,34 @@ (if (fx< idbl 8) (f (cdr types) iint (fx+ idbl 1) #t) (f (cdr types) iint idbl #f)))] + [(fp-ftd& ,ftd) + (let* ([size ($ftd-size ftd)] + [members ($ftd->members ftd)] + [num-members (length members)]) + (cond + [(and (fx<= num-members 4) + (andmap double-member? members)) + ;; doubles are either in registers or all on stack + (if (fx<= (fx+ idbl num-members) 8) + (f (cdr types) iint (fx+ idbl num-members) #f) + ;; no more floating-point registers should be used, but ok if we count more + (f (cdr types) iint idbl #f))] + [(and (fx<= num-members 4) + (andmap float-member? members)) + ;; floats are either in registers or all on stack + (let ([amt (fxsrl (align 2 (fx- num-members (if bsgl? 1 0))) 1)]) + (if (fx<= (fx+ idbl amt) 8) + (let ([odd-floats? (fxodd? num-members)]) + (if bsgl? + (f (cdr types) iint (+ idbl amt) (not odd-floats?)) + (f (cdr types) iint (+ idbl amt) odd-floats?))) + ;; no more floating-point registers should be used, but ok if we count more + (f (cdr types) iint idbl #f)))] + [(fx= 8 ($ftd-alignment ftd)) + (f (cdr types) (fxmin 4 (fx+ (align 2 iint) (fxsrl size 2))) idbl bsgl?)] + [else + (let ([size (align 4 size)]) + (f (cdr types) (fxmin 4 (fx+ iint (fxsrl size 2))) idbl bsgl?))]))] [else (if (nanopass-case (Ltype Type) (car types) [(fp-integer ,bits) (fx= bits 64)] @@ -2551,12 +2782,16 @@ (define do-stack ; all of the args are on the stack at this point, though not contiguous since ; we push all of the int reg args with one push instruction and all of the - ; float reg args with another (v)push instruction - (lambda (types saved-reg-bytes pad-bytes int-reg-bytes float-reg-bytes) - (let* ([int-reg-offset (fx+ saved-reg-bytes pad-bytes)] - [float-reg-offset (fx+ int-reg-offset int-reg-bytes)] - [stack-arg-offset (fx+ float-reg-offset float-reg-bytes)]) - (let loop ([types types] + ; float reg args with another (v)push instruction; the saved int regs + ; continue on into the stack variables, which is convenient when a struct + ; argument is split across registers and the stack + (lambda (types saved-reg-bytes pre-pad-bytes return-bytes float-reg-bytes post-pad-bytes int-reg-bytes + synthesize-first?) + (let* ([return-space-offset (fx+ saved-reg-bytes pre-pad-bytes)] + [float-reg-offset (fx+ return-space-offset return-bytes)] + [int-reg-offset (fx+ float-reg-offset float-reg-bytes post-pad-bytes)] + [stack-arg-offset (fx+ int-reg-offset int-reg-bytes)]) + (let loop ([types (if synthesize-first? (cdr types) types)] [locs '()] [iint 0] [idbl 0] @@ -2565,7 +2800,11 @@ [float-reg-offset float-reg-offset] [stack-arg-offset stack-arg-offset]) (if (null? types) - (reverse locs) + (let ([locs (reverse locs)]) + (if synthesize-first? + (cons (load-stack-address return-space-offset) + locs) + locs)) (nanopass-case (Ltype Type) (car types) [(fp-double-float) (if (< idbl 8) @@ -2590,12 +2829,73 @@ (loop (cdr types) (cons (load-single-stack stack-arg-offset) locs) iint 8 #f int-reg-offset float-reg-offset (fx+ stack-arg-offset 4))))] + [(fp-ftd& ,ftd) + (let* ([size ($ftd-size ftd)] + [members ($ftd->members ftd)] + [num-members (length members)]) + (cond + [(and (fx<= num-members 4) + (andmap double-member? members)) + ;; doubles are either in registers or all on stack + (if (fx<= (fx+ idbl num-members) 8) + (loop (cdr types) + (cons (load-stack-address float-reg-offset) locs) + iint (fx+ idbl num-members) #f int-reg-offset (fx+ float-reg-offset size) stack-arg-offset) + (let ([stack-arg-offset (align 8 stack-arg-offset)]) + (loop (cdr types) + (cons (load-stack-address stack-arg-offset) locs) + iint 8 #f int-reg-offset #f (fx+ stack-arg-offset size))))] + [(and (fx<= num-members 4) + (andmap float-member? members)) + ;; floats are either in registers or all on stack + (let ([amt (fxsrl (align 2 (fx- num-members (if bsgl-offset 1 0))) 1)]) + (if (fx<= (fx+ idbl amt) 8) + (let ([odd-floats? (fxodd? num-members)]) + (if bsgl-offset + (let ([dbl-size (align 8 (fx- size 4))]) + (loop (cdr types) + (cons (load-stack-address bsgl-offset) locs) + iint (fx+ idbl amt) (if odd-floats? #f (+ bsgl-offset size)) int-reg-offset + (fx+ float-reg-offset dbl-size) stack-arg-offset)) + (let ([dbl-size (align 8 size)]) + (loop (cdr types) + (cons (load-stack-address float-reg-offset) locs) + iint (fx+ idbl amt) (and odd-floats? (fx+ float-reg-offset size)) int-reg-offset + (fx+ float-reg-offset dbl-size) stack-arg-offset)))) + (loop (cdr types) + (cons (load-stack-address stack-arg-offset) locs) + iint 8 #f int-reg-offset float-reg-offset (fx+ stack-arg-offset size))))] + [(fx= 8 ($ftd-alignment ftd)) + (let ([int-reg-offset (if (fxeven? iint) int-reg-offset (fx+ int-reg-offset 4))] + [iint (align 2 iint)] + [amt (fxsrl size 2)]) + (if (fx< iint 4) ; argument starts in registers, may continue on stack + (loop (cdr types) + (cons (load-stack-address int-reg-offset) locs) + (fxmin 4 (fx+ iint amt)) idbl bsgl-offset (fx+ int-reg-offset size) float-reg-offset + (fx+ stack-arg-offset (fxmax 0 (fx* 4 (fx- (fx+ iint amt) 4))))) + (let ([stack-arg-offset (align 8 stack-arg-offset)]) + (loop (cdr types) + (cons (load-stack-address stack-arg-offset) locs) + iint idbl bsgl-offset int-reg-offset float-reg-offset (fx+ stack-arg-offset size)))))] + [else + (let* ([size (align 4 size)] + [amt (fxsrl size 2)]) + (if (fx< iint 4) ; argument starts in registers, may continue on stack + (loop (cdr types) + (cons (load-stack-address int-reg-offset) locs) + (fxmin 4 (fx+ iint amt)) idbl bsgl-offset (fx+ int-reg-offset size) float-reg-offset + (fx+ stack-arg-offset (fxmax 0 (fx* 4 (fx- (fx+ iint amt) 4))))) + (loop (cdr types) + (cons (load-stack-address stack-arg-offset) locs) + iint idbl bsgl-offset int-reg-offset float-reg-offset (fx+ stack-arg-offset size))))]))] [else (if (nanopass-case (Ltype Type) (car types) [(fp-integer ,bits) (fx= bits 64)] [(fp-unsigned ,bits) (fx= bits 64)] [else #f]) - (let ([iint (align 2 iint)]) + (let ([int-reg-offset (if (fxeven? iint) int-reg-offset (fx+ int-reg-offset 4))] + [iint (align 2 iint)]) (if (fx= iint 4) (let ([stack-arg-offset (align 8 stack-arg-offset)]) (loop (cdr types) @@ -2611,44 +2911,127 @@ (loop (cdr types) (cons (load-int-stack (car types) int-reg-offset) locs) (fx+ iint 1) idbl bsgl-offset (fx+ int-reg-offset 4) float-reg-offset stack-arg-offset)))])))))) + (define do-result + (lambda (result-type synthesize-first? return-stack-offset) + (nanopass-case (Ltype Type) result-type + [(fp-ftd& ,ftd) + (let* ([members ($ftd->members ftd)] + [num-members (length members)]) + (cond + [(and (fx<= 1 num-members 4) + (or (andmap double-member? members) + (andmap float-member? members))) + ;; double/float results returned in floating-point registers + (values + (lambda () + (let ([double? (and (pair? members) (double-member? (car members)))]) + (let loop ([members members] [sgl* (sgl-regs)] [offset return-stack-offset] [e #f]) + (cond + [(null? members) e] + [else + (loop (cdr members) + (if double? (cddr sgl*) (cdr sgl*)) + (fx+ offset (if double? 8 4)) + (let ([new-e + `(inline ,(make-info-loadfl (car sgl*)) ,(if double? %load-double %load-single) + ,%sp ,%zero (immediate ,offset))]) + (if e `(seq ,e ,new-e) new-e)))])))) + '() + ($ftd-size ftd))] + [else + (case ($ftd-size ftd) + [(8) + (values (lambda () + `(seq + (set! ,%Cretval ,(%mref ,%sp ,return-stack-offset)) + (set! ,%r1 ,(%mref ,%sp ,(fx+ 4 return-stack-offset))))) + (list %Cretval %r1) + 8)] + [else + (values (lambda () + `(set! ,%Cretval ,(%mref ,%sp ,return-stack-offset))) + (list %Cretval %r1) + 4)])]))] + [(fp-double-float) + (values (lambda (rhs) + `(inline ,(make-info-loadfl %Cfpretval) ,%load-double + ,rhs ,%zero ,(%constant flonum-data-disp))) + '() + 0)] + [(fp-single-float) + (values (lambda (rhs) + `(inline ,(make-info-loadfl %Cfpretval) ,%load-double->single + ,rhs ,%zero ,(%constant flonum-data-disp))) + '() + 0)] + [(fp-void) + (values (lambda () `(nop)) + '() + 0)] + [else + (cond + [(nanopass-case (Ltype Type) result-type + [(fp-integer ,bits) (fx= bits 64)] + [(fp-unsigned ,bits) (fx= bits 64)] + [else #f]) + (values (lambda (lo hi) + `(seq + (set! ,%Cretval ,lo) + (set! ,%r1 ,hi))) + (list %Cretval %r1) + 0)] + [else + (values (lambda (x) + `(set! ,%Cretval ,x)) + (list %Cretval %r1) + 0)])]))) (lambda (info) (define callee-save-regs+lr (list %r4 %r5 %r6 %r7 %r8 %r9 %r10 %r11 %lr)) (define isaved (length callee-save-regs+lr)) - (let ([arg-type* (info-foreign-arg-type* info)] - [result-type (info-foreign-result-type info)]) - (let-values ([(iint idbl) (count-reg-args arg-type*)]) + (let* ([arg-type* (info-foreign-arg-type* info)] + [result-type (info-foreign-result-type info)] + [synthesize-first? (indirect-result-that-fits-in-registers? result-type)]) + (let-values ([(iint idbl) (count-reg-args arg-type* synthesize-first?)]) (let ([saved-reg-bytes (fx* isaved 4)] - [pad-bytes (if (fxeven? (fx+ isaved iint)) 0 4)] + [pre-pad-bytes (if (fxeven? isaved) 0 4)] [int-reg-bytes (fx* iint 4)] + [post-pad-bytes (if (fxeven? iint) 0 4)] [float-reg-bytes (fx* idbl 8)]) - (values - (lambda () - (%seq - ; save argument register values to the stack so we don't lose the values - ; across possible calls to C while setting up the tc and allocating memory - ,(if (fx= idbl 0) `(nop) `(inline ,(make-info-vpush %Cfparg1 idbl) ,%vpush-multiple)) - ,(if (fx= iint 0) `(nop) `(inline ,(make-info-kill*-live* '() (list-head (list %Carg1 %Carg2 %Carg3 %Carg4) iint)) ,%push-multiple)) - ; pad if necessary to force 8-byte boundardy after saving callee-save-regs+lr - ,(if (fx= pad-bytes 0) `(nop) `(set! ,%sp ,(%inline - ,%sp (immediate 4)))) - ; save the callee save registers & return address - (inline ,(make-info-kill*-live* '() callee-save-regs+lr) ,%push-multiple) - ; set up tc for benefit of argument-conversion code, which might allocate - ,(if-feature pthreads - (%seq - (set! ,%r0 ,(%inline get-tc)) - (set! ,%tc ,%r0)) - `(set! ,%tc (literal ,(make-info-literal #f 'entry (lookup-c-entry thread-context) 0)))))) - ; list of procedures that marshal arguments from their C stack locations - ; to the Scheme argument locations - (do-stack arg-type* saved-reg-bytes pad-bytes int-reg-bytes float-reg-bytes) - (lambda (fv* Scall->result-type) - (in-context Tail - (%seq - ; restore the callee save registers - (inline ,(make-info-kill* callee-save-regs+lr) ,%pop-multiple) - ; deallocate space for pad & arg reg values - (set! ,%sp ,(%inline + ,%sp (immediate ,(fx+ pad-bytes int-reg-bytes float-reg-bytes)))) - ; tail call the C helper that calls the Scheme procedure - (jump (literal ,(make-info-literal #f 'entry Scall->result-type 0)) - (,callee-save-regs+lr ... ,fv* ...)))))))))))))) + (let-values ([(get-result result-regs return-bytes) (do-result result-type synthesize-first? + (fx+ saved-reg-bytes pre-pad-bytes))]) + (let ([return-bytes (align 8 return-bytes)]) + (values + (lambda () + (%seq + ; save argument register values to the stack so we don't lose the values + ; across possible calls to C while setting up the tc and allocating memory + ,(if (fx= iint 0) `(nop) `(inline ,(make-info-kill*-live* '() (list-head (list %Carg1 %Carg2 %Carg3 %Carg4) iint)) ,%push-multiple)) + ; pad if necessary to force 8-byte boundary, and make room for indirect return: + ,(let ([len (+ post-pad-bytes return-bytes)]) + (if (fx= len 0) `(nop) `(set! ,%sp ,(%inline - ,%sp (immediate ,len))))) + ,(if (fx= idbl 0) `(nop) `(inline ,(make-info-vpush %Cfparg1 idbl) ,%vpush-multiple)) + ; pad if necessary to force 8-byte boundardy after saving callee-save-regs+lr + ,(if (fx= pre-pad-bytes 0) `(nop) `(set! ,%sp ,(%inline - ,%sp (immediate 4)))) + ; save the callee save registers & return address + (inline ,(make-info-kill*-live* '() callee-save-regs+lr) ,%push-multiple) + ; set up tc for benefit of argument-conversion code, which might allocate + ,(if-feature pthreads + (%seq + (set! ,%r0 ,(%inline get-tc)) + (set! ,%tc ,%r0)) + `(set! ,%tc (literal ,(make-info-literal #f 'entry (lookup-c-entry thread-context) 0)))))) + ; list of procedures that marshal arguments from their C stack locations + ; to the Scheme argument locations + (do-stack arg-type* saved-reg-bytes pre-pad-bytes return-bytes float-reg-bytes post-pad-bytes int-reg-bytes + synthesize-first?) + get-result + (lambda () + (in-context Tail + (%seq + ; restore the callee save registers + (inline ,(make-info-kill* callee-save-regs+lr) ,%pop-multiple) + ; deallocate space for pad & arg reg values + (set! ,%sp ,(%inline + ,%sp (immediate ,(fx+ pre-pad-bytes int-reg-bytes post-pad-bytes float-reg-bytes)))) + ; done + (asm-c-return ,null-info ,callee-save-regs+lr ... ,result-regs ...))))))))))))))) ) diff --git a/s/base-lang.ss b/s/base-lang.ss index 829c509c93..8a18331ca6 100644 --- a/s/base-lang.ss +++ b/s/base-lang.ss @@ -184,7 +184,7 @@ ; language of foreign types (define-language Ltype - (nongenerative-id #{Ltype czp82kxwe75y4e18-0}) + (nongenerative-id #{Ltype czp82kxwe75y4e18-1}) (terminals (exact-integer (bits)) ($ftd (ftd))) @@ -199,7 +199,8 @@ (fp-fixnum) (fp-double-float) (fp-single-float) - (fp-ftd ftd))) + (fp-ftd ftd) + (fp-ftd& ftd))) (define arity? (lambda (x) diff --git a/s/cmacros.ss b/s/cmacros.ss index f7b668fc01..b039789202 100644 --- a/s/cmacros.ss +++ b/s/cmacros.ss @@ -2633,16 +2633,7 @@ scan-remembered-set instantiate-code-object Sreturn - Scall->ptr - Scall->fptr - Scall->bytevector - Scall->fixnum - Scall->int32 - Scall->uns32 - Scall->double - Scall->single - Scall->int64 - Scall->uns64 - Scall->void + Scall-one-result + Scall-any-results )) ) diff --git a/s/cpnanopass.ss b/s/cpnanopass.ss index e3edbe1973..2ae10538e4 100644 --- a/s/cpnanopass.ss +++ b/s/cpnanopass.ss @@ -972,9 +972,19 @@ (fields type reversed? invertible?)) (define-record-type info-c-simple-call (nongenerative) + (parent info-kill*-live*) + (sealed #t) + (fields save-ra? entry) + (protocol + (lambda (new) + (case-lambda + [(save-ra? entry) ((new '() '()) save-ra? entry)] + [(live* save-ra? entry) ((new '() live*) save-ra? entry)])))) + + (define-record-type info-c-return (nongenerative) (parent info) (sealed #t) - (fields save-ra? entry)) + (fields offset)) (module () (record-writer (record-type-descriptor info-load) @@ -1857,7 +1867,7 @@ [(fcallable ,info) (let ([label (make-local-label 'fcallable)]) (set! gl* (cons label gl*)) - (set! gle* (cons (in-context CaseLambdaExpr `(fcallable ,info)) gle*)) + (set! gle* (cons (in-context CaseLambdaExpr `(fcallable ,info ,label)) gle*)) `(label-ref ,label 0))]) (nanopass-case (L6 CaseLambdaExpr) ir [(case-lambda ,info ,[CaseLambdaClause : cl #f -> cl] ...) @@ -2324,7 +2334,7 @@ [(fcallable ,info) (let ([label (make-local-label 'fcallable)]) (set! gl* (cons label gl*)) - (set! gle* (cons (in-context CaseLambdaExpr `(fcallable ,info)) gle*)) + (set! gle* (cons (in-context CaseLambdaExpr `(fcallable ,info ,label)) gle*)) `(label-ref ,label 0))] [(let ([,x* ,[e*]] ...) ,body) (with-offsets index x* @@ -10472,7 +10482,23 @@ (set! ,x ,t) ,(toC (in-context Rhs (%mref ,x ,(constant record-data-disp))))))] + [(fp-ftd& ,ftd) + (let ([x (make-tmp 't)]) + (%seq + (set! ,x ,t) + (set! ,x ,(%mref ,x ,(constant record-data-disp))) + ,(toC x)))] [else ($oops who "invalid parameter type specifier ~s" type)]))) + (define Scheme->C-for-result + (lambda (type toC t) + (nanopass-case (Ltype Type) type + [(fp-void) (toC)] + [(fp-ftd& ,ftd) + ;; pointer isn't received as a result, but instead passed + ;; to the function as its first argument (or simulated as such) + (toC)] + [else + (Scheme->C type toC t)]))) (define C->Scheme ; ASSUMPTIONS: ac0, ac1, and xp are not C argument registers (lambda (type fromC lvalue) @@ -10540,6 +10566,15 @@ ,(e1 `(goto ,Lbig)) (seq (label ,Lbig) ,e2))))) (e1 e2)))))) + (define (alloc-fptr ftd) + (%seq + (set! ,%xp + ,(%constant-alloc type-typed-object (fx* (constant ptr-bytes) 2) #f)) + (set! + ,(%mref ,%xp ,(constant record-type-disp)) + (literal ,(make-info-literal #f 'object ftd 0))) + (set! ,(%mref ,%xp ,(constant record-data-disp)) ,%ac0) + (set! ,lvalue ,%xp))) (nanopass-case (Ltype Type) type [(fp-void) `(set! ,lvalue ,(%constant svoid))] [(fp-scheme-object) (fromC lvalue)] @@ -10587,15 +10622,17 @@ (set! ,lvalue ,%xp))] [(fp-ftd ,ftd) (%seq - ,(fromC %ac0) ; C integer return might be wiped out by alloc - (set! ,%xp - ,(%constant-alloc type-typed-object (fx* (constant ptr-bytes) 2) #f)) - (set! - ,(%mref ,%xp ,(constant record-type-disp)) - (literal ,(make-info-literal #f 'object ftd 0))) - (set! ,(%mref ,%xp ,(constant record-data-disp)) ,%ac0) - (set! ,lvalue ,%xp))] + ,(fromC %ac0) ; C integer return might be wiped out by alloc + ,(alloc-fptr ftd))] + [(fp-ftd& ,ftd) + (%seq + ,(fromC %ac0) + ,(alloc-fptr ftd))] [else ($oops who "invalid result type specifier ~s" type)])))) + (define (pick-Scall result-type) + (nanopass-case (Ltype Type) result-type + [(fp-void) (lookup-c-entry Scall-any-results)] + [else (lookup-c-entry Scall-one-result)])) (define build-foreign-call (with-output-language (L13 Effect) (lambda (info t0 t1* maybe-lvalue new-frame?) @@ -10615,14 +10652,20 @@ (ccall t0) t1* arg-type* c-args)) ,(let ([e (deallocate)]) (if maybe-lvalue - `(seq ,(C->Scheme result-type c-res maybe-lvalue) ,e) + (nanopass-case (Ltype Type) result-type + [(fp-ftd& ,ftd) + ;; Don't actually return a value, because the result + ;; was instead installed in the first argument. + `(seq (set! ,maybe-lvalue ,(%constant svoid)) ,e)] + [else + `(seq ,(C->Scheme result-type c-res maybe-lvalue) ,e)]) e))))]) (if new-frame? (sorry! who "can't handle nontail foreign calls") e)))))) (define build-fcallable (with-output-language (L13 Tail) - (lambda (info) + (lambda (info self-label) (define set-locs (lambda (loc* t* ebody) (fold-right @@ -10640,14 +10683,11 @@ (cons (get-fv i) (f (cdr frame-x*) i)))))]) ; add 2 for the old RA and cchain (set! max-fv (fx+ max-fv 2)) - (let-values ([(c-init c-args c-scall) (asm-foreign-callable info)]) - ; c-init save C callee-save registers and restores tc + (let-values ([(c-init c-args c-result c-return) (asm-foreign-callable info)]) + ; c-init saves C callee-save registers and restores tc ; each of c-args sets a variable to one of the C arguments - ; c-scall restores callee-save registers and tail-calls C - ; Three reasons to tail call: - ; (1) let C deal with return value conversion - ; (2) avoid need to lock target code object - ; (3) let C deal with longjmp & cchain + ; c-result converts C results to Scheme values + ; c-return restores callee-save registers and returns to C (%seq ,(c-init) ,(restore-scheme-state @@ -10666,31 +10706,19 @@ ; cookie (0) will be replaced by the procedure, so this ; needs to be a quote, not an immediate (set! ,(ref-reg %ac1) (literal ,(make-info-literal #f 'object 0 0))) + (set! ,(ref-reg %ts) (label-ref ,self-label 0)) ; for locking ,(save-scheme-state - (in %ac0 %ac1) - (out %cp %xp %yp %ts %td scheme-args extra-regs)) - ,(c-scall fv* - (nanopass-case (Ltype Type) result-type - [(fp-scheme-object) (lookup-c-entry Scall->ptr)] - [(fp-void) (lookup-c-entry Scall->void)] - [(fp-fixnum) (lookup-c-entry Scall->fixnum)] - [(fp-integer ,bits) - (case bits - [(8 16 32) (lookup-c-entry Scall->int32)] - [(64) (lookup-c-entry Scall->int64)] - [else ($oops 'foreign-callable "unsupported result type specifier integer-~s" bits)])] - [(fp-unsigned ,bits) - (case bits - [(8 16 32) (lookup-c-entry Scall->uns32)] - [(64) (lookup-c-entry Scall->uns64)] - [else ($oops 'foreign-callable "unsupported result type specifier unsigned-~s" bits)])] - [(fp-double-float) (lookup-c-entry Scall->double)] - [(fp-single-float) (lookup-c-entry Scall->single)] - [(fp-u8*) (lookup-c-entry Scall->bytevector)] - [(fp-u16*) (lookup-c-entry Scall->bytevector)] - [(fp-u32*) (lookup-c-entry Scall->bytevector)] - [(fp-ftd ,ftd) (lookup-c-entry Scall->fptr)] - [else ($oops 'compiler-internal "invalid result type specifier ~s" result-type)])))))))))))) + (in %ac0 %ac1 %ts) + (out %cp %xp %yp %td scheme-args extra-regs)) + ; Scall-{any,one}-results calls the Scheme implementation of the + ; callable, locking this callable wrapper (as communicated in %ts) + ; until just before returning + (inline ,(make-info-c-simple-call fv* #f (pick-Scall result-type)) ,%c-simple-call) + ,(restore-scheme-state + (in %ac0) + (out %ac1 %cp %xp %yp %ts %td scheme-args extra-regs)) + ,(Scheme->C-for-result result-type c-result %ac0) + ,(c-return))))))))))) (define handle-do-rest (lambda (fixed-args offset save-asm-ra?) (with-output-language (L13 Effect) @@ -11002,11 +11030,11 @@ (safe-assert (nodups local*)) (for-each (lambda (local) (uvar-location-set! local #f)) local*) `(lambda ,info ,max-fv (,local* ...) ,tlbody))))] - [(fcallable ,info) + [(fcallable ,info ,l) (let ([lambda-info (make-info-lambda #f #f #f (list (length (info-foreign-arg-type* info))) (info-foreign-name info))]) (fluid-let ([max-fv 0] [local* '()]) - (let ([tlbody (build-fcallable info)]) + (let ([tlbody (build-fcallable info l)]) `(lambda ,lambda-info ,max-fv (,local* ...) ,tlbody))))] [(hand-coded ,sym) (case sym @@ -12497,6 +12525,10 @@ (let ([block (make-tail-block)]) (tail-block-tail-set! block (with-output-language (L15a Tail) `(asm-return ,reg* ...))) (values block (cons block block*)))] + [(asm-c-return ,info ,reg* ...) + (let ([block (make-tail-block)]) + (tail-block-tail-set! block (with-output-language (L15a Tail) `(asm-c-return ,info ,reg* ...))) + (values block (cons block block*)))] [else ($oops who "unexpected Tail ~s" ir)]) (Effect : Effect (ir target block*) -> * (target block*) [(nop) (values target block*)] @@ -13810,6 +13842,7 @@ [else (sorry! who "unrecognized block ~s" block)])))) (Tail : Tail (ir chunk* offset) -> * (code* chunk* offset) [(asm-return) (values (asm-return) chunk* offset)] + [(asm-c-return ,info) (values (asm-c-return info) chunk* offset)] [(jump (label-ref ,l ,offset0)) (values (asm-direct-jump l offset0) chunk* offset)] [(jump (literal ,info)) @@ -14095,6 +14128,9 @@ [(asm-return ,reg* ...) (safe-assert (eq? out no-live*)) (fold-left add-var no-live* reg*)] + [(asm-c-return ,info ,reg* ...) + (safe-assert (eq? out no-live*)) + (fold-left add-var no-live* reg*)] [(jump ,live-info ,t (,var* ...)) (let ([out (fold-left add-var out var*)]) (live-info-live-set! live-info out) @@ -14665,7 +14701,8 @@ (Pred : Pred (ir) -> Pred ()) (Tail : Tail (ir) -> Tail () [(jump ,live-info ,[t] (,var* ...)) `(jump ,live-info ,t)] - [(asm-return ,reg* ...) `(asm-return)]) + [(asm-return ,reg* ...) `(asm-return)] + [(asm-c-return ,info ,reg* ...) `(asm-c-return ,info)]) (Effect : Effect (ir) -> Effect ()) (foldable-Effect : Effect (ir new-effect*) -> * (new-effect*) [(return-point ,info ,rpl ,mrvl (,cnfv* ...)) @@ -15064,7 +15101,8 @@ (Tail : Tail (ir) -> Tail () [(jump ,live-info ,t) (handle-jump t (live-info-live live-info))] [(goto ,l) (values '() `(goto ,l))] - [(asm-return) (values '() `(asm-return))]) + [(asm-return) (values '() `(asm-return))] + [(asm-c-return ,info) (values '() `(asm-c-return ,info))]) (Effect : Effect (ir new-effect*) -> * (new-effect*) [(set! ,live-info ,lvalue ,rhs) (Rhs rhs lvalue new-effect* (live-info-live live-info))] [(inline ,live-info ,info ,effect-prim ,t* ...) diff --git a/s/cprep.ss b/s/cprep.ss index 2ed568961e..35cf39e1eb 100644 --- a/s/cprep.ss +++ b/s/cprep.ss @@ -115,7 +115,8 @@ [(fp-fixnum) 'fixnum] [(fp-double-float) 'double-float] [(fp-single-float) 'single-float] - [(fp-ftd ,ftd) 'ftype]))) + [(fp-ftd ,ftd) 'ftype] + [(fp-ftd& ,ftd) 'ftype]))) (define uncprep (lambda (x) (define keyword? diff --git a/s/ftype.ss b/s/ftype.ss index c49b866f4c..58376176e6 100644 --- a/s/ftype.ss +++ b/s/ftype.ss @@ -560,21 +560,32 @@ ftype operators: (define expand-fp-ftype (lambda (who what r ftype def-alist) (syntax-case ftype () - [(*-kwd ftype-name) - (and (eq? (datum *-kwd) '*) (identifier? #'ftype-name)) - (let ([stype (syntax->datum ftype)]) - (cond - [(assp (lambda (x) (bound-identifier=? #'ftype-name x)) def-alist) => - (lambda (a) - (if (ftd? (cdr a)) - (make-ftd-pointer rtd/fptr #f stype pointer-size pointer-alignment (cdr a)) - (let ([ftd (make-ftd-pointer rtd/fptr #f stype pointer-size pointer-alignment #f)]) - (set-cdr! a (cons ftd (cdr a))) - ftd)))] - [(expand-ftype-name r #'ftype-name #f) => - (lambda (ftd) - (make-ftd-pointer rtd/fptr #f stype pointer-size pointer-alignment ftd))] - [else (syntax-error #'ftype-name (format "unrecognized ~s ~s ftype name" who what))]))] + [(*/&-kwd ftype-name) + (and (or (eq? (datum */&-kwd) '*) + (eq? (datum */&-kwd) '&)) + (identifier? #'ftype-name)) + (let* ([stype (syntax->datum ftype)] + [ftd + (cond + [(assp (lambda (x) (bound-identifier=? #'ftype-name x)) def-alist) => + (lambda (a) + (if (ftd? (cdr a)) + (make-ftd-pointer rtd/fptr #f stype pointer-size pointer-alignment (cdr a)) + (let ([ftd (make-ftd-pointer rtd/fptr #f stype pointer-size pointer-alignment #f)]) + (set-cdr! a (cons ftd (cdr a))) + ftd)))] + [(expand-ftype-name r #'ftype-name #f) => + (lambda (ftd) + (make-ftd-pointer rtd/fptr #f stype pointer-size pointer-alignment ftd))] + [else (syntax-error #'ftype-name (format "unrecognized ~s ~s ftype name" who what))])]) + ;; Scheme-side argument is a pointer to a value, but foreign side has two variants: + (if (eq? (datum */&-kwd) '&) + (cond + [(ftd-array? (ftd-pointer-ftd ftd)) + (syntax-error ftype (format "array value invalid as ~a ~s" who what))] + [else + (box ftd)]) ; boxed ftd => pass/receive the value (as opposed to a pointer to the value) + ftd))] ; plain ftd => pass/receive a pointer to the value [_ (cond [(and (identifier? ftype) (expand-ftype-name r ftype #f)) => (lambda (ftd) @@ -586,11 +597,14 @@ ftype operators: [else (syntax->datum ftype)])]))) (define-who indirect-ftd-pointer (lambda (x) - (if (ftd? x) - (if (ftd-pointer? x) - (ftd-pointer-ftd x) - ($oops who "~s is not an ftd-pointer" x)) - x))) + (cond + [(ftd? x) + (if (ftd-pointer? x) + (ftd-pointer-ftd x) + ($oops who "~s is not an ftd-pointer" x))] + [(box? x) + (box (indirect-ftd-pointer (unbox x)))] + [else x]))) (define-who expand-ftype-defns (lambda (r defid* ftype*) (define patch-pointer-ftds! @@ -929,6 +943,74 @@ ftype operators: (set! $ftd? (lambda (x) (ftd? x))) + (set! $ftd-as-box? ; represents `(& )` from `$expand-fp-ftype` + (lambda (x) + (and (box? x) (ftd? (unbox x))))) + (set! $ftd-size + (lambda (x) + (ftd-size x))) + (set! $ftd-alignment + (lambda (x) + (ftd-alignment x))) + (set! $ftd-compound? + (lambda (x) + (or (ftd-struct? x) + (ftd-union? x) + (ftd-array? x)))) + (set! $ftd->members + (lambda (x) + ;; Currently used for x86_64 and arm32 ABI: Returns a list of + ;; (list 'integer/'float size offset) + (let loop ([x x] [offset 0] [accum '()]) + (cond + [(ftd-base? x) + (cons (list (case (ftd-base-type x) + [(double double-float float single-float) + 'float] + [else 'integer]) + (ftd-size x) + offset) + accum)] + [(ftd-struct? x) + (let struct-loop ([field* (ftd-struct-field* x)] [accum accum]) + (cond + [(null? field*) accum] + [else (let* ([fld (car field*)] + [sub-ftd (caddr fld)] + [sub-offset (cadr fld)]) + (struct-loop (cdr field*) + (loop sub-ftd (+ offset sub-offset) accum)))]))] + [(ftd-union? x) + (let union-loop ([field* (ftd-union-field* x)] [accum accum]) + (cond + [(null? field*) accum] + [else (let* ([fld (car field*)] + [sub-ftd (cdr fld)]) + (union-loop (cdr field*) + (loop sub-ftd offset accum)))]))] + [(ftd-array? x) + (let ([elem-ftd (ftd-array-ftd x)]) + (let array-loop ([len (ftd-array-length x)] [offset offset] [accum accum]) + (cond + [(fx= len 0) accum] + [else (array-loop (fx- len 1) + (+ offset (ftd-size elem-ftd)) + (loop elem-ftd offset accum))])))] + [else (cons (list 'integer (ftd-size x) offset) accum)])))) + (set! $ftd-atomic-category + (lambda (x) + ;; Currently used for PowerPC32 ABI + (cond + [(ftd-base? x) + (case (ftd-base-type x) + [(double double-float float single-float) + 'float] + [(unsigned-short unsigned unsigned-int + unsigned-long unsigned-long-long + unsigned-8 unsigned-16 unsigned-32 unsigned-64) + 'unsigned] + [else 'integer])] + [else 'integer]))) (set! $expand-fp-ftype ; for foreign-procedure, foreign-callable (lambda (who what r ftype) (indirect-ftd-pointer diff --git a/s/np-languages.ss b/s/np-languages.ss index c6e9de1cb9..a46a315366 100644 --- a/s/np-languages.ss +++ b/s/np-languages.ss @@ -416,7 +416,7 @@ (Program (prog) (+ (labels ([l* le*] ...) l) => (labels ([l* le*] ...) (l)))) (CaseLambdaExpr (le) - (+ (fcallable info) => (fcallable info))) + (+ (fcallable info l) => (fcallable info l))) (Lvalue (lvalue) (+ x (mref e1 e2 imm))) @@ -488,10 +488,13 @@ (declare-primitive asmlibcall! effect #f) (declare-primitive c-call effect #f) (declare-primitive c-simple-call effect #f) + (declare-primitive c-simple-return effect #f) (declare-primitive fl* effect #f) (declare-primitive fl+ effect #f) (declare-primitive fl- effect #f) (declare-primitive fl/ effect #f) + (declare-primitive fldl effect #f) ; x86 + (declare-primitive flds effect #f) ; x86 (declare-primitive flsqrt effect #f) ; not implemented for some ppc32 (so we don't use it) (declare-primitive flt effect #f) (declare-primitive inc-cc-counter effect #f) @@ -544,6 +547,7 @@ (declare-primitive -/eq value #f) (declare-primitive asmlibcall value #f) (declare-primitive fstpl value #f) ; x86 only + (declare-primitive fstps value #f) ; x86 only (declare-primitive get-double value #t) ; x86_64 (declare-primitive get-tc value #f) ; threaded version only (declare-primitive lea1 value #t) @@ -849,6 +853,7 @@ (jump t (var* ...)) (joto l (nfv* ...)) (asm-return reg* ...) + (asm-c-return info reg* ...) (if p0 tl1 tl2) (seq e0 tl1) (goto l))) @@ -961,7 +966,8 @@ (Tail (tl) (goto l) (jump live-info t (var* ...)) - (asm-return reg* ...))) + (asm-return reg* ...) + (asm-c-return info reg* ...))) (define-language L15b (extends L15a) (terminals @@ -979,9 +985,11 @@ (+ (fp-offset live-info imm))) (Tail (tl) (- (jump live-info t (var* ...)) - (asm-return reg* ...)) + (asm-return reg* ...) + (asm-c-return info reg* ...)) (+ (jump live-info t) - (asm-return)))) + (asm-return) + (asm-c-return info)))) (define ur? (lambda (x) diff --git a/s/ppc32.ss b/s/ppc32.ss index 4bcbe8f8f9..472605f76c 100644 --- a/s/ppc32.ss +++ b/s/ppc32.ss @@ -810,7 +810,7 @@ asm-lock asm-lock+/- asm-fl-load/store asm-flop-2 asm-c-simple-call - asm-save-flrv asm-restore-flrv asm-return asm-size + asm-save-flrv asm-restore-flrv asm-return asm-c-return asm-size asm-enter asm-foreign-call asm-foreign-callable asm-read-counter asm-read-time-base @@ -2077,6 +2077,10 @@ (lambda () (emit blr '()))) + (define asm-c-return + (lambda (info) + (emit blr '()))) + (define asm-lognot (lambda (code* dest src) (Trivit (dest src) @@ -2129,19 +2133,27 @@ (define align (lambda (b x) (let ([k (- b 1)]) (fxlogand (fx+ x k) (fxlognot k))))) (define gp-parameter-regs (lambda () (list %Carg1 %Carg2 %Carg3 %Carg4 %Carg5 %Carg6 %Carg7 %Carg8))) (define fp-parameter-regs (lambda () (list %Cfparg1 %Cfparg2 %Cfparg3 %Cfparg4 %Cfparg5 %Cfparg6 %Cfparg7 %Cfparg8))) + (define (indirect-result-that-fits-in-registers? result-type) + (nanopass-case (Ltype Type) result-type + [(fp-ftd& ,ftd) (not ($ftd-compound? ftd))] + [else #f])) + (define (indirect-result-to-pointer? result-type) + (nanopass-case (Ltype Type) result-type + [(fp-ftd& ,ftd) ($ftd-compound? ftd)] + [else #f])) (define-who asm-foreign-call (with-output-language (L13 Effect) (define load-double-stack - (lambda (offset) + (lambda (offset fp-disp) (lambda (x) ; requires var (%seq - (inline ,(make-info-loadfl %flreg1) ,%load-double ,x ,%zero ,(%constant flonum-data-disp)) + (inline ,(make-info-loadfl %flreg1) ,%load-double ,x ,%zero (immediate ,fp-disp)) (inline ,(make-info-loadfl %flreg1) ,%store-double ,%sp ,%zero (immediate ,offset)))))) (define load-single-stack - (lambda (offset) + (lambda (offset fp-disp single?) (lambda (x) ; requires var (%seq - (inline ,(make-info-loadfl %flreg1) ,%load-double->single ,x ,%zero ,(%constant flonum-data-disp)) + (inline ,(make-info-loadfl %flreg1) ,(if single? %load-single %load-double->single) ,x ,%zero (immediate ,fp-disp)) (inline ,(make-info-loadfl %flreg1) ,%store-single ,%sp ,%zero (immediate ,offset)))))) (define load-int-stack (lambda (offset) @@ -2153,25 +2165,39 @@ (%seq (set! ,(%mref ,%sp ,(fx+ offset 4)) ,lorhs) (set! ,(%mref ,%sp ,offset) ,hirhs))))) - (define load-double-reg - (lambda (fpreg) + (define load-indirect-int-stack + (lambda (offset size) + (lambda (rhs) ; requires rhs + (let ([int-type (case size + [(1) 'integer-8] + [(2) 'integer-16] + [else 'integer-32])]) + `(set! ,(%mref ,%sp ,offset) (inline ,(make-info-load int-type #f) ,%load ,rhs ,%zero (immediate ,0))))))) + (define load-indirect-int64-stack + (lambda (offset) (lambda (x) ; requires var - `(inline ,(make-info-loadfl fpreg) ,%load-double ,x ,%zero ,(%constant flonum-data-disp))))) + `(seq + (set! ,(%mref ,%sp ,offset) ,(%mref ,x 0)) + (set! ,(%mref ,%sp ,(fx+ offset 4)) ,(%mref ,x 4)))))) + (define load-double-reg + (lambda (fpreg fp-disp) + (lambda (x) ; requires var + `(inline ,(make-info-loadfl fpreg) ,%load-double ,x ,%zero (immediate ,fp-disp))))) (define load-soft-double-reg - (lambda (loreg hireg) + (lambda (loreg hireg fp-disp) (lambda (x) (%seq - (set! ,loreg ,(%mref ,x ,(fx+ (constant flonum-data-disp) 4))) - (set! ,hireg ,(%mref ,x ,(constant flonum-data-disp))))))) + (set! ,loreg ,(%mref ,x ,(fx+ fp-disp 4))) + (set! ,hireg ,(%mref ,x ,fp-disp)))))) (define load-single-reg - (lambda (fpreg) + (lambda (fpreg fp-disp single?) (lambda (x) ; requires var - `(inline ,(make-info-loadfl fpreg) ,%load-double->single ,x ,%zero ,(%constant flonum-data-disp))))) + `(inline ,(make-info-loadfl fpreg) ,(if single? %load-single %load-double->single) ,x ,%zero (immediate ,fp-disp))))) (define load-soft-single-reg - (lambda (ireg) + (lambda (ireg fp-disp single?) (lambda (x) (%seq - (inline ,(make-info-loadfl %flreg1) ,%load-double->single ,x ,%zero ,(%constant flonum-data-disp)) + (inline ,(make-info-loadfl %flreg1) ,(if single? %load-single %load-double->single) ,x ,%zero (immediate ,fp-disp)) (inline ,(make-info-loadfl %flreg1) ,%store-single ,%tc ,%zero (immediate ,(constant tc-ac0-disp))) (set! ,ireg ,(%tc-ref ac0)))))) (define load-int-reg @@ -2184,10 +2210,31 @@ (%seq (set! ,loreg ,lo) (set! ,hireg ,hi))))) + (define load-indirect-int-reg + (lambda (ireg size category) + (lambda (rhs) ; requires var + (let ([int-type (case category + [(unsigned) (case size + [(1) 'unsigned-8] + [(2) 'unsigned-16] + [else 'unsigned-32])] + [else (case size + [(1) 'integer-8] + [(2) 'integer-16] + [else 'integer-32])])]) + `(set! ,ireg (inline ,(make-info-load int-type #f) ,%load ,rhs ,%zero (immediate ,0))))))) + (define load-indirect-int64-reg + (lambda (loreg hireg) + (lambda (x) ; requires var + `(seq + (set! ,hireg ,(%mref ,x 0)) + (set! ,loreg ,(%mref ,x 4)))))) (define do-args (lambda (types) ;; NB: start stack pointer at 8 to put arguments above the linkage area - (let loop ([types types] [locs '()] [live* '()] [int* (gp-parameter-regs)] [flt* (fp-parameter-regs)] [isp 8]) + (let loop ([types types] [locs '()] [live* '()] [int* (gp-parameter-regs)] [flt* (fp-parameter-regs)] [isp 8] + ;; configured for `ftd-fp&` unpacking of floats: + [fp-disp (constant flonum-data-disp)] [single? #f]) (if (null? types) (values isp locs live*) (nanopass-case (Ltype Type) (car types) @@ -2197,38 +2244,91 @@ (if (null? int*) (let ([isp (align 8 isp)]) (loop (cdr types) - (cons (load-double-stack isp) locs) - live* '() flt* (fx+ isp 8))) + (cons (load-double-stack isp fp-disp) locs) + live* '() flt* (fx+ isp 8) + (constant flonum-data-disp) #f)) (loop (cdr types) - (cons (load-soft-double-reg (cadr int*) (car int*)) locs) - (cons* (car int*) (cadr int*) live*) (cddr int*) flt* isp))) + (cons (load-soft-double-reg (cadr int*) (car int*) fp-disp) locs) + (cons* (car int*) (cadr int*) live*) (cddr int*) flt* isp + (constant flonum-data-disp) #f))) (if (null? flt*) (let ([isp (align 8 isp)]) (loop (cdr types) - (cons (load-double-stack isp) locs) - live* int* '() (fx+ isp 8))) + (cons (load-double-stack isp fp-disp) locs) + live* int* '() (fx+ isp 8) + (constant flonum-data-disp) #f)) (loop (cdr types) - (cons (load-double-reg (car flt*)) locs) - live* int* (cdr flt*) isp)))] + (cons (load-double-reg (car flt*) fp-disp) locs) + live* int* (cdr flt*) isp + (constant flonum-data-disp) #f)))] [(fp-single-float) (if (constant software-floating-point) (if (null? int*) ; NB: ABI says singles are passed as doubles on the stack, but gcc/linux doesn't (loop (cdr types) - (cons (load-single-stack isp) locs) - live* '() flt* (fx+ isp 4)) + (cons (load-single-stack isp fp-disp single?) locs) + live* '() flt* (fx+ isp 4) + (constant flonum-data-disp) #f) (loop (cdr types) - (cons (load-soft-single-reg (car int*)) locs) - (cons (car int*) live*) (cdr int*) flt* isp)) + (cons (load-soft-single-reg (car int*) fp-disp single?) locs) + (cons (car int*) live*) (cdr int*) flt* isp + (constant flonum-data-disp) #f)) (if (null? flt*) ; NB: ABI says singles are passed as doubles on the stack, but gcc/linux doesn't (let ([isp (align 4 isp)]) (loop (cdr types) - (cons (load-single-stack isp) locs) - live* int* '() (fx+ isp 4))) + (cons (load-single-stack isp fp-disp single?) locs) + live* int* '() (fx+ isp 4) + (constant flonum-data-disp) #f)) (loop (cdr types) - (cons (load-single-reg (car flt*)) locs) - live* int* (cdr flt*) isp)))] + (cons (load-single-reg (car flt*) fp-disp single?) locs) + live* int* (cdr flt*) isp + (constant flonum-data-disp) #f)))] + [(fp-ftd& ,ftd) + (cond + [($ftd-compound? ftd) + ;; pass as pointer + (let ([pointer-type (with-output-language (Ltype Type) `(fp-integer 32))]) + (loop (cons pointer-type (cdr types)) locs live* int* flt* isp + (constant flonum-data-disp) #f))] + [else + ;; extract content and pass that content + (let ([category ($ftd-atomic-category ftd)]) + (cond + [(eq? category 'float) + ;; piggy-back on unboxed handler + (let ([unpacked-type (with-output-language (Ltype Type) + (case ($ftd-size ftd) + [(4) `(fp-single-float)] + [else `(fp-double-float)]))]) + (loop (cons unpacked-type (cdr types)) locs live* int* flt* isp + ;; no floating displacement within pointer: + 0 + ;; in case of float, load as single-float: + (= ($ftd-size ftd) 4)))] + [(and (memq category '(integer unsigned)) + (fx= 8 ($ftd-size ftd))) + (let ([int* (if (even? (length int*)) int* (cdr int*))]) + (if (null? int*) + (let ([isp (align 8 isp)]) + (loop (cdr types) + (cons (load-indirect-int64-stack isp) locs) + live* '() flt* (fx+ isp 8) + (constant flonum-data-disp) #f)) + (loop (cdr types) + (cons (load-indirect-int64-reg (cadr int*) (car int*)) locs) + (cons* (car int*) (cadr int*) live*) (cddr int*) flt* isp + (constant flonum-data-disp) #f)))] + [else + (if (null? int*) + (loop (cdr types) + (cons (load-indirect-int-stack isp ($ftd-size ftd)) locs) + live* '() flt* (fx+ isp 4) + (constant flonum-data-disp) #f) + (loop (cdr types) + (cons (load-indirect-int-reg (car int*) ($ftd-size ftd) category) locs) + (cons (car int*) live*) (cdr int*) flt* isp + (constant flonum-data-disp) #f))]))])] [else (if (nanopass-case (Ltype Type) (car types) [(fp-integer ,bits) (fx= bits 64)] @@ -2239,28 +2339,59 @@ (let ([isp (align 8 isp)]) (loop (cdr types) (cons (load-int64-stack isp) locs) - live* '() flt* (fx+ isp 8))) + live* '() flt* (fx+ isp 8) + (constant flonum-data-disp) #f)) (loop (cdr types) (cons (load-int64-reg (cadr int*) (car int*)) locs) - (cons* (car int*) (cadr int*) live*) (cddr int*) flt* isp))) + (cons* (car int*) (cadr int*) live*) (cddr int*) flt* isp + (constant flonum-data-disp) #f))) (if (null? int*) (loop (cdr types) (cons (load-int-stack isp) locs) - live* '() flt* (fx+ isp 4)) + live* '() flt* (fx+ isp 4) + (constant flonum-data-disp) #f) (loop (cdr types) (cons (load-int-reg (car int*)) locs) - (cons (car int*) live*) (cdr int*) flt* isp)))]))))) + (cons (car int*) live*) (cdr int*) flt* isp + (constant flonum-data-disp) #f)))]))))) + (define do-indirect-result-from-registers + (lambda (ftd offset) + (let ([tmp %Carg8]) + (%seq + (set! ,tmp ,(%mref ,%sp ,offset)) + ,(cond + [(and (not (constant software-floating-point)) + (eq? 'float ($ftd-atomic-category ftd))) + `(inline ,(make-info-loadfl %Cfpretval) ,(if (= 4 ($ftd-size ftd)) %store-single %store-double) + ,tmp ,%zero (immediate 0))] + [else + (case ($ftd-size ftd) + [(1) `(inline ,(make-info-load 'integer-8 #f) ,%store ,tmp ,%zero (immediate 0) ,%Cretval)] + [(2) `(inline ,(make-info-load 'integer-16 #f) ,%store ,tmp ,%zero (immediate 0) ,%Cretval)] + [(4) `(inline ,(make-info-load 'integer-32 #f) ,%store ,tmp ,%zero (immediate 0) ,%Cretval)] + [(8) + (%seq + (inline ,(make-info-load 'integer-32 #f) ,%store ,tmp ,%zero (immediate 0) ,%Cretval-high) + (inline ,(make-info-load 'integer-32 #f) ,%store ,tmp ,%zero (immediate 4) ,%Cretval-low))] + [else (sorry! who "unexpected result size")])]))))) (lambda (info) (safe-assert (reg-callee-save? %tc)) ; no need to save-restore - (let ([arg-type* (info-foreign-arg-type* info)] - [result-type (info-foreign-result-type info)]) - (with-values (do-args arg-type*) - (lambda (frame-size locs live*) + (let* ([arg-type* (info-foreign-arg-type* info)] + [result-type (info-foreign-result-type info)] + [fill-result-here? (indirect-result-that-fits-in-registers? result-type)]) + (with-values (do-args (if fill-result-here? (cdr arg-type*) arg-type*)) + (lambda (orig-frame-size locs live*) ;; NB: add 4 to frame size for CR save word - (let ([frame-size (align 16 (fx+ frame-size 4))]) + (let ([fill-stash-offset orig-frame-size] + [frame-size (align 16 (fx+ orig-frame-size 4 (if fill-result-here? 4 0)))]) (values (lambda () (%inline store-with-update ,%Csp ,%Csp (immediate ,(fx- frame-size)))) - (reverse locs) + (let ([locs (reverse locs)]) + (cond + [fill-result-here? + ;; stash extra argument on the stack to be retrieved after call and filled with the result: + (cons (load-int-stack fill-stash-offset) locs)] + [else locs])) (lambda (t0) (if (constant software-floating-point) (let () @@ -2276,11 +2407,21 @@ [(8 16 32) (handle-32-bit)] [(64) (handle-64-bit)] [else (sorry! who "unexpected asm-foriegn-procedures fp-integer size ~s" bits)]))) + (define (handle-ftd&-case ftd) + (cond + [fill-result-here? + (%seq + ,(if (> ($ftd-size ftd) 4) + (handle-64-bit) + (handle-32-bit)) + ,(do-indirect-result-from-registers ftd fill-stash-offset))] + [else `(inline ,(make-info-kill*-live* (reg-list) live*) ,%c-call ,t0)])) (nanopass-case (Ltype Type) result-type [(fp-double-float) (handle-64-bit)] [(fp-single-float) (handle-32-bit)] [(fp-integer ,bits) (handle-integer-cases bits)] [(fp-integer ,bits) (handle-integer-cases bits)] + [(fp-ftd& ,ftd) (handle-ftd&-case ftd)] [else `(inline ,(make-info-kill*-live* (reg-list %Cretval) live*) ,%c-call ,t0)])) (let () (define handle-integer-cases @@ -2288,12 +2429,22 @@ (case bits [(8 16 32) `(inline ,(make-info-kill*-live* (reg-list %Cretval) live*) ,%c-call ,t0)] [(64) `(inline ,(make-info-kill*-live* (reg-list %Cretval-high %Cretval-low) live*) ,%c-call ,t0)] - [else (sorry! who "unexpected asm-foreign-procedures fp-integer size ~s" bits)]))) + [else (sorry! who "unexpected asm-foreign-procedures fp-integer size ~s" bits)]))) + (define (handle-ftd&-case ftd) + (cond + [fill-result-here? + (%seq + ,(if (not (eq? 'float ($ftd-atomic-category ftd))) + (handle-integer-cases (* 8 ($ftd-size ftd))) + `(inline ,(make-info-kill*-live* (reg-list) live*) ,%c-call ,t0)) + ,(do-indirect-result-from-registers ftd fill-stash-offset))] + [else `(inline ,(make-info-kill*-live* (reg-list) live*) ,%c-call ,t0)])) (nanopass-case (Ltype Type) result-type [(fp-double-float) `(inline ,(make-info-kill*-live* (reg-list) live*) ,%c-call ,t0)] [(fp-single-float) `(inline ,(make-info-kill*-live* (reg-list) live*) ,%c-call ,t0)] [(fp-integer ,bits) (handle-integer-cases bits)] [(fp-unsigned ,bits) (handle-integer-cases bits)] + [(fp-ftd& ,ftd) (handle-ftd&-case ftd)] [else `(inline ,(make-info-kill*-live* (reg-list %Cretval) live*) ,%c-call ,t0)])))) (nanopass-case (Ltype Type) result-type [(fp-double-float) @@ -2396,40 +2547,36 @@ +---------------------------+ | | | lr | 1 word - sp+184: | | + sp+X+4: | | +---------------------------+ | | | back chain | 1 word - sp+180: | | + sp+X: | | +---------------------------+ + +---------------------------+ <- 16-byte aligned + | | + | &-return space | 2 words, if needed + | | + +---------------------------+ <- 8-byte aligned + | | + | callee-save regs | + | | +---------------------------+ | | - | floating-point regs | 0 words - sp+180: | | - +---------------------------+ + | floating-point arg regs | | | - | integer regs | 18 words - sp+108: | | - +---------------------------+ + +---------------------------+ <- 8-byte aligned | | - | control register | 1 word - sp+104: | | - +---------------------------+ + | integer argument regs | | | - | local variable space | 24 words: 8 words for gp arg regs, 8 double words for fp arg regs, 0 for padding - sp+8: | (and padding) | - +---------------------------+ - | | - | parameter list | 0 words - sp+8: | | - +---------------------------+ + sp+8: +---------------------------+ <-- 8-byte aligned | | | lr | 1 word (place for get-thread-context to store lr) - sp+4: | | + | | +---------------------------+ | | | back chain | 1 word - sp+0: | [sp+176] | + sp+0: | [sp+X-4] | +---------------------------+ FOR foreign callable (nb: assuming flreg1 & flreg2 are caller-save): @@ -2438,14 +2585,14 @@ save fp arg regs (based on number declared by foreign-callable form) at sp+40 don't bother saving cr save callee-save gp registers at sp+108 (could avoid those we don't use during argument conversion, if we knew what they were) - save lr at sp[180] (actually sp 4, before sp is moved) + save lr at sp[188] (actually sp 4, before sp is moved) if threaded: call get-thread-context else tc <- thread-context endif ... - restore lr from sp[180] + restore lr from sp[188] INVARIANTS stack grows down @@ -2488,9 +2635,22 @@ (%seq (set! ,lolvalue ,(%mref ,%sp ,(fx+ offset 4))) (set! ,hilvalue ,(%mref ,%sp ,offset)))))) + (define load-stack-address + (lambda (offset) + (lambda (lvalue) + `(set! ,lvalue ,(%inline + ,%sp (immediate ,offset)))))) + (define load-stack-address/convert-float + (lambda (offset) + (lambda (lvalue) + (%seq + ;; Overwrite argument on stack with single-precision version + ;; FIXME: is the callee allowed to do this if the argument is passed on the stack? + (inline ,(make-info-loadfl %flreg1) ,%load-double->single ,%sp ,%zero (immediate ,offset)) + (inline ,(make-info-loadfl %flreg1) ,%store-single ,%sp ,%zero (immediate ,offset)) + (set! ,lvalue ,(%inline + ,%sp (immediate ,offset))))))) (define count-reg-args - (lambda (types gp-reg-count fp-reg-count) - (let f ([types types] [iint 0] [iflt 0]) + (lambda (types gp-reg-count fp-reg-count synthesize-first-argument?) + (let f ([types types] [iint (if synthesize-first-argument? -1 0)] [iflt 0]) (if (null? types) (values iint iflt) (cond @@ -2498,11 +2658,14 @@ (nanopass-case (Ltype Type) (car types) [(fp-double-float) #t] [(fp-single-float) #t] + [(fp-ftd& ,ftd) (eq? 'float ($ftd-atomic-category ftd))] [else #f])) (f (cdr types) iint (if (fx< iflt fp-reg-count) (fx+ iflt 1) iflt))] [(or (nanopass-case (Ltype Type) (car types) [(fp-integer ,bits) (fx= bits 64)] [(fp-unsigned ,bits) (fx= bits 64)] + [(fp-ftd& ,ftd) (and (not ($ftd-compound? ftd)) + (fx= 8 ($ftd-size ftd)))] [else #f]) (and (constant software-floating-point) (nanopass-case (Ltype Type) (car types) @@ -2515,8 +2678,9 @@ ; all of the args are on the stack at this point, though not contiguous since ; we push all of the int reg args with one push instruction and all of the ; float reg args with another (v)push instruction - (lambda (types gp-reg-count fp-reg-count int-reg-offset float-reg-offset stack-arg-offset) - (let loop ([types types] + (lambda (types gp-reg-count fp-reg-count int-reg-offset float-reg-offset stack-arg-offset + synthesize-first-argument? return-space-offset) + (let loop ([types (if synthesize-first-argument? (cdr types) types)] [locs '()] [iint 0] [iflt 0] @@ -2524,7 +2688,11 @@ [float-reg-offset float-reg-offset] [stack-arg-offset stack-arg-offset]) (if (null? types) - (reverse locs) + (let ([locs (reverse locs)]) + (if synthesize-first-argument? + (cons (load-stack-address return-space-offset) + locs) + locs)) (cond [(and (not (constant software-floating-point)) (nanopass-case (Ltype Type) (car types) @@ -2564,7 +2732,49 @@ (loop (cdr types) (cons (load-soft-single-stack stack-arg-offset) locs) iint iflt int-reg-offset float-reg-offset (fx+ stack-arg-offset 4)))] - [(nanopass-case (Ltype Type) (car types) + [(nanopass-case (Ltype Type) (car types) + [(fp-ftd& ,ftd) (not ($ftd-compound? ftd))] + [else #f]) + ;; load pointer to address on the stack + (let ([ftd (nanopass-case (Ltype Type) (car types) + [(fp-ftd& ,ftd) ftd])]) + (case (and (not (constant software-floating-point)) + ($ftd-atomic-category ftd)) + [(float) + (let ([load-address (case ($ftd-size ftd) + [(4) load-stack-address/convert-float] + [else load-stack-address])]) + (if (fx< iflt fp-reg-count) + (loop (cdr types) + (cons (load-address float-reg-offset) locs) + iint (fx+ iflt 1) int-reg-offset (fx+ float-reg-offset 8) stack-arg-offset) + (let ([stack-arg-offset (align 8 stack-arg-offset)]) + (loop (cdr types) + (cons (load-address stack-arg-offset) locs) + iint iflt int-reg-offset float-reg-offset (fx+ stack-arg-offset 8)))))] + [else + (case ($ftd-size ftd) + [(8) + (let ([iint (align 2 iint)]) + (if (fx< iint gp-reg-count) + (let ([int-reg-offset (align 8 int-reg-offset)]) + (loop (cdr types) + (cons (load-stack-address int-reg-offset) locs) + (fx+ iint 2) iflt (fx+ int-reg-offset 8) float-reg-offset stack-arg-offset)) + (let ([stack-arg-offset (align 8 stack-arg-offset)]) + (loop (cdr types) + (cons (load-stack-address stack-arg-offset) locs) + iint iflt int-reg-offset float-reg-offset (fx+ stack-arg-offset 8)))))] + [else + (let ([byte-offset (- 4 ($ftd-size ftd))]) + (if (fx< iint gp-reg-count) + (loop (cdr types) + (cons (load-stack-address (+ int-reg-offset byte-offset)) locs) + (fx+ iint 1) iflt (fx+ int-reg-offset 4) float-reg-offset stack-arg-offset) + (loop (cdr types) + (cons (load-stack-address (+ stack-arg-offset byte-offset)) locs) + iint iflt int-reg-offset float-reg-offset (fx+ stack-arg-offset 4))))])]))] + [(nanopass-case (Ltype Type) (car types) [(fp-integer ,bits) (fx= bits 64)] [(fp-unsigned ,bits) (fx= bits 64)] [else #f]) @@ -2616,48 +2826,114 @@ (if (null? regs) inline (%seq ,inline ,(f regs (fx+ offset 4)))))))))) + (define do-result + (lambda (result-type return-space-offset int-reg-offset) + (nanopass-case (Ltype Type) result-type + [(fp-ftd& ,ftd) + (case ($ftd-atomic-category ftd) + [(float) + (values + (lambda () + (case ($ftd-size ftd) + [(4) `(inline ,(make-info-loadfl %Cfpretval) ,%load-single ,%sp ,%zero (immediate ,return-space-offset))] + [else `(inline ,(make-info-loadfl %Cfpretval) ,%load-double ,%sp ,%zero (immediate ,return-space-offset))])) + '())] + [else + (cond + [($ftd-compound? ftd) + ;; return pointer + (values + (lambda () `(set! ,%Cretval ,(%mref ,%sp ,int-reg-offset))) + (list %Cretval))] + [(fx= 8 ($ftd-size ftd)) + (values (lambda () + (%seq + (set! ,%Cretval-high ,(%mref ,%sp ,return-space-offset)) + (set! ,%Cretval-low ,(%mref ,%sp ,(fx+ return-space-offset 4))))) + (list %Cretval-high %Cretval-low))] + [else + (values + (lambda () + (case ($ftd-size ftd) + [(1) `(set! ,%Cretval (inline ,(make-info-load 'integer-8 #f) ,%load ,%sp ,%zero (immediate ,return-space-offset)))] + [(2) `(set! ,%Cretval (inline ,(make-info-load 'integer-16 #f) ,%load ,%sp ,%zero (immediate ,return-space-offset)))] + [else `(set! ,%Cretval ,(%mref ,%sp ,return-space-offset))])) + (list %Cretval))])])] + [(fp-double-float) + (values (lambda (x) + `(inline ,(make-info-loadfl %Cfpretval) ,%load-double ,x ,%zero ,(%constant flonum-data-disp))) + '())] + [(fp-single-float) + (values (lambda (x) + `(inline ,(make-info-loadfl %Cfpretval) ,%load-double->single ,x ,%zero ,(%constant flonum-data-disp))) + '())] + [(fp-void) + (values (lambda () `(nop)) + '())] + [else + (cond + [(nanopass-case (Ltype Type) result-type + [(fp-integer ,bits) (fx= bits 64)] + [(fp-unsigned ,bits) (fx= bits 64)] + [else #f]) + (values (lambda (lo-rhs hi-rhs) + (%seq + (set! ,%Cretval-low ,lo-rhs) + (set! ,%Cretval-high ,hi-rhs))) + (list %Cretval-high %Cretval-low))] + [else + (values (lambda (rhs) + `(set! ,%Cretval ,rhs)) + (list %Cretval))])]))) (lambda (info) (define callee-save-regs (list %r14 %r15 %r16 %r17 %r18 %r19 %r20 %r21 %r22 %r23 %r24 %r25 %r26 %r27 %r28 %r29 %r30 %r31)) (define isaved (length callee-save-regs)) (let ([arg-type* (info-foreign-arg-type* info)] + [result-type (info-foreign-result-type info)] [gp-reg-count (length (gp-parameter-regs))] [fp-reg-count (length (fp-parameter-regs))]) - (let-values ([(iint iflt) (count-reg-args arg-type* gp-reg-count fp-reg-count)]) + (let-values ([(iint iflt) (count-reg-args arg-type* gp-reg-count fp-reg-count (indirect-result-that-fits-in-registers? result-type))]) (let* ([int-reg-offset 8] ; initial offset for calling conventions - [float-reg-offset (fx+ (fx* gp-reg-count 4) int-reg-offset)] + [float-reg-offset (align 8 (fx+ (fx* gp-reg-count 4) int-reg-offset))] [callee-save-offset (if (constant software-floating-point) float-reg-offset (fx+ (fx* fp-reg-count 8) float-reg-offset))] - [stack-size (align 16 (fx+ (fx* isaved 4) callee-save-offset))] + [synthesize-first-argument? (indirect-result-that-fits-in-registers? result-type)] + [return-space-offset (align 8 (fx+ (fx* isaved 4) callee-save-offset))] + [stack-size (align 16 (if synthesize-first-argument? + (fx+ return-space-offset 8) + return-space-offset))] [stack-arg-offset (fx+ stack-size 8)]) - (values - (lambda () - (%seq - ,(%inline save-lr (immediate 4)) - ,(%inline store-with-update ,%Csp ,%Csp (immediate ,(fx- stack-size))) - ,(save-regs (list-head (gp-parameter-regs) iint) int-reg-offset) - ,(save-fp-regs (list-head (fp-parameter-regs) iflt) float-reg-offset) - ; not bothering with callee-save floating point regs right now - ; not bothering with cr, because we don't update nonvolatile fields - ,(save-regs callee-save-regs callee-save-offset) - ,(if-feature pthreads - (%seq - (set! ,%Cretval ,(%inline get-tc)) - (set! ,%tc ,%Cretval)) - `(set! ,%tc (literal ,(make-info-literal #f 'entry (lookup-c-entry thread-context) 0)))))) - ; list of procedures that marshal arguments from their C stack locations - ; to the Scheme argument locations - (do-stack arg-type* gp-reg-count fp-reg-count int-reg-offset float-reg-offset stack-arg-offset) - (lambda (fv* Scall->result-type) - (in-context Tail - (%seq - ; restore the lr - (inline ,null-info ,%restore-lr (immediate ,(fx+ stack-size 4))) - ; restore the callee save registers - ,(restore-regs callee-save-regs callee-save-offset) - ; deallocate space for pad & arg reg values - (set! ,%Csp ,(%inline + ,%Csp (immediate ,stack-size))) - ; tail call the C helper that calls the Scheme procedure - (jump (literal ,(make-info-literal #f 'entry Scall->result-type 0)) - (,callee-save-regs ... ,fv* ...)))))))))))))) + (let-values ([(get-result result-regs) (do-result result-type return-space-offset int-reg-offset)]) + (values + (lambda () + (%seq + ,(%inline save-lr (immediate 4)) + ,(%inline store-with-update ,%Csp ,%Csp (immediate ,(fx- stack-size))) + ,(save-regs (list-head (gp-parameter-regs) iint) int-reg-offset) + ,(save-fp-regs (list-head (fp-parameter-regs) iflt) float-reg-offset) + ; not bothering with callee-save floating point regs right now + ; not bothering with cr, because we don't update nonvolatile fields + ,(save-regs callee-save-regs callee-save-offset) + ,(if-feature pthreads + (%seq + (set! ,%Cretval ,(%inline get-tc)) + (set! ,%tc ,%Cretval)) + `(set! ,%tc (literal ,(make-info-literal #f 'entry (lookup-c-entry thread-context) 0)))))) + ; list of procedures that marshal arguments from their C stack locations + ; to the Scheme argument locations + (do-stack arg-type* gp-reg-count fp-reg-count int-reg-offset float-reg-offset stack-arg-offset + synthesize-first-argument? return-space-offset) + get-result + (lambda () + (in-context Tail + (%seq + ; restore the lr + (inline ,null-info ,%restore-lr (immediate ,(fx+ stack-size 4))) + ; restore the callee save registers + ,(restore-regs callee-save-regs callee-save-offset) + ; deallocate space for pad & arg reg values + (set! ,%Csp ,(%inline + ,%Csp (immediate ,stack-size))) + ; done + (asm-c-return ,null-info ,callee-save-regs ... ,result-regs ...)))))))))))))) ) diff --git a/s/primdata.ss b/s/primdata.ss index 0c89595c5c..47aa9a4172 100644 --- a/s/primdata.ss +++ b/s/primdata.ss @@ -1974,6 +1974,12 @@ ($fptr-unlock! [flags]) ($fp-type->pred [flags]) ($ftd? [flags]) + ($ftd-alignment [flags]) + ($ftd-as-box? [flags]) + ($ftd-atomic-category [flags]) + ($ftd-compound? [flags]) + ($ftd-size [flags]) + ($ftd->members [flags]) ($ftype-pointer? [flags]) ($fxaddress [flags unrestricted alloc]) ($fx-? [flags]) diff --git a/s/syntax.ss b/s/syntax.ss index 08bc0176f1..574aead35a 100644 --- a/s/syntax.ss +++ b/s/syntax.ss @@ -679,7 +679,11 @@ [(integer-40 integer-48 integer-56 integer-64) `(fp-integer 64)] [(unsigned-40 unsigned-48 unsigned-56 unsigned-64) `(fp-unsigned 64)] [(void) (and void-okay? `(fp-void))] - [else (and ($ftd? x) `(fp-ftd ,x))]) + [else + (cond + [($ftd? x) `(fp-ftd ,x)] + [($ftd-as-box? x) `(fp-ftd& ,(unbox x))] + [else #f])]) ($oops #f "invalid ~a ~a specifier ~s" who what x))))) (define build-foreign-procedure @@ -8508,7 +8512,9 @@ (constant-case native-endianness [(little) 'utf-32le] [(big) 'utf-32be])])] - [else (and ($ftd? type) type)]))) + [else + (and (or ($ftd? type) ($ftd-as-box? type)) + type)]))) (define $fp-type->pred (lambda (type) @@ -8649,10 +8655,11 @@ (err ($moi) x))))) (u32*))] [else #f]) - (if ($ftd? type) - #`(#,(if unsafe? #'() #`((unless (record? x '#,type) (err ($moi) x)))) - (x) - (#,type)) + (if (or ($ftd? type) ($ftd-as-box? type)) + (let ([ftd (if ($ftd? type) type (unbox type))]) + #`(#,(if unsafe? #'() #`((unless (record? x '#,ftd) (err ($moi) x)))) + (x) + (#,type))) (with-syntax ([pred (datum->syntax #'foreign-procedure ($fp-type->pred type))] [type (datum->syntax #'foreign-procedure type)]) #`(#,(if unsafe? #'() #'((unless (pred x) (err ($moi) x)))) @@ -8684,15 +8691,36 @@ [(unsigned-48) #`((lambda (x) (mod x #x1000000000000)) unsigned-64)] [(integer-56) #`((lambda (x) (mod0 x #x100000000000000)) integer-64)] [(unsigned-56) #`((lambda (x) (mod x #x100000000000000)) unsigned-64)] - [else #`(values #,(datum->syntax #'foreign-procedure result-type))])]) - #`(let ([p ($foreign-procedure conv foreign-name ?foreign-addr (arg ... ...) result)] + [else + (cond + [($ftd-as-box? result-type) + ;; Return void, since an extra first argument receives the result, + ;; but tell `$foreign-procedure` that the result is actually an & form + #`((lambda (r) (void)) #,(datum->syntax #'foreign-procedure result-type))] + [else + #`(values #,(datum->syntax #'foreign-procedure result-type))])])] + [([extra ...] [extra-arg ...] [extra-check ...]) + ;; When the result type is `(& )`, the `$foreign-procedure` result + ;; expects an extra argument as a `(* )` that it uses to store the + ;; foreign-procedure result, and it returns void. The extra argument is made + ;; explicit for `$foreign-procedure`, and the return type is preserved as-is + ;; to let `$foreign-procedure` know that it needs to fill the first argument. + (cond + [($ftd-as-box? result-type) + #`([&-result] + [#,(unbox result-type)] + #,(if unsafe? + #`[] + #`[(unless (record? &-result '#,(unbox result-type)) (err ($moi) &-result))]))] + [else #'([] [] [])])]) + #`(let ([p ($foreign-procedure conv foreign-name ?foreign-addr (extra-arg ... arg ... ...) result)] #,@(if unsafe? #'() #'([err (lambda (who x) ($oops (or who foreign-name) "invalid foreign-procedure argument ~s" x))]))) - (lambda (t ...) check ... ... (result-filter (p actual ... ...))))))))) + (lambda (extra ... t ...) extra-check ... check ... ... (result-filter (p extra ... actual ... ...))))))))) (define-syntax foreign-procedure (lambda (x) @@ -8810,12 +8838,13 @@ (with-syntax ([(x) (generate-temporaries #'(*))]) #`(x (x) (#,(datum->syntax #'foreign-callable type)))))) type*)] - [(result-filter result) + [(result-filter result [extra-arg ...] [extra ...]) (case result-type [(boolean) #`((lambda (x) (if x 1 0)) #,(constant-case int-bits [(32) #'integer-32] - [(64) #'integer-64]))] + [(64) #'integer-64]) + [] [])] [(char) #`((lambda (x) #,(if unsafe? @@ -8824,7 +8853,8 @@ (let ([x (char->integer x)]) (and (fx<= x #xff) x))) (err x)))) - unsigned-8)] + unsigned-8 + [] [])] [(wchar) (constant-case wchar-bits [(16) #`((lambda (x) @@ -8834,14 +8864,16 @@ (let ([x (char->integer x)]) (and (fx<= x #xffff) x))) (err x)))) - unsigned-16)] + unsigned-16 + [] [])] [(32) #`((lambda (x) #,(if unsafe? #'(char->integer x) #'(if (char? x) (char->integer x) (err x)))) - unsigned-16)])] + unsigned-16 + [] [])])] [(utf-8) #`((lambda (x) (if (eq? x #f) @@ -8851,7 +8883,8 @@ #'(if (string? x) ($fp-string->utf8 x) (err x))))) - u8*)] + u8* + [] [])] [(utf-16le) #`((lambda (x) (if (eq? x #f) @@ -8861,7 +8894,8 @@ #'(if (string? x) ($fp-string->utf16 x 'little) (err x))))) - u16*)] + u16* + [] [])] [(utf-16be) #`((lambda (x) (if (eq? x #f) @@ -8871,7 +8905,8 @@ #'(if (string? x) ($fp-string->utf16 x 'big) (err x))))) - u16*)] + u16* + [] [])] [(utf-32le) #`((lambda (x) (if (eq? x #f) @@ -8881,7 +8916,8 @@ #'(if (string? x) ($fp-string->utf32 x 'little) (err x))))) - u32*)] + u32* + [] [])] [(utf-32be) #`((lambda (x) (if (eq? x #f) @@ -8891,21 +8927,37 @@ #'(if (string? x) ($fp-string->utf32 x 'big) (err x))))) - u32*)] + u32* + [] [])] [else - (if ($ftd? result-type) - (with-syntax ([type (datum->syntax #'foreign-callable result-type)]) - #`((lambda (x) - #,@(if unsafe? #'() #'((unless (record? x 'type) (err x)))) - x) - type)) - (with-syntax ([pred (datum->syntax #'foreign-callable ($fp-type->pred result-type))] - [type (datum->syntax #'foreign-callable result-type)]) - #`((lambda (x) - #,@(if unsafe? #'() #'((unless (pred x) (err x)))) - x) - type)))])]) - ; use a gensym to avoid giving the procedure a confusing namej + (cond + [($ftd? result-type) + (with-syntax ([type (datum->syntax #'foreign-callable result-type)]) + #`((lambda (x) + #,@(if unsafe? #'() #'((unless (record? x 'type) (err x)))) + x) + type + [] []))] + [($ftd-as-box? result-type) + ;; callable receives an extra pointer argument to fill with the result; + ;; we add this type to `$foreign-callable` as an initial address argument, + ;; which may be actually provided by the caller or synthesized by the + ;; back end, depending on the type and architecture + (with-syntax ([type (datum->syntax #'foreign-callable result-type)] + [ftd (datum->syntax #'foreign-callable (unbox result-type))]) + #`((lambda (x) (void)) ; callable result is ignored + type + [ftd] + [&-result]))] + [else + (with-syntax ([pred (datum->syntax #'foreign-callable ($fp-type->pred result-type))] + [type (datum->syntax #'foreign-callable result-type)]) + #`((lambda (x) + #,@(if unsafe? #'() #'((unless (pred x) (err x)))) + x) + type + [] []))])])]) + ; use a gensym to avoid giving the procedure a confusing name (with-syntax ([p (datum->syntax #'foreign-callable (gensym))]) #`($foreign-callable conv (let ([p ?proc]) @@ -8914,8 +8966,8 @@ "invalid return value ~s from ~s" x p)) #,@(if unsafe? #'() #'((unless (procedure? p) ($oops 'foreign-callable "~s is not a procedure" p)))) - (lambda (t ... ...) (result-filter (p actual ...)))) - (arg ... ...) + (lambda (extra ... t ... ...) (result-filter (p extra ... actual ...)))) + (extra-arg ... arg ... ...) result))))))) (define-syntax foreign-callable diff --git a/s/x86.ss b/s/x86.ss index 28962e4893..94e779e7bc 100644 --- a/s/x86.ss +++ b/s/x86.ss @@ -733,6 +733,15 @@ (define-instruction value (fstpl) [(op (z mem)) `(set! ,(make-live-info) ,z (asm ,info ,asm-fstpl))]) + (define-instruction value (fstps) + [(op (z mem)) `(set! ,(make-live-info) ,z (asm ,info ,asm-fstps))]) + + (define-instruction effect (fldl) + [(op (z mem)) `(asm ,info ,asm-fldl ,z)]) + + (define-instruction effect (flds) + [(op (z mem)) `(asm ,info ,asm-flds ,z)]) + (define-instruction effect (load-single->double load-double->single) [(op (x ur) (y ur) (z imm32)) `(asm ,info ,(asm-fl-cvt op (info-loadfl-flreg info)) ,x ,y ,z)]) @@ -907,11 +916,11 @@ asm-pop asm-shiftop asm-sll asm-logand asm-lognot asm-logtest asm-fl-relop asm-relop asm-push asm-indirect-jump asm-literal-jump asm-direct-jump asm-return-address asm-jump asm-conditional-jump asm-data-label asm-rp-header - asm-lea1 asm-lea2 asm-indirect-call asm-fstpl asm-condition-code + asm-lea1 asm-lea2 asm-indirect-call asm-fstpl asm-fstps asm-fldl asm-flds asm-condition-code asm-fl-cvt asm-fl-store asm-fl-load asm-flt asm-trunc asm-div asm-exchange asm-pause asm-locked-incr asm-locked-decr asm-flop-2 asm-flsqrt asm-c-simple-call - asm-save-flrv asm-restore-flrv asm-return asm-size + asm-save-flrv asm-restore-flrv asm-return asm-c-return asm-size asm-enter asm-foreign-call asm-foreign-callable asm-inc-profile-counter asm-inc-cc-counter asm-read-time-stamp-counter asm-read-performance-monitoring-counter @@ -1039,6 +1048,7 @@ (define-op popf byte-op #b10011101) (define-op nop byte-op #b10010000) (define-op ret byte-op #b11000011) + (define-op retl byte+short-op #b11000010) (define-op sahf byte-op #b10011110) (define-op extad byte-op #b10011001) ; extend eax to edx @@ -1076,7 +1086,9 @@ ; coprocessor ops required to handle calling conventions (define-op fldl float-op2 #b101 #b000) ; double memory push => ST[0] + (define-op flds float-op2 #b001 #b000) ; single memory push => ST[0] (define-op fstpl float-op2 #b101 #b011) ; ST[0] => double memory, pop + (define-op fstps float-op2 #b001 #b011) ; ST[0] => single memory, pop ; SSE2 instructions (pulled from x86_64macros.ss) (define-op sse.addsd sse-op1 #xF2 #x58) @@ -1434,6 +1446,13 @@ (build byte op-code1) (build byte op-code2)))) + (define byte+short-op + (lambda (op op-code1 t code*) + (emit-code (op code*) + (build byte op-code1) + (build byte (fxand (cadr t) #xFF)) + (build byte (fxsrl (cadr t) 16))))) + (define byte-reg-op1 (lambda (op op-code1 reg code*) (begin @@ -1629,6 +1648,21 @@ (Trivit (dest) (emit fstpl dest code*)))) + (define asm-fstps + (lambda (code* dest) + (Trivit (dest) + (emit fstps dest code*)))) + + (define asm-fldl + (lambda (code* src) + (Trivit (src) + (emit fldl src code*)))) + + (define asm-flds + (lambda (code* src) + (Trivit (src) + (emit flds src code*)))) + (define asm-fl-cvt (lambda (op flreg) (lambda (code* base index offset) @@ -1849,6 +1883,14 @@ [(i3osx ti3osx) (emit addi '(imm 12) (cons 'reg %sp) (emit ret '()))] [else (emit ret '())]))) + (define asm-c-return + (lambda (info) + (if (info-c-return? info) + (let ([offset (info-c-return-offset info)]) + (safe-assert (<= 0 offset #xFFFF)) + (emit retl `(imm ,offset) '())) + (emit ret '())))) + (define asm-locked-incr (lambda (code* base index offset) (let ([dest (build-mem-opnd base index offset)]) @@ -2220,6 +2262,25 @@ ,e))])))] [else (define asm-enter values)]) + (define callee-expects-result-pointer? + (lambda (result-type) + (nanopass-case (Ltype Type) result-type + [(fp-ftd& ,ftd) (constant-case machine-type-name + [(i3osx ti3osx i3nt ti3nt) + (case ($ftd-size ftd) + [(1 2 4 8) #f] + [else #t])] + [else ($ftd-compound? ftd)])] + [else #f]))) + (define callee-pops-result-pointer? + (lambda (result-type) + (callee-expects-result-pointer? result-type))) + (define fill-result-pointer-from-registers? + (lambda (result-type) + (nanopass-case (Ltype Type) result-type + [(fp-ftd& ,ftd) (not (callee-expects-result-pointer? result-type))] + [else #f]))) + (define asm-foreign-call (with-output-language (L13 Effect) (letrec ([load-double-stack @@ -2244,19 +2305,74 @@ (%seq (set! ,(%mref ,%sp ,offset) ,lorhs) (set! ,(%mref ,%sp ,(fx+ offset 4)) ,hirhs))))] + [load-content + (lambda (offset len) + (lambda (x) ; requires var + (let loop ([offset offset] [x-offset 0] [len len]) + (cond + [(= len 0) `(nop)] + [(>= len 4) + `(seq + (set! ,(%mref ,%sp ,offset) (inline ,(make-info-load 'integer-32 #f) + ,%load ,x ,%zero (immediate ,x-offset))) + ,(loop (fx+ offset 4) (fx+ x-offset 4) (fx- len 4)))] + [(>= len 2) + (%seq + (set! ,%eax (inline ,(make-info-load 'integer-16 #f) + ,%load ,x ,%zero (immediate ,x-offset))) + (inline ,(make-info-load 'integer-16 #f) + ,%store ,%sp ,%zero (immediate ,offset) + ,%eax) + ,(loop (fx+ offset 2) (fx+ x-offset 2) (fx- len 2)))] + [else + (%seq + (set! ,%eax (inline ,(make-info-load 'integer-8 #f) + ,%load ,x ,%zero (immediate ,x-offset))) + (inline ,(make-info-load 'integer-8 #f) + ,%store ,%sp ,%zero (immediate ,offset) + ,%eax))]))))] [do-stack - (lambda (types locs n) + (lambda (types locs n result-type) (if (null? types) (values n locs) (nanopass-case (Ltype Type) (car types) [(fp-double-float) (do-stack (cdr types) (cons (load-double-stack n) locs) - (fx+ n 8))] + (fx+ n 8) + #f)] [(fp-single-float) (do-stack (cdr types) (cons (load-single-stack n) locs) - (fx+ n 4))] + (fx+ n 4) + #f)] + [(fp-ftd& ,ftd) + (do-stack (cdr types) + (cons (load-content n ($ftd-size ftd)) locs) + (fx+ n (fxlogand (fx+ ($ftd-size ftd) 3) -4)) + #f)] + [(fp-ftd ,ftd) + (cond + [(and result-type + (fill-result-pointer-from-registers? result-type)) + ;; Callee doesn't expect this argument; move + ;; it to the end just to save it for filling + ;; when the callee returns + (let ([end-n 0]) + (with-values (do-stack (cdr types) + (cons (lambda (rhs) + ((load-stack end-n) rhs)) + locs) + n + #f) + (lambda (frame-size locs) + (set! end-n frame-size) + (values (fx+ frame-size 4) locs))))] + [else + (do-stack (cdr types) + (cons (load-stack n) locs) + (fx+ n 4) + #f)])] [else (if (nanopass-case (Ltype Type) (car types) [(fp-integer ,bits) (fx= bits 64)] @@ -2264,17 +2380,19 @@ [else #f]) (do-stack (cdr types) (cons (load-stack64 n) locs) - (fx+ n 8)) + (fx+ n 8) + #f) (do-stack (cdr types) (cons (load-stack n) locs) - (fx+ n 4)))])))]) + (fx+ n 4) + #f))])))]) (define returnem - (lambda (conv frame-size locs ccall r-loc) + (lambda (conv orig-frame-size locs result-type ccall r-loc) (let ([frame-size (constant-case machine-type-name ; maintain 16-byte alignment not including the return address pushed ; by the call instruction, which counts as part of callee's frame - [(i3osx ti3osx) (fxlogand (fx+ frame-size 15) -16)] - [else frame-size])]) + [(i3osx ti3osx) (fxlogand (fx+ orig-frame-size 15) -16)] + [else orig-frame-size])]) (values (lambda () (if (fx= frame-size 0) `(nop) @@ -2286,28 +2404,64 @@ (lambda () (if (or (fx= frame-size 0) (memq conv '(i3nt-stdcall i3nt-com))) `(nop) - `(set! ,%sp ,(%inline + ,%sp (immediate ,frame-size))))))))) + (let ([frame-size (if (callee-pops-result-pointer? result-type) + (fx- frame-size (constant ptr-bytes)) + frame-size)]) + `(set! ,%sp ,(%inline + ,%sp (immediate ,frame-size)))))))))) (lambda (info) (safe-assert (reg-callee-save? %tc)) ; no need to save-restore (let ([conv (info-foreign-conv info)] [arg-type* (info-foreign-arg-type* info)] [result-type (info-foreign-result-type info)]) - (with-values (do-stack arg-type* '() 0) + (with-values (do-stack arg-type* '() 0 result-type) (lambda (frame-size locs) - (returnem conv frame-size locs + (returnem conv frame-size locs result-type (lambda (t0) - (case conv - [(i3nt-com) - (when (null? arg-type*) - ($oops 'foreign-procedure - "__com convention requires instance argument")) - ; jump indirect - (%seq - (set! ,%eax ,(%mref ,%sp 0)) - (set! ,%eax ,(%mref ,%eax 0)) - (set! ,%eax ,(%inline + ,%eax ,t0)) - (inline ,(make-info-kill*-live* (reg-list %eax %edx) '()) ,%c-call ,(%mref ,%eax 0)))] - [else `(inline ,(make-info-kill*-live* (reg-list %eax %edx) '()) ,%c-call ,t0)])) + (let ([call + (case conv + [(i3nt-com) + (when (null? arg-type*) + ($oops 'foreign-procedure + "__com convention requires instance argument")) + ; jump indirect + (%seq + (set! ,%eax ,(%mref ,%sp 0)) + (set! ,%eax ,(%mref ,%eax 0)) + (set! ,%eax ,(%inline + ,%eax ,t0)) + (inline ,(make-info-kill*-live* (reg-list %eax %edx) '()) ,%c-call ,(%mref ,%eax 0)))] + [else `(inline ,(make-info-kill*-live* (reg-list %eax %edx) '()) ,%c-call ,t0)])]) + (cond + [(fill-result-pointer-from-registers? result-type) + (let* ([ftd (nanopass-case (Ltype Type) result-type + [(fp-ftd& ,ftd) ftd])] + [size ($ftd-size ftd)]) + (%seq + ,call + (set! ,%ecx ,(%mref ,%sp ,(fx- frame-size (constant ptr-bytes)))) + ,(case size + [(1) + `(inline ,(make-info-load 'integer-8 #f) ,%store + ,%ecx ,%zero (immediate ,0) ,%eax)] + [(2) + `(inline ,(make-info-load 'integer-16 #f) ,%store + ,%ecx ,%zero (immediate ,0) ,%eax)] + [(4) + (cond + [(and (if-feature windows (not ($ftd-compound? ftd)) #t) + (equal? '((float 4 0)) ($ftd->members ftd))) + `(set! ,(%mref ,%ecx 0) ,(%inline fstps))] + [else + `(set! ,(%mref ,%ecx 0) ,%eax)])] + [(8) + (cond + [(and (if-feature windows (not ($ftd-compound? ftd)) #t) + (equal? '((float 8 0)) ($ftd->members ftd))) + `(set! ,(%mref ,%ecx 0) ,(%inline fstpl))] + [else + `(seq + (set! ,(%mref ,%ecx 0) ,%eax) + (set! ,(%mref ,%ecx 4) ,%edx))])])))] + [else call]))) (nanopass-case (Ltype Type) result-type [(fp-double-float) (lambda (x) @@ -2350,6 +2504,25 @@ [else (lambda (lvalue) `(set! ,lvalue ,%eax))]))))))))) (define asm-foreign-callable + #| + Frame Layout + +---------------------------+ + | | + | incoming stack args | + sp+X+Y: | | + +---------------------------+ <- i3osx: 16-byte boundary + | incoming return address | one word + +---------------------------+ + | | + | callee-save registers | EBP, ESI, EDI, EBX (4 words) + sp+X: | | + +---------------------------+ + | indirect result space | i3osx: 3 words + | (for & results via regs) | other: 2 words + sp+0: +---------------------------+<- i3osx: 16-byte boundary + |# + + (with-output-language (L13 Effect) (let () (define load-double-stack @@ -2389,6 +2562,10 @@ "unexpected load-int-stack fp-unsigned size ~s" bits)])] [else `(set! ,lvalue ,(%mref ,%sp ,offset))])))) + (define load-stack-address + (lambda (offset) + (lambda (lvalue) ; requires lvalue + `(set! ,lvalue ,(%inline + ,%sp (immediate ,offset)))))) (define load-stack64 (lambda (type offset) (lambda (lolvalue hilvalue) ; requires lvalue @@ -2408,6 +2585,10 @@ (do-stack (cdr types) (cons (load-single-stack n) locs) (fx+ n 4))] + [(fp-ftd& ,ftd) + (do-stack (cdr types) + (cons (load-stack-address n) locs) + (fx+ n (fxlogand (fx+ ($ftd-size ftd) 3) -4)))] [else (if (nanopass-case (Ltype Type) (car types) [(fp-integer ,bits) (fx= bits 64)] @@ -2419,61 +2600,127 @@ (do-stack (cdr types) (cons (load-stack (car types) n) locs) (fx+ n 4)))])))) + (define (do-result result-type init-stack-offset indirect-result-to-registers?) + (nanopass-case (Ltype Type) result-type + [(fp-ftd& ,ftd) + (cond + [indirect-result-to-registers? + (cond + [(and (if-feature windows (not ($ftd-compound? ftd)) #t) + (equal? '((float 4 0)) ($ftd->members ftd))) + (values (lambda () + (%inline flds ,(%mref ,%sp 0))) + '())] + [(and (if-feature windows (not ($ftd-compound? ftd)) #t) + (equal? '((float 8 0)) ($ftd->members ftd))) + (values (lambda () + (%inline fldl ,(%mref ,%sp 0))) + '())] + [(fx= ($ftd-size ftd) 8) + (values (lambda () + `(seq + (set! ,%eax ,(%mref ,%sp 0)) + (set! ,%edx ,(%mref ,%sp 4)))) + (list %eax %edx))] + [else + (values (lambda () + `(set! ,%eax ,(%mref ,%sp 0))) + (list %eax))])] + [else + (values (lambda () + ;; Return pointer that was filled; destination was the first argument + `(set! ,%eax ,(%mref ,%sp ,init-stack-offset))) + (list %eax))])] + [(fp-double-float) + (values (lambda (x) + (%inline fldl ,(%mref ,x ,(constant flonum-data-disp)))) + '())] + [(fp-single-float) + (values (lambda (x) + (%inline fldl ,(%mref ,x ,(constant flonum-data-disp)))) + '())] + [(fp-void) + (values (lambda () `(nop)) + '())] + [else + (cond + [(nanopass-case (Ltype Type) result-type + [(fp-integer ,bits) (fx= bits 64)] + [(fp-unsigned ,bits) (fx= bits 64)] + [else #f]) + (values (lambda (lorhs hirhs) ; requires rhs + (%seq + (set! ,%eax ,lorhs) + (set! ,%edx ,hirhs))) + (list %eax %edx))] + [else + (values (lambda (x) + `(set! ,%eax ,x)) + (list %eax))])])) (lambda (info) (let ([conv (info-foreign-conv info)] [arg-type* (info-foreign-arg-type* info)] - [result-type (info-foreign-result-type info)]) - (with-values (do-stack arg-type* '() - (constant-case machine-type-name [(i3osx ti3osx) 32] [else 20])) - (lambda (frame-size locs) - (values - (lambda () - (%seq - ,(%inline push ,%ebp) - ,(%inline push ,%esi) - ,(%inline push ,%edi) - ,(%inline push ,%ebx) - ,((lambda (e) - (constant-case machine-type-name - [(i3osx ti3osx) - ; maintain 16-bit alignment for i3osx, taking into account - ; 16 bytes pushed below + 4 for RA pushed by asmCcall - (%seq - (set! ,%sp ,(%inline - ,%sp (immediate 12))) - ,e)] - [else e])) - (if-feature pthreads - `(seq - (set! ,%eax ,(%inline get-tc)) - (set! ,%tc ,%eax)) - `(set! ,%tc (literal ,(make-info-literal #f 'entry (lookup-c-entry thread-context) 0))))))) - (reverse locs) - (lambda (fv* Scall->result-type) - (in-context Tail - ((lambda (e) - (constant-case machine-type-name - [(i3osx ti3osx) - (%seq - (set! ,%sp ,(%inline + ,%sp (immediate 12))) - ,e)] - [else e])) + [result-type (info-foreign-result-type info)] + [init-stack-offset (constant-case machine-type-name [(i3osx ti3osx) 32] [else 28])] + [indirect-result-space (constant-case machine-type-name + [(i3osx ti3osx) + ;; maintain 16-bit alignment for i3osx, taking into account + ;; 16 bytes pushed above + 4 for RA pushed by asmCcall; + ;; 8 of these bytes are used for &-return space, if needed + 12] + [else 8])]) + (let ([indirect-result-to-registers? (fill-result-pointer-from-registers? result-type)]) + (let-values ([(get-result result-regs) (do-result result-type init-stack-offset indirect-result-to-registers?)]) + (with-values (do-stack (if indirect-result-to-registers? + (cdr arg-type*) + arg-type*) + '() + init-stack-offset) + (lambda (frame-size locs) + (values + (lambda () (%seq - (set! ,%ebx ,(%inline pop)) - (set! ,%edi ,(%inline pop)) - (set! ,%esi ,(%inline pop)) - (set! ,%ebp ,(%inline pop)) - ; Windows __stdcall convention requires callee to clean up - ,((lambda (e) - (if (memq conv '(i3nt-stdcall i3nt-com)) - (let ([arg-size (fx- frame-size 20)]) + ,(%inline push ,%ebp) + ,(%inline push ,%esi) + ,(%inline push ,%edi) + ,(%inline push ,%ebx) + (set! ,%sp ,(%inline - ,%sp (immediate ,indirect-result-space))) + ,(if-feature pthreads + `(seq + (set! ,%eax ,(%inline get-tc)) + (set! ,%tc ,%eax)) + `(set! ,%tc (literal ,(make-info-literal #f 'entry (lookup-c-entry thread-context) 0)))))) + (let ([locs (reverse locs)]) + (if indirect-result-to-registers? + (cons (load-stack-address 0) ; use the &-return space + locs) + locs)) + get-result + (lambda () + (in-context Tail + (%seq + (set! ,%sp ,(%inline + ,%sp (immediate ,indirect-result-space))) + (set! ,%ebx ,(%inline pop)) + (set! ,%edi ,(%inline pop)) + (set! ,%esi ,(%inline pop)) + (set! ,%ebp ,(%inline pop)) + ; Windows __stdcall convention requires callee to clean up + ,((lambda (e) + (if (memq conv '(i3nt-stdcall i3nt-com)) + (let ([arg-size (fx- frame-size init-stack-offset)]) (if (fx> arg-size 0) (%seq - (set! - ,(%mref ,%sp ,arg-size) - ,(%mref ,%sp 0)) - (set! ,%sp ,(%inline + ,%sp (immediate ,arg-size))) - ,e) + (set! + ,(%mref ,%sp ,arg-size) + ,(%mref ,%sp 0)) + (set! ,%sp ,(%inline + ,%sp (immediate ,arg-size))) + ,e) e)) e)) - `(jump (literal ,(make-info-literal #f 'entry Scall->result-type 0)) - (,%ebx ,%edi ,%esi ,%ebp ,fv* ...)))))))))))))))) + `(asm-c-return ,(if (callee-pops-result-pointer? result-type) + ;; remove the pointer argument provided by the caller + ;; after popping the return address + (make-info-c-return 4) + null-info) + ,result-regs ...))))))))))))))) + ) diff --git a/s/x86_64.ss b/s/x86_64.ss index 3162df302a..b066f09f2b 100644 --- a/s/x86_64.ss +++ b/s/x86_64.ss @@ -977,7 +977,7 @@ asm-fl-cvt asm-fl-store asm-fl-load asm-flt asm-trunc asm-div asm-exchange asm-pause asm-locked-incr asm-locked-decr asm-flop-2 asm-flsqrt asm-c-simple-call - asm-save-flrv asm-restore-flrv asm-return asm-size + asm-save-flrv asm-restore-flrv asm-return asm-c-return asm-size asm-enter asm-foreign-call asm-foreign-callable asm-inc-profile-counter asm-inc-cc-counter asm-read-time-stamp-counter asm-read-performance-monitoring-counter @@ -1991,6 +1991,10 @@ (emit addi '(imm 8) (cons 'reg %sp) (emit ret '())))) + (define asm-c-return + (lambda (info) + (emit ret '()))) + (define asm-locked-incr (lambda (code* base index offset) (let ([dest (build-mem-opnd base index offset)]) @@ -2408,6 +2412,88 @@ (define make-vint (lambda () (vector %Carg1 %Carg2 %Carg3 %Carg4 %Carg5 %Carg6))) (define make-vfp (lambda () (vector %Cfparg1 %Cfparg2 %Cfparg3 %Cfparg4 %Cfparg5 %Cfparg6 %Cfparg7 %Cfparg8))))) + (define (align n size) + (fxlogand (fx+ n (fx- size 1)) (fx- size))) + + (define (classify-type type) + (nanopass-case (Ltype Type) type + [(fp-ftd& ,ftd) (classify-eightbytes ftd)] + [else #f])) + + ;; classify-eightbytes: returns '(memory) or a nonemtpy list of 'integer/'sse + (if-feature windows + ;; Windows: either passed in one register or not + (define (classify-eightbytes ftd) + (cond + [($ftd-compound? ftd) + (if (memv ($ftd-size ftd) '(1 2 4 8)) + '(integer) + '(memory))] + [(eq? 'float (caar ($ftd->members ftd))) + '(sse)] + [else '(integer)])) + ;; Non-Windows: SYSV ABI is a more general classification of + ;; 8-byte segments into 'integer, 'sse, or 'memory modes + (define (classify-eightbytes ftd) + (define (merge t1 t2) + (cond + [(eq? t1 t2) t1] + [(eq? t1 'no-class) t2] + [(eq? t2 'no-class) t1] + [(eq? t1 'memory) 'memory] + [(eq? t2 'memory) 'memory] + [else 'integer])) + (cond + [(or (> ($ftd-size ftd) 16) ; more than 2 eightbytes => passed in memory + (fx= 0 ($ftd-size ftd))) + '(memory)] + [else + (let ([classes (make-vector (fxsrl (align ($ftd-size ftd) 8) 3) 'no-class)]) + (let loop ([mbrs ($ftd->members ftd)]) + (cond + [(null? mbrs) + (vector->list classes)] + [else + (let ([kind (caar mbrs)] + [size (cadar mbrs)] + [offset (caddar mbrs)]) + (cond + [(not (fx= offset (align offset size))) + ;; misaligned + '(memory)] + [else + (let* ([pos (fxsrl offset 3)] + [class (vector-ref classes pos)] + [new-class (merge class (if (eq? kind 'float) 'sse 'integer))]) + (cond + [(eq? new-class 'memory) + '(memory)] + [else + (vector-set! classes pos new-class) + (loop (cdr mbrs))]))]))])))]))) + + (define (count v l) + (cond + [(null? l) 0] + [(eq? (car l) v) (fx+ 1 (count v (cdr l)))] + [else (count v (cdr l))])) + + ;; A result is put in registers if it has up to two + ;; eightbytes, each 'integer or 'sse. On Windows, + ;; `result-classes` always has only one item. + (define (result-fits-in-registers? result-classes) + (and result-classes + (not (eq? 'memory (car result-classes))) + (or (null? (cdr result-classes)) + (null? (cddr result-classes))))) + + ;; An argument is put in registeres depending on how many + ;; registers are left + (define (pass-here-by-stack? classes iint ints ifp fps) + (or (eq? 'memory (car classes)) + (fx> (fx+ iint ints) 6) + (fx> (fx+ ifp fps) 8))) + (define asm-foreign-call (with-output-language (L13 Effect) (letrec ([load-double-stack @@ -2452,6 +2538,87 @@ ; x is a non-triv right-hand-side [else (%seq (set! ,ireg ,x) (set! ,ireg ,(%inline zext32 ,ireg)))])] [else `(set! ,ireg ,x)])))] + [load-content-stack + (lambda (offset len) + (lambda (x) ; requires var + (let loop ([offset offset] [x-offset 0] [len len]) + (cond + [(= len 0) `(nop)] + [(>= len 8) + `(seq + (set! ,(%mref ,%sp ,offset) (inline ,(make-info-load 'integer-64 #f) + ,%load ,x ,%zero (immediate ,x-offset))) + ,(loop (fx+ offset 8) (fx+ x-offset 8) (fx- len 8)))] + [(>= len 4) + `(seq + (set! ,(%mref ,%sp ,offset) (inline ,(make-info-load 'integer-32 #f) + ,%load ,x ,%zero (immediate ,x-offset))) + ,(loop (fx+ offset 4) (fx+ x-offset 4) (fx- len 4)))] + [(>= len 2) + `(seq + (set! ,(%mref ,%sp ,offset) (inline ,(make-info-load 'integer-16 #f) + ,%load ,x ,%zero (immediate ,x-offset))) + ,(loop (fx+ offset 2) (fx+ x-offset 2) (fx- len 2)))] + [else + `(set! ,(%mref ,%sp ,offset) (inline ,(make-info-load 'integer-8 #f) + ,%load ,x ,%zero (immediate ,x-offset)))]))))] + [load-content-regs + (lambda (classes size iint ifp vint vfp) + (lambda (x) ; requires var + (let loop ([size size] [iint iint] [ifp ifp] [classes classes] [x-offset 0]) + (cond + [(null? classes) `(nop)] + [(eq? 'sse (car classes)) + (cond + [(fx= size 4) + ;; Must be the last element + `(inline ,(make-info-loadfl (vector-ref vfp ifp)) ,%load-single ,x ,%zero (immediate ,x-offset))] + [else + `(seq + (inline ,(make-info-loadfl (vector-ref vfp ifp)) ,%load-double ,x ,%zero (immediate ,x-offset)) + ,(loop (fx- size 8) iint (fx+ ifp 1) (cdr classes) (fx+ x-offset 8)))])] + ;; Remaining cases are integers: + [(>= size 8) + `(seq + (set! ,(vector-ref vint iint) (inline ,(make-info-load 'integer-64 #f) + ,%load ,x ,%zero (immediate ,x-offset))) + ,(loop (fx- size 8) (fx+ iint 1) ifp (cdr classes) (fx+ x-offset 8)))] + ;; Remaining cases must be the last element + [else + (let loop ([reg (vector-ref vint iint)] [size size] [x-offset x-offset]) + (cond + [(= size 4) + `(set! ,reg (inline ,(make-info-load 'unsigned-32 #f) + ,%load ,x ,%zero (immediate ,x-offset)))] + [(= size 2) + `(set! ,reg (inline ,(make-info-load 'unsigned-16 #f) + ,%load ,x ,%zero (immediate ,x-offset)))] + [(= size 1) + `(set! ,reg (inline ,(make-info-load 'unsigned-8 #f) + ,%load ,x ,%zero (immediate ,x-offset)))] + [(> size 4) + ;; 5, 6, or 7: multiple steps to avoid reading too many bytes + (let ([tmp %rax]) ;; ?? ok to use %rax? + (%seq + ,(loop reg (fx- size 4) (fx+ x-offset 4)) + (set! ,reg ,(%inline sll ,reg (immediate 32))) + ,(loop tmp 4 x-offset) + (set! ,reg ,(%inline + ,reg ,tmp))))] + [else + ;; 3: multiple steps to avoid reading too many bytes + (let ([tmp %rax]) ;; ?? ok to use %rax? + (%seq + ,(loop reg (fx- size 2) (fx+ x-offset 2)) + (set! ,reg ,(%inline sll ,reg (immediate 16))) + ,(loop tmp 2 x-offset) + (set! ,reg ,(%inline + ,reg ,tmp))))]))]))))] + [add-int-regs + (lambda (ints iint vint regs) + (cond + [(fx= 0 ints) regs] + [else + (add-int-regs (fx- ints 1) (fx+ iint 1) vint + (cons (vector-ref vint iint) regs))]))] [do-args (lambda (types vint vfp) (if-feature windows @@ -2476,6 +2643,44 @@ (loop (cdr types) (cons (load-single-stack isp) locs) regs i (fx+ isp 8)))] + [(fp-ftd& ,ftd) + (cond + [(memv ($ftd-size ftd) '(1 2 4 8)) + ;; pass as value in register or as value on the stack + (cond + [(< i 4) + ;; pass as value in register + (cond + [(and (not ($ftd-compound? ftd)) + (eq? 'float (caar ($ftd->members ftd)))) + ;; float or double + (loop (cdr types) + (cons (load-content-regs '(sse) ($ftd-size ftd) i i vint vfp) locs) + (add-int-regs 1 i vint regs) (fx+ i 1) isp)] + [else + ;; integer + (loop (cdr types) + (cons (load-content-regs '(integer) ($ftd-size ftd) i i vint vfp) locs) + (add-int-regs 1 i vint regs) (fx+ i 1) isp)])] + [else + ;; pass as value on the stack + (loop (cdr types) + (cons (load-content-stack isp ($ftd-size ftd)) locs) + regs i (fx+ isp (align ($ftd-size ftd) 8)))])] + [else + ;; pass by reference in register or by reference on the stack + (cond + [(< i 4) + ;; pass by reference in a register + (let ([reg (vector-ref vint i)]) + (loop (cdr types) + (cons (load-int-reg (car types) reg) locs) + (cons reg regs) (fx+ i 1) isp))] + [else + ;; pass by reference on the stack + (loop (cdr types) + (cons (load-int-stack isp) locs) + regs i (fx+ isp 8))])])] [else (if (< i 4) (let ([reg (vector-ref vint i)]) @@ -2506,6 +2711,22 @@ (loop (cdr types) (cons (load-single-stack isp) locs) regs iint ifp (fx+ isp 8)))] + [(fp-ftd& ,ftd) + (let* ([classes (classify-eightbytes ftd)] + [ints (count 'integer classes)] + [fps (count 'sse classes)]) + (cond + [(pass-here-by-stack? classes iint ints ifp fps) + ;; pass on the stack + (loop (cdr types) + (cons (load-content-stack isp ($ftd-size ftd)) locs) + regs iint ifp (fx+ isp (align ($ftd-size ftd) 8)))] + [else + ;; pass in registers + (loop (cdr types) + (cons (load-content-regs classes ($ftd-size ftd) iint ifp vint vfp) locs) + (add-int-regs ints iint vint regs) + (fx+ iint ints) (fx+ ifp fps) isp)]))] [else (if (< iint 6) (let ([reg (vector-ref vint iint)]) @@ -2516,6 +2737,35 @@ (loop (cdr types) (cons (load-int-stack isp) locs) regs iint ifp (fx+ isp 8)))])))))]) + (define (add-save-fill-target fill-result-here? frame-size locs) + (cond + [fill-result-here? + ;; The callee isn't expecting a pointer to fill with the result. + ;; Stash the pointer as an extra argument, and then when the + ;; function returns, we'll move register content for the result + ;; into the pointer's target + (values (fx+ frame-size (constant ptr-bytes)) + (append locs + (list + (lambda (x) ; requires var + `(set! ,(%mref ,%sp ,frame-size) ,x)))))] + [else + (values frame-size locs)])) + (define (add-fill-result c-call saved-offset classes) + (let loop ([classes classes] [offset 0] [iregs (reg-list %rax %rdx)] [fpregs (reg-list %Cfparg1 %Cfparg2)]) + (cond + [(null? classes) + `(seq + ,c-call + (set! ,%rcx ,(%mref ,%sp ,saved-offset)))] + [(eq? 'sse (car classes)) + `(seq + ,(loop (cdr classes) (fx+ offset 8) iregs (cdr fpregs)) + (inline ,(make-info-loadfl (car fpregs)) ,%store-double ,%rcx ,%zero (immediate ,offset)))] + [else + `(seq + ,(loop (cdr classes) (fx+ offset 8) (cdr iregs) fpregs) + (set! ,(%mref ,%rcx ,offset) ,(car iregs)))]))) (define returnem (lambda (frame-size locs ccall r-loc) ; need to maintain 16-byte alignment, ignoring the return address @@ -2535,51 +2785,60 @@ `(set! ,%sp ,(%inline + ,%sp (immediate ,frame-size))))))))) (lambda (info) (safe-assert (reg-callee-save? %tc)) ; no need to save-restore - (let ([conv (info-foreign-conv info)] - [arg-type* (info-foreign-arg-type* info)] - [result-type (info-foreign-result-type info)]) - (with-values (do-args arg-type* (make-vint) (make-vfp)) + (let* ([conv (info-foreign-conv info)] + [arg-type* (info-foreign-arg-type* info)] + [result-type (info-foreign-result-type info)] + [result-classes (classify-type result-type)] + [fill-result-here? (result-fits-in-registers? result-classes)]) + (with-values (do-args (if fill-result-here? (cdr arg-type*) arg-type*) (make-vint) (make-vfp)) (lambda (frame-size nfp locs live*) - (returnem frame-size locs - (lambda (t0) - (if-feature windows - (%seq - (set! ,%sp ,(%inline - ,%sp (immediate 32))) - (inline ,(make-info-kill*-live* (reg-list %rax) live*) ,%c-call ,t0) - (set! ,%sp ,(%inline + ,%sp (immediate 32)))) - (%seq - ; System V ABI varargs functions require count of fp regs used in %al register. - ; since we don't know if the callee is a varargs function, we always set it. - (set! ,%rax (immediate ,nfp)) - (inline ,(make-info-kill*-live* (reg-list %rax) (cons %rax live*)) ,%c-call ,t0)))) - (nanopass-case (Ltype Type) result-type - [(fp-double-float) - (lambda (lvalue) - `(inline ,(make-info-loadfl %Cfpretval) ,%store-double ,lvalue ,%zero - ,(%constant flonum-data-disp)))] - [(fp-single-float) - (lambda (lvalue) - `(inline ,(make-info-loadfl %Cfpretval) ,%store-single->double ,lvalue ,%zero - ,(%constant flonum-data-disp)))] - [(fp-integer ,bits) - (case bits - [(8) (lambda (lvalue) `(set! ,lvalue ,(%inline sext8 ,%rax)))] - [(16) (lambda (lvalue) `(set! ,lvalue ,(%inline sext16 ,%rax)))] - [(32) (lambda (lvalue) `(set! ,lvalue ,(%inline sext32 ,%rax)))] - [(64) (lambda (lvalue) `(set! ,lvalue ,%rax))] - [else ($oops 'assembler-internal - "unexpected asm-foreign-procedures fp-integer size ~s" - bits)])] - [(fp-unsigned ,bits) - (case bits - [(8) (lambda (lvalue) `(set! ,lvalue ,(%inline zext8 ,%rax)))] - [(16) (lambda (lvalue) `(set! ,lvalue ,(%inline zext16 ,%rax)))] - [(32) (lambda (lvalue) `(set! ,lvalue ,(%inline zext32 ,%rax)))] - [(64) (lambda (lvalue) `(set! ,lvalue ,%rax))] - [else ($oops 'assembler-internal - "unexpected asm-foreign-procedures fp-unsigned size ~s" - bits)])] - [else (lambda (lvalue) `(set! ,lvalue ,%rax))]))))))))) + (with-values (add-save-fill-target fill-result-here? frame-size locs) + (lambda (frame-size locs) + (returnem frame-size locs + (lambda (t0) + (let ([c-call + (if-feature windows + (%seq + (set! ,%sp ,(%inline - ,%sp (immediate 32))) + (inline ,(make-info-kill*-live* (reg-list %rax) live*) ,%c-call ,t0) + (set! ,%sp ,(%inline + ,%sp (immediate 32)))) + (%seq + ;; System V ABI varargs functions require count of fp regs used in %al register. + ;; since we don't know if the callee is a varargs function, we always set it. + (set! ,%rax (immediate ,nfp)) + (inline ,(make-info-kill*-live* (reg-list %rax) (cons %rax live*)) ,%c-call ,t0)))]) + (cond + [fill-result-here? + (add-fill-result c-call (fx- frame-size (constant ptr-bytes)) result-classes)] + [else c-call]))) + (nanopass-case (Ltype Type) result-type + [(fp-double-float) + (lambda (lvalue) + `(inline ,(make-info-loadfl %Cfpretval) ,%store-double ,lvalue ,%zero + ,(%constant flonum-data-disp)))] + [(fp-single-float) + (lambda (lvalue) + `(inline ,(make-info-loadfl %Cfpretval) ,%store-single->double ,lvalue ,%zero + ,(%constant flonum-data-disp)))] + [(fp-integer ,bits) + (case bits + [(8) (lambda (lvalue) `(set! ,lvalue ,(%inline sext8 ,%rax)))] + [(16) (lambda (lvalue) `(set! ,lvalue ,(%inline sext16 ,%rax)))] + [(32) (lambda (lvalue) `(set! ,lvalue ,(%inline sext32 ,%rax)))] + [(64) (lambda (lvalue) `(set! ,lvalue ,%rax))] + [else ($oops 'assembler-internal + "unexpected asm-foreign-procedures fp-integer size ~s" + bits)])] + [(fp-unsigned ,bits) + (case bits + [(8) (lambda (lvalue) `(set! ,lvalue ,(%inline zext8 ,%rax)))] + [(16) (lambda (lvalue) `(set! ,lvalue ,(%inline zext16 ,%rax)))] + [(32) (lambda (lvalue) `(set! ,lvalue ,(%inline zext32 ,%rax)))] + [(64) (lambda (lvalue) `(set! ,lvalue ,%rax))] + [else ($oops 'assembler-internal + "unexpected asm-foreign-procedures fp-unsigned size ~s" + bits)])] + [else (lambda (lvalue) `(set! ,lvalue ,%rax))]))))))))))) (define asm-foreign-callable #| @@ -2600,7 +2859,7 @@ | callee-save registers | RBX, RBP, RDI, RSI, R12, R13, R14, R15 (8 quads) | | +---------------------------+ - | pad word | one quad + | pad word / indirect space | one quad sp+0: +---------------------------+<- 16-byte boundary @@ -2609,11 +2868,14 @@ +---------------------------+ | | | incoming stack args | - sp+176: | | + sp+192: | | +---------------------------+ <- 16-byte boundary | incoming return address | one quad +---------------------------+ | pad word | one quad + +---------------------------+ + | indirect result space | two quads + sp+160 | (for & results via regs) | +---------------------------+<- 16-byte boundary | | | saved register args | space for Carg*, Cfparg* (14 quads) @@ -2661,6 +2923,10 @@ "unexpected load-int-stack fp-unsigned size ~s" bits)])] [else `(set! ,lvalue ,(%mref ,%sp ,offset))])))) + (define load-stack-address + (lambda (offset) + (lambda (lvalue) ; requires lvalue + `(set! ,lvalue ,(%inline + ,%sp (immediate ,offset)))))) (define save-arg-regs (lambda (types) (define vint (make-vint)) @@ -2684,6 +2950,40 @@ ,%sp ,%zero (immediate ,isp)) ,(f (cdr types) (fx+ i 1) (fx+ isp 8))) (f (cdr types) i isp))] + [(fp-ftd& ,ftd) + (cond + [(memv ($ftd-size ftd) '(1 2 4 8)) + ;; receive as value in register or on the stack + (cond + [(< i 4) + ;; receive in register + (cond + [(and (not ($ftd-compound? ftd)) + (eq? 'float (caar ($ftd->members ftd)))) + ;; float or double + `(seq + (inline ,(make-info-loadfl (vector-ref vfp i)) ,%store-double + ,%sp ,%zero (immediate ,isp)) + ,(f (cdr types) (fx+ i 1) (fx+ isp 8)))] + [else + ;; integer + `(seq + (set! ,(%mref ,%sp ,isp) ,(vector-ref vint i)) + ,(f (cdr types) (fx+ i 1) (fx+ isp 8)))])] + [else + ;; receive by value on the stack + (f (cdr types) i isp)])] + [else + ;; receive by reference in register or on the stack + (cond + [(< i 4) + ;; receive by reference in register + `(seq + (set! ,(%mref ,%sp ,isp) ,(vector-ref vint i)) + ,(f (cdr types) (fx+ i 1) (fx+ isp 8)))] + [else + ;; receive by reference on the stack + (f (cdr types) i isp)])])] [else (if (< i 4) (%seq @@ -2708,6 +3008,29 @@ ,%sp ,%zero (immediate ,isp)) ,(f (cdr types) iint (fx+ ifp 1) (fx+ isp 8))) (f (cdr types) iint ifp isp))] + [(fp-ftd& ,ftd) + (let* ([classes (classify-eightbytes ftd)] + [ints (count 'integer classes)] + [fps (count 'sse classes)]) + (cond + [(pass-here-by-stack? classes iint ints ifp fps) + ;; receive on the stack + (f (cdr types) iint ifp isp)] + [else + ;; receive via registers + (let reg-loop ([classes classes] [iint iint] [ifp ifp] [isp isp]) + (cond + [(null? classes) + (f (cdr types) iint ifp isp)] + [(eq? (car classes) 'sse) + `(seq + (inline ,(make-info-loadfl (vector-ref vfp ifp)) ,%store-double + ,%sp ,%zero (immediate ,isp)) + ,(reg-loop (cdr classes) iint (fx+ ifp 1) (+ isp 8)))] + [else + `(seq + (set! ,(%mref ,%sp ,isp) ,(vector-ref vint iint)) + ,(reg-loop (cdr classes) (fx+ iint 1) ifp (+ isp 8)))]))]))] [else (if (< iint 6) (%seq @@ -2727,10 +3050,23 @@ (nanopass-case (Ltype Type) (car types) [(fp-double-float) (load-double-stack isp)] [(fp-single-float) (load-single-stack isp)] + [(fp-ftd& ,ftd) + (cond + [(memq ($ftd-size ftd) '(1 2 4 8)) + ;; passed by value + (load-stack-address isp)] + [else + ;; passed by reference + (load-int-stack (car types) isp)])] [else (load-int-stack (car types) isp)]) locs) (fx+ isp 8)))) - (let f ([types types] [locs '()] [iint 0] [ifp 0] [risp 48] [sisp 176]) + (let f ([types types] + [locs '()] + [iint 0] + [ifp 0] + [risp 48] + [sisp 192]) (if (null? types) locs (nanopass-case (Ltype Type) (car types) @@ -2750,6 +3086,23 @@ (f (cdr types) (cons (load-single-stack risp) locs) iint (fx+ ifp 1) (fx+ risp 8) sisp))] + [(fp-ftd& ,ftd) + (let* ([classes (classify-eightbytes ftd)] + [ints (count 'integer classes)] + [fps (count 'sse classes)]) + (cond + [(pass-here-by-stack? classes iint ints ifp fps) + ;; receive on the stack + (f (cdr types) + (cons (load-stack-address sisp) locs) + iint ifp risp (fx+ sisp ($ftd-size ftd)))] + [else + ;; receive via registers; `save-args-regs` has saved + ;; the registers in a suitable order so that the data + ;; is contiguous on the stack + (f (cdr types) + (cons (load-stack-address risp) locs) + (fx+ iint ints) (fx+ ifp fps) (fx+ risp (fx* 8 (fx+ ints fps))) sisp)]))] [else (if (= iint 6) (f (cdr types) @@ -2758,14 +3111,74 @@ (f (cdr types) (cons (load-int-stack (car types) risp) locs) (fx+ iint 1) ifp (fx+ risp 8) sisp))])))))) + (define (do-result result-type result-classes) + (nanopass-case (Ltype Type) result-type + [(fp-ftd& ,ftd) + (cond + [(result-fits-in-registers? result-classes) + ;; Copy content of result area on stack into + ;; the integer and floating-point registers + (let loop ([result-classes result-classes] + [offset (if-feature windows 0 160)] + [int* (list %rax %rdx)] + [fp* (list %Cfpretval %Cfparg2)] + [accum '()] + [live* '()]) + (cond + [(null? result-classes) + (values (lambda () + (if (pair? (cdr accum)) `(seq ,(car accum) ,(cadr accum)) (car accum))) + live*)] + [(eq? (car result-classes) 'integer) + (loop (cdr result-classes) + (fx+ offset 8) + (cdr int*) + fp* + (cons `(set! ,(car int*) ,(%mref ,%sp ,offset)) + accum) + (cons (car int*) live*))] + [(eq? (car result-classes) 'sse) + (loop (cdr result-classes) + (fx+ offset 8) + int* + (cdr fp*) + (cons `(inline ,(make-info-loadfl (car fp*)) ,%load-double ,%sp ,%zero (immediate ,offset)) + accum) + live*)]))] + [else + (values (lambda () + ;; Return pointer that was filled; destination was the first argument + `(set! ,%Cretval ,(%mref ,%sp ,(if-feature windows 80 48)))) + (list %Cretval))])] + [(fp-double-float) + (values + (lambda (x) + `(inline ,(make-info-loadfl %Cfpretval) ,%load-double ,x ,%zero ,(%constant flonum-data-disp))) + '())] + [(fp-single-float) + (values + (lambda (x) + `(inline ,(make-info-loadfl %Cfpretval) ,%load-double->single ,x ,%zero ,(%constant flonum-data-disp))) + '())] + [(fp-void) + (values (lambda () `(nop)) + '())] + [else + (values(lambda (x) + `(set! ,%Cretval ,x)) + (list %Cretval))])) (lambda (info) (let ([conv (info-foreign-conv info)] [arg-type* (info-foreign-arg-type* info)] [result-type (info-foreign-result-type info)]) - (let ([locs (do-stack arg-type*)]) - (values - (lambda () - (%seq + (let* ([result-classes (classify-type result-type)] + [synthesize-first? (and result-classes + (result-fits-in-registers? result-classes))] + [locs (do-stack (if synthesize-first? (cdr arg-type*) arg-type*))]) + (let-values ([(get-result result-regs) (do-result result-type result-classes)]) + (values + (lambda () + (%seq ,(if-feature windows (%seq ,(save-arg-regs arg-type*) @@ -2779,7 +3192,7 @@ ,(%inline push ,%r15) (set! ,%sp ,(%inline - ,%sp (immediate 8)))) (%seq - (set! ,%sp ,(%inline - ,%sp (immediate 120))) + (set! ,%sp ,(%inline - ,%sp (immediate 136))) ,(%inline push ,%rbx) ,(%inline push ,%rbp) ,(%inline push ,%r12) @@ -2792,9 +3205,14 @@ (set! ,%rax ,(%inline get-tc)) (set! ,%tc ,%rax)) `(set! ,%tc (literal ,(make-info-literal #f 'entry (lookup-c-entry thread-context) 0)))))) - (reverse locs) - (lambda (fv* Scall->result-type) - (in-context Tail + (let ([locs (reverse locs)]) + (if synthesize-first? + (cons (load-stack-address (if-feature windows 0 160)) ; space on stack for results to be returned via registers + locs) + locs)) + get-result + (lambda () + (in-context Tail (%seq ,(if-feature windows (%seq @@ -2814,7 +3232,6 @@ (set! ,%r12 ,(%inline pop)) (set! ,%rbp ,(%inline pop)) (set! ,%rbx ,(%inline pop)) - (set! ,%sp ,(%inline + ,%sp (immediate 120))))) - (jump (literal ,(make-info-literal #f 'entry Scall->result-type 0)) - (,%rbx ,%rbp ,%r12 ,%r13 ,%r14 ,%r15 ,fv* ...))))))))))))) + (set! ,%sp ,(%inline + ,%sp (immediate 136))))) + (asm-c-return ,null-info ,result-regs ...))))))))))))) ) From aa8bea9648dc8e211970783feeacf35dbbf54f16 Mon Sep 17 00:00:00 2001 From: dybvig Date: Tue, 13 Mar 2018 12:28:20 -0400 Subject: [PATCH 12/21] reworked the S_call_help/S_return CCHAIN handling to fix a bug in which the signal handler could trip over the NULL jumpbuf in a CCHAIN record. schlib.c remade boot files original commit: d8c270403121547101cb523cc1f80a569dbb0378 --- LOG | 3 +++ c/schlib.c | 18 ++++++++++-------- 2 files changed, 13 insertions(+), 8 deletions(-) diff --git a/LOG b/LOG index 89a15ea1a7..32eb516dc3 100644 --- a/LOG +++ b/LOG @@ -892,3 +892,6 @@ schlib.c, prim.c, externs.h mats/foreign4.c, mats/foreign.ms mats/Mf-* foreign.stex, release_notes.stex +- reworked the S_call_help/S_return CCHAIN handling to fix a bug in which + the signal handler could trip over the NULL jumpbuf in a CCHAIN record. + schlib.c diff --git a/c/schlib.c b/c/schlib.c index be9259ad45..f9ea4b6ad4 100644 --- a/c/schlib.c +++ b/c/schlib.c @@ -219,14 +219,17 @@ void S_call_help(tc, singlep, lock_ts) ptr tc; IBOOL singlep; IBOOL lock_ts; { jb = CREATEJMPBUF(); if (jb == NULL) S_error_abort("unable to allocate memory for jump buffer"); - FRAME(tc, -1) = CCHAIN(tc) = Scons(Scons(jb, code), CCHAIN(tc)); if (lock_ts) { /* Lock a code object passed in TS, which is a more immediate caller whose return address is on the C stack */ Slock_object(TS(tc)); - CCHAIN(tc) = Scons(Scons(NULL, TS(tc)), CCHAIN(tc)); + CCHAIN(tc) = Scons(Scons(jb, Scons(code,TS(tc))), CCHAIN(tc)); + } else { + CCHAIN(tc) = Scons(Scons(jb, Scons(code,Sfalse)), CCHAIN(tc)); } + FRAME(tc, -1) = CCHAIN(tc); + switch (SETJMP(jb)) { case 0: /* first time */ S_generic_invoke(tc, S_G.invoke_code_object); @@ -268,11 +271,10 @@ void S_call_any_results() { S_call_help(tc, 0, 1); } -/* cchain = ((jb . co) ...) */ +/* cchain = ((jb . (co . maybe-co)) ...) */ void S_return() { ptr tc = get_thread_context(); ptr xp, yp; - void *jb; SFP(tc) = (ptr)((ptr *)SFP(tc) - 2); @@ -286,11 +288,11 @@ void S_return() { /* error checks are done; now unlock affected code objects */ for (xp = CCHAIN(tc); ; xp = Scdr(xp)) { - Sunlock_object(CDAR(xp)); + ptr p = CDAR(xp); + Sunlock_object(Scar(p)); + if (Scdr(p) != Sfalse) Sunlock_object(Scdr(p)); if (xp == yp) break; - jb = CAAR(xp); - if (jb != NULL) - FREEJMPBUF(jb); + FREEJMPBUF(CAAR(xp)); } /* reset cchain and return via longjmp */ From 68e1ae0ece6145b24ba885b4fc1d0ae8ca66732d Mon Sep 17 00:00:00 2001 From: Oscar Waddell Date: Tue, 27 Mar 2018 12:52:43 -0400 Subject: [PATCH 13/21] install equates.h, kernel.o, and main.o on unix-like systems original commit: fd7812d05c791e05eb65982c93bd8c36f7a0404f --- LOG | 2 ++ makefiles/Mf-install.in | 3 +++ 2 files changed, 5 insertions(+) diff --git a/LOG b/LOG index 32eb516dc3..206a7031ce 100644 --- a/LOG +++ b/LOG @@ -895,3 +895,5 @@ - reworked the S_call_help/S_return CCHAIN handling to fix a bug in which the signal handler could trip over the NULL jumpbuf in a CCHAIN record. schlib.c +- install equates.h, kernel.o, and main.o on unix-like systems + Mf-install.in diff --git a/makefiles/Mf-install.in b/makefiles/Mf-install.in index a965bbd957..6446561664 100644 --- a/makefiles/Mf-install.in +++ b/makefiles/Mf-install.in @@ -123,6 +123,9 @@ libbininstall: ${LibBin} ln -f ${LibBin}/scheme.boot ${LibBin}/${InstallSchemeName}.boot;\ fi ln -sf ${LibBin}/scheme.boot ${LibBin}/${InstallScriptName}.boot; + $I -m 444 ${Include}/equates.h ${LibBin} + $I -m 444 ${Include}/kernel.o ${LibBin} + $I -m 444 ${Include}/main.o ${LibBin} $I -m 444 ${Include}/scheme.h ${LibBin} maninstall: scheme.1 petite.1 ${Man} From 718cfada6f2b916466c578aac75436bd709c7601 Mon Sep 17 00:00:00 2001 From: dyb Date: Tue, 27 Mar 2018 14:06:42 -0700 Subject: [PATCH 14/21] corrected typo reported by github:@ocyzl original commit: 5b6b89cd8f030d7a94194d94bed8f56fade5af34 --- csug/numeric.stex | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/csug/numeric.stex b/csug/numeric.stex index a3a6242400..453b2702e2 100644 --- a/csug/numeric.stex +++ b/csug/numeric.stex @@ -117,7 +117,7 @@ Section~\ref{SECTNUMERICMISC}. The Revised$^6$ Report distinguishes two types of special numeric objects: fixnums and flonums. {\ChezScheme} additionally distinguishes \emph{bignums} (exact integers outside -of the bignum range) and \emph{ratnums} (ratios of exact integers). +of the fixnum range) and \emph{ratnums} (ratios of exact integers). It also provides a predicate for recognizing \emph{cflonums}, which are flonums or inexact complex numbers. From 9991dd14ae0a534ad8c280ebfa4eb51c1453d932 Mon Sep 17 00:00:00 2001 From: dyb Date: Wed, 28 Mar 2018 08:56:54 -0700 Subject: [PATCH 15/21] fixed typo reported by github:@guenchi original commit: 27e2a5c2d076e03ac6a70da06250a393f2253ea1 --- csug/foreign.stex | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/csug/foreign.stex b/csug/foreign.stex index f0dc71dd2b..1e6ff32651 100644 --- a/csug/foreign.stex +++ b/csug/foreign.stex @@ -1067,8 +1067,8 @@ void cb_init(void) { callbacks[i] = (CB)0; } -void register_callback(char c, int cb) { - callbacks[c] = (CB)cb; +void register_callback(char c, CB cb) { + callbacks[c] = cb; } void event_loop(void) { @@ -1090,7 +1090,7 @@ Interfaces to these functions may be defined in Scheme as follows. (define cb-init (foreign-procedure "cb_init" () void)) (define register-callback - (foreign-procedure "register_callback" (char int) void)) + (foreign-procedure "register_callback" (char void*) void)) (define event-loop (foreign-procedure "event_loop" () void)) \endschemedisplay From b3cf76c3e8535da575ddf2f1d8d4e3d5a7c1c355 Mon Sep 17 00:00:00 2001 From: dyb Date: Wed, 28 Mar 2018 09:25:20 -0700 Subject: [PATCH 16/21] Makefile-csug.in install target is now consistent with the project page csug directory and pdf names, and newrelease now updates Makefile-csug.in accordingly. original commit: 63b1e7237d82d3af3ec594c35e3d5b9c7e58ae54 --- makefiles/Makefile-csug.in | 5 +++-- newrelease | 7 +++++++ 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/makefiles/Makefile-csug.in b/makefiles/Makefile-csug.in index 8254e67130..df24092b45 100644 --- a/makefiles/Makefile-csug.in +++ b/makefiles/Makefile-csug.in @@ -1,7 +1,7 @@ m = $(m) Scheme=../$m/bin/$m/scheme -b ../$m/boot/$m/petite.boot -b ../$m/boot/$m/scheme.boot STEXLIB=../stex -installdir=/tmp/csug9 +installdir=/tmp/csug9.5 INSTALL=../$m/installsh x = csug @@ -16,7 +16,8 @@ target: logcheck1 logcheck2 checklibs $(x).html $(x).pdf install: target $(INSTALL) -m 2755 -d $(installdir) - $(INSTALL) -m 0644 --ifdiff *.html *.pdf *.css $(installdir) + $(INSTALL) -m 0644 --ifdiff *.html *.css $(installdir) + $(INSTALL) -m 0644 --ifdiff csug.pdf $(installdir)/csug9_5.pdf $(INSTALL) -m 2755 -d $(installdir)/canned $(INSTALL) -m 0644 --ifdiff canned/* $(installdir)/canned $(INSTALL) -m 2755 -d $(installdir)/gifs diff --git a/newrelease b/newrelease index 01b7f5fdef..34803ab74c 100755 --- a/newrelease +++ b/newrelease @@ -35,6 +35,9 @@ if ({(echo -n "$1" | grep '^[0-9]\.[0-9]$' >& /dev/null)}) then # set ZR to release number w/o "." set ZR = $MR$mR + + # set underscoreR to release number w/ "_" in place of "." + set underscoreR = $MR"_"$mR else if ({(echo -n "$1" | grep '^[0-9]\.[0-9]\.[0-9]$' >& /dev/null)}) then # set MR to major release number set tmp = $R:r @@ -48,6 +51,9 @@ else if ({(echo -n "$1" | grep '^[0-9]\.[0-9]\.[0-9]$' >& /dev/null)}) then # set ZR to release number w/o "." set ZR = $MR$mR$bR + + # set underscoreR to release number w/ "_" in place of "." + set underscoreR = $MR"_"$mR"_"$bR else echo "invalid release number $R" exit 1 @@ -87,6 +93,7 @@ set updatedfiles = ($updatedfiles NOTICE) mkdir makefiles sed -e "s/csv[0-9]\.[0-9]\(\.[0-9]\)*/csv$R/" ../makefiles/Mf-install.in > makefiles/Mf-install.in +sed -e "s/csug[0-9]\.[0-9]\(\.[0-9]\)*/csug$R/" -e "s/csug[0-9]_[0-9]\(_[0-9]\)*/csug$underscoreR/" ../makefiles/Makefile-csug.in > makefiles/Makefile-csug.in set updatedfiles = ($updatedfiles makefiles/Mf-install.in) /bin/rm scheme.1.in From 9d1b935705354139bb1980735beff1182923791b Mon Sep 17 00:00:00 2001 From: Oscar Waddell Date: Wed, 28 Mar 2018 15:11:10 -0400 Subject: [PATCH 17/21] standalone export form now handles (import import-spec ...) original commit: 09b6745679892fe2fac761d5849fe78b87d57dcf --- LOG | 2 ++ mats/8.ms | 13 +++++++++++++ release_notes/release_notes.stex | 6 ++++++ s/syntax.ss | 18 +++++++++++------- 4 files changed, 32 insertions(+), 7 deletions(-) diff --git a/LOG b/LOG index 206a7031ce..d5f7e40a72 100644 --- a/LOG +++ b/LOG @@ -897,3 +897,5 @@ schlib.c - install equates.h, kernel.o, and main.o on unix-like systems Mf-install.in +- standalone export form now handles (import import-spec ...) + 8.ms, syntax.ss, release_notes.stex diff --git a/mats/8.ms b/mats/8.ms index 20efa5c3d8..33e183fdc3 100644 --- a/mats/8.ms +++ b/mats/8.ms @@ -7976,6 +7976,19 @@ (equal? (let () (import ($l3)) (f (f 3))) 3) + (begin + ;; (export import-spec ...) empty case + (library ($empty) (export) (import (chezscheme)) (export (import))) + #t) + (begin + (library ($l4-A) (export a) (import (chezscheme)) (define a 1)) + (library ($l4-B) (export b) (import (chezscheme)) (define b 2)) + #t) + (equal? '(1 2) (let () (import ($l4-A) ($l4-B)) (list a b))) + (begin + ;; (export import-spec ...) multiple imports case + (library ($l4-C) (export) (import (chezscheme)) (export (import ($l4-A) ($l4-B)))) + (equal? '(1 2) (let () (import ($l4-C)) (list a b)))) ) (mat library2 diff --git a/release_notes/release_notes.stex b/release_notes/release_notes.stex index c0678c7a0b..278017dc88 100644 --- a/release_notes/release_notes.stex +++ b/release_notes/release_notes.stex @@ -1554,6 +1554,12 @@ in fasl files does not generally make sense. %----------------------------------------------------------------------------- \section{Bug Fixes}\label{section:bugfixes} +\subsection{Incomplete handling of import specs within standalone export forms} + +A bug that limited the \scheme{(import \var{import-spec} \dots)} form within a +standalone \scheme{export} form to \scheme{(import \var{import-spec})} has been +fixed. + \subsection{Permission denied after deleting files or directories in Windows} In Windows, deleting a file or directory briefly leaves the file or diff --git a/s/syntax.ss b/s/syntax.ss index 574aead35a..f6c66ea197 100644 --- a/s/syntax.ss +++ b/s/syntax.ss @@ -4280,14 +4280,18 @@ (append #'(old-id ...) exports) (append #'(old-id ...) exports-to-check) (fold-right resolve&add-id new-exports #'(old-id ...) #'(new-id ...)))] - [(?import impspec) + [(?import impspec ...) (sym-kwd? ?import import) - (let-values ([(mid tid imps) (help-determine-imports #'impspec r #f)]) - (let ([imps (if (import-interface? imps) (module-exports imps) imps)]) - (values - (append (map car imps) exports) - exports-to-check - (fold-right add-id new-exports (map cdr imps)))))] + (let process-impspecs ([impspec* #'(impspec ...)]) + (if (null? impspec*) + (values exports exports-to-check new-exports) + (let-values ([(_mid _tid imps) (help-determine-imports (car impspec*) r #f)] + [(exports exports-to-check new-exports) (process-impspecs (cdr impspec*))]) + (let ([imps (if (import-interface? imps) (module-exports imps) imps)]) + (values + (append (map car imps) exports) + exports-to-check + (fold-right add-id new-exports (map cdr imps)))))))] [_ (syntax-error x "invalid export spec")])))))]) (g (cdr expspec**) exports exports-to-check new-exports)))))) ) From 9aa1fc4caa99eef65add1cf589d6c847f33027b6 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 22 Jan 2018 17:01:46 -0700 Subject: [PATCH 18/21] add collect-rendezvous original commit: f7cb82d97e34b14bfbafe635b0d4a294527b02c3 --- LOG | 2 ++ c/prim.c | 1 + csug/smgmt.stex | 19 ++++++++++++++++ mats/7.ms | 39 ++++++++++++++++++++++++++++++++ release_notes/release_notes.stex | 12 ++++++++++ s/7.ss | 6 +++++ s/primdata.ss | 1 + 7 files changed, 80 insertions(+) diff --git a/LOG b/LOG index d5f7e40a72..a1b161c06f 100644 --- a/LOG +++ b/LOG @@ -899,3 +899,5 @@ Mf-install.in - standalone export form now handles (import import-spec ...) 8.ms, syntax.ss, release_notes.stex +- add collect-rendezvous + prim.c, 7.ss, primdata.ss, 7.ms, smgmt.stex, release_notes.stex diff --git a/c/prim.c b/c/prim.c index 0041012a81..65269ad948 100644 --- a/c/prim.c +++ b/c/prim.c @@ -177,6 +177,7 @@ void S_prim_init() { Sforeign_symbol("(cs)enable_object_counts", (void *)S_enable_object_counts); Sforeign_symbol("(cs)set_enable_object_counts", (void *)S_set_enable_object_counts); Sforeign_symbol("(cs)object_counts", (void *)S_object_counts); + Sforeign_symbol("(cs)fire_collector", (void *)S_fire_collector); } static void s_instantiate_code_object() { diff --git a/csug/smgmt.stex b/csug/smgmt.stex index 07d5809a89..854129866e 100644 --- a/csug/smgmt.stex +++ b/csug/smgmt.stex @@ -153,6 +153,25 @@ The system determines which generations to collect, based on \var{g} and \var{tg} if provided, as described in the lead-in to this section. +%---------------------------------------------------------------------------- +\entryheader +\formdef{collect-rendezvous}{\categoryprocedure}{(collect-rendezvous)} +\returns unspecified +\listlibraries +\endentryheader + +\noindent +Requests a garbage collection in the same way as when the system +determines that a collection should occur. All running threads are +coordinated so that one of them calls the collect-request handler, while +the other threads pause until the handler returns. + +Note that if the collect-request handler (see +\scheme{collect-request-handler}) does not call \scheme{collect}, then +\scheme{collect-rendezvous} does not actualy perform a garbage +collection. + + %---------------------------------------------------------------------------- \entryheader \formdef{collect-notify}{\categoryglobalparameter}{collect-notify} diff --git a/mats/7.ms b/mats/7.ms index 29bba8229c..36d062c723 100644 --- a/mats/7.ms +++ b/mats/7.ms @@ -3589,6 +3589,45 @@ evaluating module init (or (not a) (not (assq 'static (cdr a))))) ) +(mat collect-rendezvous + (begin + (define (check-working-gc collect) + (with-interrupts-disabled + (let ([p (weak-cons (gensym) #f)]) + (collect) + (eq? (car p) #!bwp)))) + (and (check-working-gc collect) + (check-working-gc collect-rendezvous))) + + (or (not (threaded?)) + (let ([m (make-mutex)] + [c (make-condition)] + [done? #f]) + (fork-thread + (lambda () + (let loop () + (mutex-acquire m) + (cond + [done? + (condition-signal c) + (mutex-release m)] + [else + (mutex-release m) + (loop)])))) + (and (check-working-gc collect-rendezvous) + ;; End thread: + (begin + (mutex-acquire m) + (set! done? #t) + (condition-wait c m) + (mutex-release m) + ;; Make sure the thread is really done + (let loop () + (unless (= 1 (#%$top-level-value '$active-threads)) + (loop))) + ;; Plain `collect` should work again: + (check-working-gc collect))))) + ) ;;; section 7.6: diff --git a/release_notes/release_notes.stex b/release_notes/release_notes.stex index 278017dc88..564c013d50 100644 --- a/release_notes/release_notes.stex +++ b/release_notes/release_notes.stex @@ -58,6 +58,18 @@ Online versions of both books can be found at %----------------------------------------------------------------------------- \section{Functionality Changes}\label{section:functionality} +\subsection{Garbage collection and threads (9.5.1)} + +A new \scheme{collect-rendezvous} function performs a garbage +collection in the same way as when the system determines that a +collection should occur. For many purposes, +\scheme{collect-rendezvous} is a variant of \scheme{collect} that +works when multiple threads are active. More precisely, the +\scheme{collect-rendezvous} function invokes the collect-request +handler (in an unspecified thread) after synchronizing all active +threads and temporarily deactivating all but the one used to call the +collect-request handler. + \subsection{Foreign-procedure struct arguments and results (9.5.1)} A new \scheme{(& \var{ftype})} form allows a struct or union to be diff --git a/s/7.ss b/s/7.ss index eeb308dbcc..e177bc71ca 100644 --- a/s/7.ss +++ b/s/7.ss @@ -750,6 +750,12 @@ ($oops who "invalid target generation ~s for generation ~s" gtarget g)) (collect2 g (if (eq? gtarget 'static) (constant static-generation) gtarget))]))) +(set! collect-rendezvous + (let ([fire-collector (foreign-procedure "(cs)fire_collector" () void)]) + (lambda () + (fire-collector) + ($collect-rendezvous)))) + (set! keyboard-interrupt-handler ($make-thread-parameter (lambda () diff --git a/s/primdata.ss b/s/primdata.ss index 47aa9a4172..6f719e2eda 100644 --- a/s/primdata.ss +++ b/s/primdata.ss @@ -1197,6 +1197,7 @@ (clear-input-port [sig [() (input-port) -> (void)]] [flags true]) (clear-output-port [sig [() (output-port) -> (void)]] [flags true]) (collect [sig [() (sub-ufixnum) (sub-ufixnum ptr) -> (void)]] [flags true]) + (collect-rendezvous [sig [() -> (void)]] [flags]) (collections [sig [() -> (uint)]] [flags unrestricted alloc]) (compile [sig [(sub-ptr) (sub-ptr environment) -> (ptr ...)]] [flags]) (compile-file [sig [(pathname) (pathname pathname) (pathname pathname sub-symbol) -> (void)]] [flags true]) From 30934965f3412496c65ee0832eae004a688d0314 Mon Sep 17 00:00:00 2001 From: dyb Date: Wed, 4 Apr 2018 15:34:54 -0700 Subject: [PATCH 19/21] - added identifier? checks to detect attempts to use non-identifier field names in define-record-type field specs. syntax.ss, record.ms, root-experr* original commit: be022d947b3831afcb4c538151899f9bd6559615 --- LOG | 4 ++++ mats/record.ms | 18 ++++++++++++++++++ mats/root-experr-compile-0-f-f-f | 8 ++++++++ mats/root-experr-compile-2-f-f-f | 8 ++++++++ s/syntax.ss | 4 ++++ 5 files changed, 42 insertions(+) diff --git a/LOG b/LOG index a1b161c06f..e47cf494c3 100644 --- a/LOG +++ b/LOG @@ -901,3 +901,7 @@ 8.ms, syntax.ss, release_notes.stex - add collect-rendezvous prim.c, 7.ss, primdata.ss, 7.ms, smgmt.stex, release_notes.stex +- added identifier? checks to detect attempts to use non-identifier + field names in define-record-type field specs. + syntax.ss, + record.ms, root-experr* diff --git a/mats/record.ms b/mats/record.ms index b657ea1cbb..c8aa0dcf15 100644 --- a/mats/record.ms +++ b/mats/record.ms @@ -8607,6 +8607,24 @@ (if b (#3%$object-ref 'scheme-object 'x ,fixnum?) 72))) + ; ensure we're checking to make sure field names, accessors, and + ; mutators are identifiers + (error? ; invalid field spec + (define-record-type foo (fields 876))) + (error? ; invalid field spec + (define-record-type foo (fields (mutable (x))))) + (error? ; invalid field spec + (define-record-type foo (fields (immutable "spam")))) + (error? ; invalid field spec + (define-record-type foo (fields (immutable (x) foo-x)))) + (error? ; invalid accessor name + (define-record-type foo (fields (immutable x (foo-x))))) + (error? ; invalid field spec + (define-record-type foo (fields (mutable (x) foo-x foo-x!)))) + (error? ; invalid accessor name + (define-record-type foo (fields (mutable x (foo-x) foo-x!)))) + (error? ; invalid accessor name + (define-record-type foo (fields (mutable x foo-x (foo-x!))))) ) (mat define-record-type-extensions diff --git a/mats/root-experr-compile-0-f-f-f b/mats/root-experr-compile-0-f-f-f index 472415f8e6..f8fa3139df 100644 --- a/mats/root-experr-compile-0-f-f-f +++ b/mats/root-experr-compile-0-f-f-f @@ -7453,6 +7453,14 @@ record.mo:Expected error in mat r6rs-records-syntactic: "invalid define-record-t record.mo:Expected error in mat r6rs-records-syntactic: "no constructor descriptor for define-record record type frob". record.mo:Expected error in mat r6rs-records-syntactic: "define-record-type: invalid protocol oops". record.mo:Expected error in mat r6rs-records-syntactic: "parent record type is sealed prnt". +record.mo:Expected error in mat r6rs-records-syntactic: "invalid field specifier 876". +record.mo:Expected error in mat r6rs-records-syntactic: "invalid field specifier (mutable (x))". +record.mo:Expected error in mat r6rs-records-syntactic: "invalid field specifier (immutable "spam")". +record.mo:Expected error in mat r6rs-records-syntactic: "invalid field specifier (immutable (x) foo-x)". +record.mo:Expected error in mat r6rs-records-syntactic: "invalid field specifier (immutable x (foo-x))". +record.mo:Expected error in mat r6rs-records-syntactic: "invalid field specifier (mutable (x) foo-x foo-x!)". +record.mo:Expected error in mat r6rs-records-syntactic: "invalid field specifier (mutable x (foo-x) foo-x!)". +record.mo:Expected error in mat r6rs-records-syntactic: "invalid field specifier (mutable x foo-x (foo-x!))". record.mo:Expected error in mat define-record-type-extensions: "missing nongenerative clause and require-nongenerative-clause is #t (define-record-type foo)". record.mo:Expected error in mat cp0-record-ref-optimizations: "make-record-type-descriptor: invalid uid 5". hash.mo:Expected error in mat old-hash-table: "get-hash-table: ((a . b)) is not an eq hashtable". diff --git a/mats/root-experr-compile-2-f-f-f b/mats/root-experr-compile-2-f-f-f index 472415f8e6..f8fa3139df 100644 --- a/mats/root-experr-compile-2-f-f-f +++ b/mats/root-experr-compile-2-f-f-f @@ -7453,6 +7453,14 @@ record.mo:Expected error in mat r6rs-records-syntactic: "invalid define-record-t record.mo:Expected error in mat r6rs-records-syntactic: "no constructor descriptor for define-record record type frob". record.mo:Expected error in mat r6rs-records-syntactic: "define-record-type: invalid protocol oops". record.mo:Expected error in mat r6rs-records-syntactic: "parent record type is sealed prnt". +record.mo:Expected error in mat r6rs-records-syntactic: "invalid field specifier 876". +record.mo:Expected error in mat r6rs-records-syntactic: "invalid field specifier (mutable (x))". +record.mo:Expected error in mat r6rs-records-syntactic: "invalid field specifier (immutable "spam")". +record.mo:Expected error in mat r6rs-records-syntactic: "invalid field specifier (immutable (x) foo-x)". +record.mo:Expected error in mat r6rs-records-syntactic: "invalid field specifier (immutable x (foo-x))". +record.mo:Expected error in mat r6rs-records-syntactic: "invalid field specifier (mutable (x) foo-x foo-x!)". +record.mo:Expected error in mat r6rs-records-syntactic: "invalid field specifier (mutable x (foo-x) foo-x!)". +record.mo:Expected error in mat r6rs-records-syntactic: "invalid field specifier (mutable x foo-x (foo-x!))". record.mo:Expected error in mat define-record-type-extensions: "missing nongenerative clause and require-nongenerative-clause is #t (define-record-type foo)". record.mo:Expected error in mat cp0-record-ref-optimizations: "make-record-type-descriptor: invalid uid 5". hash.mo:Expected error in mat old-hash-table: "get-hash-table: ((a . b)) is not an eq hashtable". diff --git a/s/syntax.ss b/s/syntax.ss index f6c66ea197..6992c49145 100644 --- a/s/syntax.ss +++ b/s/syntax.ss @@ -9299,6 +9299,7 @@ (define (parse-field x i) (syntax-case x (immutable mutable) [(immutable field-name accessor-name) + (and (identifier? #'field-name) (identifier? #'accessor-name)) (make-field-desc (datum field-name) i @@ -9306,6 +9307,7 @@ #'accessor-name #f)] [(mutable field-name accessor-name mutator-name) + (and (identifier? #'field-name) (identifier? #'accessor-name) (identifier? #'mutator-name)) (make-field-desc (datum field-name) i @@ -9313,10 +9315,12 @@ #'accessor-name #'mutator-name)] [(immutable field-name) + (identifier? #'field-name) (make-field-desc (datum field-name) i x (construct-name name name "-" #'field-name) #f)] [(mutable field-name) + (identifier? #'field-name) (make-field-desc (datum field-name) i x (construct-name name name "-" #'field-name) (construct-name name name "-" #'field-name "-set!"))] From 052e48e9e865e44fb13ef73c2b9bbd6ce5cbdbc7 Mon Sep 17 00:00:00 2001 From: dyb Date: Thu, 5 Apr 2018 21:28:33 -0700 Subject: [PATCH 20/21] committing @akeep library change with rebuilt boot files: - fixed an issue with the library system where an exception that occurs during visit or revisit left the library in an inconsistent state that caused it to appear that it was still in the process of running. This manifested in it raising a cyclic dependency exception, even though there really is not a cyclic dependency. The various library management functions involved will now reset the part of the library when an exception occurs. This also means that if the library visit or revisit failed for a transient reason (such as a missing or incorrect library version that can be fixed by updating the library-directories) it is now possible to recover from these errors. expand-lang.ss, syntax.ss, interpret.ss, compile.ss, cprep.ss, 8.ms original commit: 6dbd72496fb4eaf5fb65453d0ae0a75f0ef2ad80 --- LOG | 12 ++ mats/8.ms | 249 +++++++++++++++++++++++++++++++ release_notes/release_notes.stex | 15 +- s/compile.ss | 14 +- s/cprep.ss | 4 +- s/expand-lang.ss | 6 +- s/interpret.ss | 4 +- s/syntax.ss | 70 ++++++--- 8 files changed, 337 insertions(+), 37 deletions(-) diff --git a/LOG b/LOG index e47cf494c3..cf89a8ee73 100644 --- a/LOG +++ b/LOG @@ -905,3 +905,15 @@ field names in define-record-type field specs. syntax.ss, record.ms, root-experr* +- fixed an issue with the library system where an exception that occurs + during visit or revisit left the library in an inconsistent state that + caused it to appear that it was still in the process of running. This + manifested in it raising a cyclic dependency exception, even though + there really is not a cyclic dependency. The various library + management functions involved will now reset the part of the library + when an exception occurs. This also means that if the library visit + or revisit failed for a transient reason (such as a missing or + incorrect library version that can be fixed by updating the + library-directories) it is now possible to recover from these errors. + expand-lang.ss, syntax.ss, interpret.ss, compile.ss, cprep.ss, + 8.ms diff --git a/mats/8.ms b/mats/8.ms index 33e183fdc3..409086babc 100644 --- a/mats/8.ms +++ b/mats/8.ms @@ -8730,6 +8730,255 @@ "revisiting testfile-l6-prog1\n#((10 . 12))\n") ) +(mat library-regression + ; test that failing invoke code does not result in cyclic dependency problem on re-run + (equal? + (separate-eval + '(begin + (library (invoke-fail) + (export x) + (import (chezscheme)) + (define x #f) + (error #f "failed to load library (invoke-fail)")) + (guard (e [else + (guard (e2 [else + (display-condition e) (newline) + (display-condition e2) (newline)]) + (eval 'x (environment '(chezscheme) '(invoke-fail))))]) + (eval 'x (environment '(chezscheme) '(invoke-fail)))))) + "Exception: failed to load library (invoke-fail)\nException: failed to load library (invoke-fail)\n") + + ; test that true cyclic dependency will always report the same thing + (equal? + (separate-eval + '(begin + (library (invoke-cyclic) + (export x y) + (import (chezscheme)) + (define x #f) + (define y (eval '(if x 5 10) (environment '(chezscheme) '(invoke-cyclic))))) + (guard (e [else + (guard (e2 [else + (display-condition e) (newline) + (display-condition e2) (newline)]) + (eval 'x (environment '(chezscheme) '(invoke-cyclic))))]) + (eval 'x (environment '(chezscheme) '(invoke-cyclic)))))) + "Exception: cyclic dependency involving invocation of library (invoke-cyclic)\nException: cyclic dependency involving invocation of library (invoke-cyclic)\n") + + (begin + ; library to help make it easier to cause a failure in the visit-code that + ; does not lead to failure during compilation of the file. + (with-output-to-file "testfile-lr-l1.ss" + (lambda () + (pretty-print + '(library (testfile-lr-l1) + (export make-it-fail) + (import (chezscheme)) + (define make-it-fail (make-parameter #f (lambda (x) (and x #t))))))) + 'replace) + ; simple test to define one macro and potentially to raise an error when + ; defining the second one. + (with-output-to-file "testfile-lr-l2.ss" + (lambda () + (pretty-print + '(library (testfile-lr-l2) + (export M1 M2) + (import (chezscheme) (testfile-lr-l1)) + (define-syntax M1 + (identifier-syntax #f)) + + (define-syntax M2 + (if (make-it-fail) + (error 'M2 "user requested failure with (make-it-fail) parameter") + (lambda (x) + (syntax-case x () + [(_ expr) #'expr]))))))) + 'replace) + ; more complete test that attempts to create the various types of things + ; that can be defined in visit code so that we can verify things are being + ; properly reset. + (with-output-to-file "testfile-lr-l3.ss" + (lambda () + (pretty-print + '(library (testfile-lr-l3) + (export a b c d e f g h) + (import (chezscheme) (testfile-lr-l1)) + + (module a (x) (define x 5)) + (alias b cons) + (define-syntax c (make-compile-time-value 5)) + (define d 5) + (meta define e 5) + (define-syntax f (identifier-syntax #f)) + (define $g (make-parameter #f)) + (define-syntax g + (make-variable-transformer + (lambda (x) + (syntax-case x () + [(set! _ v) #'($g v)] + [_ #'($g)] + [(_ e* ...) #'(($g) e* ...)])))) + (define-property f g 10) + (define-syntax h + (if (make-it-fail) + (error 'h "user requested failure with (make-it-fail) parameter") + (lambda (x) + (syntax-case x () + [(_ expr) #'expr]))))))) + 'replace) + (separate-compile + '(lambda (x) + (parameterize ([compile-imported-libraries #t]) + (for-each compile-library x))) + '(list "testfile-lr-l1" "testfile-lr-l2" "testfile-lr-l3")) + #t) + + (equal? + (separate-eval + '(begin + (import (testfile-lr-l2) (testfile-lr-l1)) + (make-it-fail #t) + (guard (e [else + (guard (e2 + [else + (display-condition e) (newline) + (display-condition e2) (newline)]) + (eval 'M1 (environment '(testfile-lr-l2))))]) + (eval 'M1 (environment '(testfile-lr-l2)))))) + "Exception in M2: user requested failure with (make-it-fail) parameter\nException in M2: user requested failure with (make-it-fail) parameter\n") + + ; module is defined as part of import code, run time bindings are setup as part of invoke code + (equal? + (separate-eval + '(begin + (import (testfile-lr-l3) (testfile-lr-l1)) + (make-it-fail #t) + (import a) + x)) + "5\n") + + ; alias is part of module binding ribcage, set up by import code + (equal? + (separate-eval + '(begin + (import (testfile-lr-l3) (testfile-lr-l1)) + (make-it-fail #t) + (b 'a 'b))) + "(a . b)\n") + + ; compile-time-value is set in visit code, should show same error each time it is referenced + (equal? + (separate-eval + '(begin + (library (lookup) + (export lookup) + (import (chezscheme)) + (define-syntax lookup + (lambda (x) + (syntax-case x () + [(_ id) (lambda (rho) #`'#,(rho #'id))] + [(_ id key) (lambda (rho) #`'#,(rho #'id #'key))])))) + (import (testfile-lr-l3) (testfile-lr-l1)) + (make-it-fail #t) + (guard (e [else + (guard (e2 + [else + (display-condition e) (newline) + (display-condition e2) (newline)]) + (eval '(lookup c) (environment '(testfile-lr-l3) '(lookup))))]) + (eval '(lookup c) (environment '(testfile-lr-l3) '(lookup)))))) + "Exception in h: user requested failure with (make-it-fail) parameter\nException in h: user requested failure with (make-it-fail) parameter\n") + + ; defines are set up as part of invoke code + (equal? + (separate-eval + '(begin + (import (testfile-lr-l3) (testfile-lr-l1)) + (make-it-fail #t) + d)) + "5\n") + + ; meta defines are set up as part of visit code + (equal? + (separate-eval + '(begin + (import (testfile-lr-l3) (testfile-lr-l1)) + (make-it-fail #t) + (guard (e [else + (guard (e2 + [else + (display-condition e) (newline) + (display-condition e2) (newline)]) + (eval '(let () + (define-syntax get-e + (lambda (x) + (syntax-case x () + [(_) #`'#,e]))) + (get-e)) + (environment '(chezscheme) '(testfile-lr-l3))))]) + (eval '(let () + (define-syntax get-e + (lambda (x) + (syntax-case x () + [(_) #`'#,e]))) + (get-e)) + (environment '(chezscheme) '(testfile-lr-l3)))))) + "Exception in h: user requested failure with (make-it-fail) parameter\nException in h: user requested failure with (make-it-fail) parameter\n") + + ; macros are set up as part of visit code + (equal? + (separate-eval + '(begin + (import (testfile-lr-l3) (testfile-lr-l1)) + (make-it-fail #t) + (guard (e [else + (guard (e2 + [else + (display-condition e) (newline) + (display-condition e2) (newline)]) + (eval 'f (environment '(testfile-lr-l3))))]) + (eval 'f (environment '(testfile-lr-l3)))))) + "Exception in h: user requested failure with (make-it-fail) parameter\nException in h: user requested failure with (make-it-fail) parameter\n") + + ; variable transformer macros are set up as part of visit code + (equal? + (separate-eval + '(begin + (import (testfile-lr-l3) (testfile-lr-l1)) + (make-it-fail #t) + (guard (e [else + (guard (e2 + [else + (display-condition e) (newline) + (display-condition e2) (newline)]) + (eval 'g (environment '(testfile-lr-l3))))]) + (eval 'g (environment '(testfile-lr-l3)))))) + "Exception in h: user requested failure with (make-it-fail) parameter\nException in h: user requested failure with (make-it-fail) parameter\n") + + ; properties are setup as part of visit code. + (equal? + (separate-eval + '(begin + (library (lookup) + (export lookup) + (import (chezscheme)) + (define-syntax lookup + (lambda (x) + (syntax-case x () + [(_ id) (lambda (rho) #`'#,(rho #'id))] + [(_ id key) (lambda (rho) #`'#,(rho #'id #'key))])))) + (import (testfile-lr-l3) (testfile-lr-l1)) + (make-it-fail #t) + (guard (e [else + (guard (e2 + [else + (display-condition e) (newline) + (display-condition e2) (newline)]) + (eval '(lookup f g) (environment '(testfile-lr-l3) '(lookup))))]) + (eval '(lookup f g) (environment '(testfile-lr-l3) '(lookup)))))) + "Exception in h: user requested failure with (make-it-fail) parameter\nException in h: user requested failure with (make-it-fail) parameter\n") +) + (mat cross-library-optimization (begin (with-output-to-file "testfile-clo-1a.ss" diff --git a/release_notes/release_notes.stex b/release_notes/release_notes.stex index 564c013d50..2bc6ef1d4b 100644 --- a/release_notes/release_notes.stex +++ b/release_notes/release_notes.stex @@ -1566,13 +1566,24 @@ in fasl files does not generally make sense. %----------------------------------------------------------------------------- \section{Bug Fixes}\label{section:bugfixes} -\subsection{Incomplete handling of import specs within standalone export forms} +\subsection{Misleading cyclic dependency error (9.5)} + +The library system no longer reports a cyclic dependency error +during the second and subsequent attempts to visit or invoke a +library after the first attempt fails for some reason other than +an actual cyclic dependency. +The fix also allows a library to be visited or invoked successfully +on the second or subsequent attempt if the visit or invoke failed +for a transient reason, such as a missing or incorrect version in +an imported library. + +\subsection{Incomplete handling of import specs within standalone export forms (9.5)} A bug that limited the \scheme{(import \var{import-spec} \dots)} form within a standalone \scheme{export} form to \scheme{(import \var{import-spec})} has been fixed. -\subsection{Permission denied after deleting files or directories in Windows} +\subsection{Permission denied after deleting files or directories in Windows (9.5)} In Windows, deleting a file or directory briefly leaves the file or directory in a state where a subsequent create operation fails with diff --git a/s/compile.ss b/s/compile.ss index c56e3195a4..32eca11865 100644 --- a/s/compile.ss +++ b/s/compile.ss @@ -461,8 +461,8 @@ (Inner : Inner (ir) -> Inner () [,lsrc lsrc] ; NB: workaround for nanopass tag snafu [(program ,uid ,body) ($build-invoke-program uid body)] - [(library/ct ,uid ,import-code ,visit-code) - ($build-install-library/ct-code uid import-code visit-code)] + [(library/ct ,uid (,export-id* ...) ,import-code ,visit-code) + ($build-install-library/ct-code uid export-id* import-code visit-code)] [(library/rt ,uid (,dl* ...) (,db* ...) (,dv* ...) (,de* ...) ,body) ($build-install-library/rt-code uid dl* db* dv* de* body)] [else ir])) @@ -916,7 +916,7 @@ (program-node-ir-set! maybe-program ir) (values)]) (ctLibrary : ctLibrary (ir situation) -> * () - [(library/ct ,uid ,import-code ,visit-code) + [(library/ct ,uid (,export-id* ...) ,import-code ,visit-code) (when (eq? situation 'revisit) ($oops who "encountered revisit-only compile-time library ~s while processing wpo file ~s" (lookup-path uid) ifn)) (record-ct-lib-ir! uid ir) (values)]) @@ -1042,8 +1042,8 @@ (define build-install-library/ct-code (lambda (node) (nanopass-case (Lexpand ctLibrary) (library-node-ctir node) - [(library/ct ,uid ,import-code ,visit-code) - ($build-install-library/ct-code uid + [(library/ct ,uid (,export-id* ...) ,import-code ,visit-code) + ($build-install-library/ct-code uid export-id* (if (library-node-visible? node) import-code void-pr) (if (library-node-visible? node) visit-code void-pr))]))) @@ -1449,8 +1449,8 @@ (Inner : Inner (ir) -> Expr () [,lsrc lsrc] [(program ,uid ,body) ($build-invoke-program uid body)] - [(library/ct ,uid ,import-code ,visit-code) - ($build-install-library/ct-code uid import-code visit-code)] + [(library/ct ,uid (,export-id* ...) ,import-code ,visit-code) + ($build-install-library/ct-code uid export-id* import-code visit-code)] [(library/rt ,uid (,dl* ...) (,db* ...) (,dv* ...) (,de* ...) ,body) ($build-install-library/rt-code uid dl* db* dv* de* body)] [else (sorry! who "unexpected Lexpand record ~s" ir)]) diff --git a/s/cprep.ss b/s/cprep.ss index 35cf39e1eb..5d22e50d3c 100644 --- a/s/cprep.ss +++ b/s/cprep.ss @@ -26,8 +26,8 @@ (Inner : Inner (ir) -> * (val) [,lsrc (go lsrc)] [(program ,uid ,body) (go ($build-invoke-program uid body))] - [(library/ct ,uid ,import-code ,visit-code) - (go ($build-install-library/ct-code uid import-code visit-code))] + [(library/ct ,uid (,export-id* ...) ,import-code ,visit-code) + (go ($build-install-library/ct-code uid export-id* import-code visit-code))] [(library/rt ,uid (,dl* ...) (,db* ...) (,dv* ...) (,de* ...) ,body) (go ($build-install-library/rt-code uid dl* db* dv* de* body))] [,linfo/ct `(library/ct-info ,(library-info-uid linfo/ct) ,(library/ct-info-import-req* linfo/ct) diff --git a/s/expand-lang.ss b/s/expand-lang.ss index 8421f86eb5..b9000e786a 100644 --- a/s/expand-lang.ss +++ b/s/expand-lang.ss @@ -80,10 +80,10 @@ (define maybe-label? (lambda (x) (or (not x) (gensym? x)))) (define-language Lexpand - (nongenerative-id #{Lexpand fgy7v2wrvj0so4ro8kvhqo-1}) + (nongenerative-id #{Lexpand fgy7v2wrvj0so4ro8kvhqo-2}) (terminals (maybe-label (dl)) - (gensym (uid)) + (gensym (uid export-id)) (library-path (path)) (library-version (version)) (maybe-optimization-loc (db)) @@ -110,7 +110,7 @@ prog lsrc) (ctLibrary (ctlib) - (library/ct uid import-code visit-code)) + (library/ct uid (export-id* ...) import-code visit-code)) (rtLibrary (rtlib) (library/rt uid (dl* ...) diff --git a/s/interpret.ss b/s/interpret.ss index ec382314d3..d019327f12 100644 --- a/s/interpret.ss +++ b/s/interpret.ss @@ -666,8 +666,8 @@ [,lsrc (ibeval lsrc)] [(program ,uid ,body) (ibeval ($build-invoke-program uid body))] - [(library/ct ,uid ,import-code ,visit-code) - (ibeval ($build-install-library/ct-code uid import-code visit-code))] + [(library/ct ,uid (,export-id* ...) ,import-code ,visit-code) + (ibeval ($build-install-library/ct-code uid export-id* import-code visit-code))] [(library/rt ,uid (,dl* ...) (,db* ...) (,dv* ...) (,de* ...) ,body) (ibeval ($build-install-library/rt-code uid dl* db* dv* de* body))] [,linfo/rt ($install-library/rt-desc linfo/rt for-import? ofn)] diff --git a/s/syntax.ss b/s/syntax.ss index 6992c49145..afebf6b188 100644 --- a/s/syntax.ss +++ b/s/syntax.ss @@ -828,9 +828,10 @@ ,(build-sequence no-source init*))))) (define build-top-library/ct - (lambda (uid import-code* visit-code*) + (lambda (uid export-id* import-code* visit-code*) (with-output-language (Lexpand ctLibrary) `(library/ct ,uid + (,export-id* ...) ,(build-lambda no-source '() (build-sequence no-source import-code*)) ,(if (null? visit-code*) @@ -2357,9 +2358,10 @@ (mutable clo*) ; cross-library optimization information (mutable loaded-import-reqs) (mutable loaded-visit-reqs) + (mutable export-id*) ; ids that need to be reset when visit-code raises an exception (mutable import-code) (mutable visit-code)) - (nongenerative #{ctdesc bthma8spr7lds76z4hlmr9-1}) + (nongenerative #{ctdesc bthma8spr7lds76z4hlmr9-2}) (sealed #t)) (define-record-type rtdesc @@ -2375,6 +2377,7 @@ libdesc-loaded-visit-reqs libdesc-loaded-visit-reqs-set! libdesc-import-code libdesc-import-code-set! libdesc-visit-code libdesc-visit-code-set! + libdesc-visit-id* libdesc-visit-id*-set! libdesc-clo* libdesc-clo*-set!) (define get-ctdesc (lambda (desc) @@ -2416,6 +2419,12 @@ (define libdesc-visit-code-set! (lambda (desc x) (ctdesc-visit-code-set! (get-ctdesc desc) x))) + (define libdesc-visit-id* + (lambda (desc) + (ctdesc-export-id* (get-ctdesc desc)))) + (define libdesc-visit-id*-set! + (lambda (desc x) + (ctdesc-export-id*-set! (get-ctdesc desc) x))) (define libdesc-clo* (lambda (desc) (ctdesc-clo* (get-ctdesc desc)))) @@ -2460,10 +2469,15 @@ (when (eq? p 'pending) ($oops #f "cyclic dependency involving visit of library ~s" (libdesc-path desc))) (libdesc-visit-code-set! desc 'pending) - (for-each (lambda (req) (visit-library (libreq-uid req))) (libdesc-visit-visit-req* desc)) - (for-each (lambda (req) (invoke-library (libreq-uid req))) (libdesc-visit-req* desc)) - (p) - (libdesc-visit-code-set! desc #f))]))] + (on-reset + (begin + (for-each (lambda (id) ($sc-put-cte id (make-binding 'visit uid) #f)) (libdesc-visit-id* desc)) + (libdesc-visit-code-set! desc p)) + (for-each (lambda (req) (visit-library (libreq-uid req))) (libdesc-visit-visit-req* desc)) + (for-each (lambda (req) (invoke-library (libreq-uid req))) (libdesc-visit-req* desc)) + (p)) + (libdesc-visit-code-set! desc #f) + (libdesc-visit-id*-set! desc '()))]))] [else ($oops #f "library ~:s is not defined" uid)]))) (define invoke-library @@ -2480,8 +2494,9 @@ (when (eq? p 'pending) ($oops #f "cyclic dependency involving invocation of library ~s" (libdesc-path desc))) (libdesc-invoke-code-set! desc 'pending) - (for-each (lambda (req) (invoke-library (libreq-uid req))) (libdesc-invoke-req* desc)) - (p) + (on-reset (libdesc-invoke-code-set! desc p) + (for-each (lambda (req) (invoke-library (libreq-uid req))) (libdesc-invoke-req* desc)) + (p)) (libdesc-invoke-code-set! desc #f))]))] [else ($oops #f "library ~:s is not defined" uid)]))) @@ -2525,8 +2540,9 @@ (when (eq? p 'pending) ($oops #f "cyclic dependency involving invocation of library ~s" (libdesc-path desc))) (libdesc-invoke-code-set! desc 'pending) - (for-each (lambda (req) (invoke-library (libreq-uid req))) (libdesc-invoke-req* desc)) - (p) + (on-reset (libdesc-invoke-code-set! desc p) + (for-each (lambda (req) (invoke-library (libreq-uid req))) (libdesc-invoke-req* desc)) + (p)) (libdesc-invoke-code-set! desc #f))])) (unless (memp (lambda (x) (eq? (libreq-uid x) uid)) req*) (set! req* (cons (make-libreq (libdesc-path desc) (libdesc-version desc) uid) req*))))] @@ -2626,7 +2642,7 @@ (install-library library-path library-uid ; import-code & visit-code is #f because vthunk invocation has already set up compile-time environment (make-libdesc library-path library-version outfn #f - (make-ctdesc include-req* import-req* visit-visit-req* visit-req* '() #t #t #f #f) + (make-ctdesc include-req* import-req* visit-visit-req* visit-req* '() #t #t '() #f #f) (make-rtdesc invoke-req* #t (top-level-eval-hook (build-lambda no-source '() @@ -2666,6 +2682,13 @@ build-void (lambda () (build-top-library/ct library-uid + ; visit-time exports (making them available for reset on visit-code failure) + (fold-left (lambda (ls x) + (let ([label (car x)] [exp (cdr x)]) + (if (and (pair? exp) (eq? (car exp) 'visit)) + (cons label ls) + ls))) + '() env*) ; setup code `(,(build-cte-install bound-id (build-data no-source interface-binding) '*system*) ,@(if (null? env*) @@ -4632,11 +4655,12 @@ (when desc (put-library-descriptor uid desc))))) (define-who install-library/ct-code - (lambda (uid import-code visit-code) + (lambda (uid export-id* import-code visit-code) (let ([desc (get-library-descriptor uid)]) (unless desc (sorry! who "unable to install visit code for non-existent library ~s" uid)) (let ([ctdesc (libdesc-ctdesc desc)]) (unless ctdesc (sorry! who "unable to install visit code for revisit-only library ~s" uid)) + (ctdesc-export-id*-set! ctdesc export-id*) (ctdesc-import-code-set! ctdesc import-code) (ctdesc-visit-code-set! ctdesc visit-code))))) @@ -5077,7 +5101,8 @@ [(#t) (void)] [(#f) (libdesc-loaded-invoke-reqs-set! desc 'pending) - (for-each (make-load-req load-invoke-library path) (libdesc-invoke-req* desc)) + (on-reset (libdesc-loaded-invoke-reqs-set! desc #f) + (for-each (make-load-req load-invoke-library path) (libdesc-invoke-req* desc))) (libdesc-loaded-invoke-reqs-set! desc #t)] [(pending) ($oops #f "cyclic dependency involving invocation of library ~s" (libdesc-path desc))])))))) (define load-visit-library @@ -5091,8 +5116,9 @@ [(#t) (void)] [(#f) (libdesc-loaded-visit-reqs-set! desc 'pending) - (for-each (make-load-req load-visit-library path) (libdesc-visit-visit-req* desc)) - (for-each (make-load-req load-invoke-library path) (libdesc-visit-req* desc)) + (on-reset (libdesc-loaded-visit-reqs-set! desc #f) + (for-each (make-load-req load-visit-library path) (libdesc-visit-visit-req* desc)) + (for-each (make-load-req load-invoke-library path) (libdesc-visit-req* desc))) (libdesc-loaded-visit-reqs-set! desc #t)] [(pending) ($oops #f "cyclic dependency involving visit of library ~s" (libdesc-path desc))])))))) (define load-import-library @@ -5106,7 +5132,8 @@ [(#t) (void)] [(#f) (libdesc-loaded-import-reqs-set! desc 'pending) - (for-each (make-load-req load-import-library path) (libdesc-import-req* desc)) + (on-reset (libdesc-loaded-import-reqs-set! desc #f) + (for-each (make-load-req load-import-library path) (libdesc-import-req* desc))) (libdesc-loaded-import-reqs-set! desc #t)] [(pending) ($oops #f "cyclic dependency involving import of library ~s" (libdesc-path desc))])))))) (define import-library @@ -5261,9 +5288,10 @@ (build-lambda no-source '() body)))) (set-who! $build-install-library/ct-code - (lambda (uid import-code visit-code) + (lambda (uid export-id* import-code visit-code) (build-primcall no-source 3 '$install-library/ct-code (build-data no-source uid) + (build-data no-source export-id*) import-code visit-code))) @@ -5393,7 +5421,7 @@ (library/ct-info-visit-visit-req* linfo/ct) (library/ct-info-visit-req* linfo/ct) (library/ct-info-clo* linfo/ct) - #f #f 'loading 'loading))))) + #f #f '() 'loading 'loading))))) (set! $install-library/rt-desc (lambda (linfo/rt for-import? ofn) @@ -5405,8 +5433,8 @@ uid ofn (make-rtdesc (library/rt-info-invoke-req* linfo/rt) #f 'loading))))) (set! $install-library/ct-code - (lambda (uid import-code visit-code) - (install-library/ct-code uid import-code visit-code))) + (lambda (uid export-id* import-code visit-code) + (install-library/ct-code uid export-id* import-code visit-code))) (set! $install-library/rt-code (lambda (uid invoke-code) @@ -5482,7 +5510,7 @@ (lambda (path uid) (install-library path uid (make-libdesc path (if (eq? (car path) 'rnrs) '(6) '()) #f #t - (make-ctdesc '() '() '() '() '() #t #t #f #f) + (make-ctdesc '() '() '() '() '() #t #t '() #f #f) (make-rtdesc '() #t #f))))) (set! $make-base-modules (lambda () From e79f9a66eb8542164874f053c837003b7023c7ab Mon Sep 17 00:00:00 2001 From: Andy Keep Date: Sun, 8 Apr 2018 12:22:25 -0400 Subject: [PATCH 21/21] Fixes #273 (on master this time) with -Wno-implicit-fallthrough Embarrassingly, I committed this change on the wrong branch initially. Added -Wno-implicit-fallthrough flag to macOS C makefiles. c/Mf-a6osx, c/Mf-i3osx, c/Mf-ta6osx, c/Mf-ti3osx original commit: 8eb8336a7d2870f8e592f060bab8321703e40b48 --- LOG | 2 ++ c/Mf-a6osx | 2 +- c/Mf-i3osx | 2 +- c/Mf-ta6osx | 2 +- c/Mf-ti3osx | 2 +- 5 files changed, 6 insertions(+), 4 deletions(-) diff --git a/LOG b/LOG index cf89a8ee73..987cbf19df 100644 --- a/LOG +++ b/LOG @@ -917,3 +917,5 @@ library-directories) it is now possible to recover from these errors. expand-lang.ss, syntax.ss, interpret.ss, compile.ss, cprep.ss, 8.ms +- Added -Wno-implicit-fallthrough flag to macOS C makefiles. + c/Mf-a6osx, c/Mf-i3osx, c/Mf-ta6osx, c/Mf-ti3osx diff --git a/c/Mf-a6osx b/c/Mf-a6osx index fe0756b378..8293937baa 100644 --- a/c/Mf-a6osx +++ b/c/Mf-a6osx @@ -17,7 +17,7 @@ m = a6osx Cpu = X86_64 mdclib = -liconv -lm -lncurses -C = ${CC} ${CPPFLAGS} -m64 -Wpointer-arith -Wall -Wextra -Werror -O2 -I/opt/X11/include/ ${CFLAGS} +C = ${CC} ${CPPFLAGS} -m64 -Wpointer-arith -Wall -Wextra -Wno-implicit-fallthrough -Werror -O2 -I/opt/X11/include/ ${CFLAGS} o = o mdsrc = i3le.c mdobj = i3le.o diff --git a/c/Mf-i3osx b/c/Mf-i3osx index 833cea7ee0..8ca333d76d 100644 --- a/c/Mf-i3osx +++ b/c/Mf-i3osx @@ -17,7 +17,7 @@ m = i3osx Cpu = I386 mdclib = -liconv -lm -lncurses -C = ${CC} ${CPPFLAGS} -m32 -Wpointer-arith -Wall -Wextra -Werror -O2 -msse2 -I/opt/X11/include/ ${CFLAGS} +C = ${CC} ${CPPFLAGS} -m32 -Wpointer-arith -Wall -Wextra -Wno-implicit-fallthrough -Werror -O2 -msse2 -I/opt/X11/include/ ${CFLAGS} o = o mdsrc = i3le.c mdobj = i3le.o diff --git a/c/Mf-ta6osx b/c/Mf-ta6osx index 15fe45b375..9626f36489 100644 --- a/c/Mf-ta6osx +++ b/c/Mf-ta6osx @@ -17,7 +17,7 @@ m = ta6osx Cpu = X86_64 mdclib = -liconv -lm -lncurses -C = ${CC} ${CPPFLAGS} -m64 -Wpointer-arith -Wall -Wextra -Werror -O2 -I/opt/X11/include/ ${CFLAGS} +C = ${CC} ${CPPFLAGS} -m64 -Wpointer-arith -Wall -Wextra -Wno-implicit-fallthrough -Werror -O2 -I/opt/X11/include/ ${CFLAGS} o = o mdsrc = i3le.c mdobj = i3le.o diff --git a/c/Mf-ti3osx b/c/Mf-ti3osx index 27d3e62bfc..f78817db7d 100644 --- a/c/Mf-ti3osx +++ b/c/Mf-ti3osx @@ -17,7 +17,7 @@ m = ti3osx Cpu = I386 mdclib = -liconv -lm -lncurses -C = ${CC} ${CPPFLAGS} -m32 -Wpointer-arith -Wall -Wextra -Werror -O2 -msse2 -I/opt/X11/include/ ${CFLAGS} +C = ${CC} ${CPPFLAGS} -m32 -Wpointer-arith -Wall -Wextra -Wno-implicit-fallthrough -Werror -O2 -msse2 -I/opt/X11/include/ ${CFLAGS} o = o mdsrc = i3le.c mdobj = i3le.o