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