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

Various updates, mostly to the compiler, including a new lambda

Browse Source 
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
This commit is contained in:
dybvig 2018-01-29 09:20:07 -05:00
parent 1cdc2a7e0f
commit f7c414bda3
23 changed files with 694 additions and 194 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

89
LOG
View File

@ -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

8
c/gc.c
View File

@ -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

57
csug/objects.stex
View File

@ -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}}%

28
csug/system.stex
View File

@ -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}

30
mats/Mf-base
View File

@ -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})'\

78
mats/mat.ss
View File

@ -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)

131
mats/record.ms
View File

@ -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

27
release_notes/release_notes.stex
View File

@ -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

18
s/Mf-base
View File

@ -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)'\

2
s/Mf-cross
View File

@ -20,7 +20,7 @@
what = all examples
base = ../..
doitformebaby: xboot
xdoit: xboot
include Mf-${xm}

5
s/back.ss
View File

@ -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)

2
s/cmacros.ss
View File

@ -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]))

186
s/compile.ss
View File

@ -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)

4
s/cp0.ss
View File

@ -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)))]

111
s/cpletrec.ss
View File

@ -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)

2
s/cpnanopass.ss
View File

@ -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

63
s/cprep.ss
View File

@ -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))))

5
s/ftype.ss
View File

@ -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)

3
s/interpret.ss
View File

@ -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]))))

21
s/newhash.ss
View File

@ -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)))

10
s/primdata.ss
View File

@ -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])

2
s/prims.ss
View File

@ -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

6
s/syntax.ss
View File

@ -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