From f7c414bda3673f8fa7cb2bc0721d01c9a9a2e234 Mon Sep 17 00:00:00 2001 From: dybvig Date: Mon, 29 Jan 2018 09:20:07 -0500 Subject: [PATCH] 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