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

350.3

Browse Source 
svn: r3571
This commit is contained in:
Matthew Flatt 2006-07-01 18:53:09 +00:00
parent a4f230d00a
commit ebe051694d
42 changed files with 2899 additions and 2706 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
collects/compiler/private/xform.ss
View File

@ -2562,18 +2562,25 @@
[(null? body)
;; Starting live-vars record for this block:
;; Create new tag
;; Locally-defined arrays and records are always live.
;; Locally-defined arrays, records, and & variables, are always live.
;; Start with -1 maxlive in case we want to check whether anything
;; was pushed in the block.
(values null (make-live-var-info (gentag)
-1
0
(append
(let loop ([vars extra-vars])
(cond
[(null? vars) null]
[(memq (caar vars) &-vars)
(cons (car vars) (loop (cdr vars)))]
[else (loop (cdr vars))]))
(let loop ([vars local-vars])
(cond
[(null? vars) null]
[(or (array-type? (cdar vars))
(struc-type? (cdar vars)))
(struc-type? (cdar vars))
(memq (caar vars) &-vars))
(cons (car vars) (loop (cdr vars)))]
[else (loop (cdr vars))]))
(live-var-info-vars live-vars))

2
collects/mzlib/cm.ss
View File

@ -210,7 +210,7 @@
(define (compile-root mode path up-to-date)
(let ([path (simplify-path (expand-path path))])
(let ((stamp (and up-to-date
(hash-table-get up-to-date path (lambda () #f)))))
(hash-table-get up-to-date path #f))))
(cond
(stamp stamp)
(else

32
collects/mzlib/private/class-internal.ss
View File

@ -802,7 +802,7 @@
(lambda (what l)
(let ([ht (make-hash-table)])
(for-each (lambda (id)
(when (hash-table-get ht (syntax-e id) (lambda () #f))
(when (hash-table-get ht (syntax-e id) #f)
(bad (format "duplicate declared external ~a name" what) id))
(hash-table-put! ht (syntax-e id) #t))
l)))])
@ -820,20 +820,20 @@
[stx-ht (make-hash-table)])
(for-each
(lambda (defined-name)
(let ([l (hash-table-get ht (syntax-e defined-name) (lambda () null))])
(let ([l (hash-table-get ht (syntax-e defined-name) null)])
(hash-table-put! ht (syntax-e defined-name) (cons defined-name l))))
defined-method-names)
(for-each
(lambda (defined-name)
(let ([l (hash-table-get stx-ht (syntax-e defined-name) (lambda () null))])
(let ([l (hash-table-get stx-ht (syntax-e defined-name) null)])
(hash-table-put! stx-ht (syntax-e defined-name) (cons defined-name l))))
defined-syntax-names)
(for-each
(lambda (pubovr-name)
(let ([l (hash-table-get ht (syntax-e pubovr-name) (lambda () null))])
(let ([l (hash-table-get ht (syntax-e pubovr-name) null)])
(unless (ormap (lambda (i) (bound-identifier=? i pubovr-name)) l)
;; Either undefined or defined as syntax:
(let ([stx-l (hash-table-get stx-ht (syntax-e pubovr-name) (lambda () null))])
(let ([stx-l (hash-table-get stx-ht (syntax-e pubovr-name) null)])
(if (ormap (lambda (i) (bound-identifier=? i pubovr-name)) stx-l)
(bad
"method declared but defined as syntax"
@ -850,7 +850,7 @@
(hash-table-put! ht (syntax-e (cdr pub)) #t))
(append publics public-finals overrides override-finals augrides))
(for-each (lambda (inn)
(when (hash-table-get ht (syntax-e (cdr inn)) (lambda () #f))
(when (hash-table-get ht (syntax-e (cdr inn)) #f)
(bad
"inner method is locally declared as public, override, public-final, override-final, or augride"
(cdr inn))))
@ -1702,7 +1702,7 @@
(unless no-new-methods?
(let loop ([ids public-names][p (class-method-width super)])
(unless (null? ids)
(when (hash-table-get method-ht (car ids) (lambda () #f))
(when (hash-table-get method-ht (car ids) #f)
(obj-error 'class* "superclass already contains method: ~a~a"
(car ids)
(for-class name)))
@ -1711,7 +1711,7 @@
(unless no-new-fields?
(let loop ([ids public-field-names][p (class-field-width super)])
(unless (null? ids)
(when (hash-table-get field-ht (car ids) (lambda () #f))
(when (hash-table-get field-ht (car ids) #f)
(obj-error 'class* "superclass already contains field: ~a~a"
(car ids)
(for-class name)))
@ -1720,7 +1720,7 @@
;; Check that superclass has expected fields
(for-each (lambda (id)
(unless (hash-table-get field-ht id (lambda () #f))
(unless (hash-table-get field-ht id #f)
(obj-error 'class* "superclass does not provide field: ~a~a"
id
(for-class name))))
@ -1761,7 +1761,7 @@
(lambda (intf)
(for-each
(lambda (var)
(unless (hash-table-get method-ht var (lambda () #f))
(unless (hash-table-get method-ht var #f)
(obj-error 'class*
"interface-required method missing: ~a~a~a"
var
@ -2159,7 +2159,7 @@
(lambda (super)
(for-each
(lambda (var)
(when (hash-table-get ht var (lambda () #f))
(when (hash-table-get ht var #f)
(obj-error 'interface "variable already in superinterface: ~a~a~a"
var
(for-intf name)
@ -2557,7 +2557,7 @@
(identifier? (syntax abs-object))
(syntax
(let* ([c (object-ref abs-object)]
[pos (hash-table-get (class-method-ht c) name (lambda () #f))])
[pos (hash-table-get (class-method-ht c) name #f)])
(cond
[pos (values (vector-ref (class-methods c) pos) abs-object)]
[(wrapper-object? abs-object) wrapper-case]
@ -2699,7 +2699,7 @@
[index (hash-table-get
field-ht
id
(lambda () #f))])
#f)])
(cond
[index
((class-field-ref (car index)) obj (cdr index))]
@ -2729,7 +2729,7 @@
(let loop ([obj obj])
(let* ([cls (object-ref obj)]
[field-ht (class-field-ht cls)])
(or (and (hash-table-get field-ht id (lambda () #f))
(or (and (hash-table-get field-ht id #f)
#t) ;; ensure that only #t and #f leak out, not bindings in ht
(and (wrapper-object? obj)
(loop (wrapper-object-wrapped obj)))))))
@ -2850,7 +2850,7 @@
(raise-type-error 'object-method-arity-includes? "non-negative exact integer" cnt))
(let loop ([o o])
(let* ([c (object-ref o)]
[pos (hash-table-get (class-method-ht c) name (lambda () #f))])
[pos (hash-table-get (class-method-ht c) name #f)])
(cond
[pos (procedure-arity-includes? (vector-ref (class-methods c) pos)
(add1 cnt))]
@ -2867,7 +2867,7 @@
(unless (interface? i)
(raise-type-error 'interface-extension? "interface" 1 v i))
(and (interface? i)
(hash-table-get (interface-all-implemented v) i (lambda () #f))))
(hash-table-get (interface-all-implemented v) i #f)))
(define (method-in-interface? s i)
(unless (symbol? s)

54
collects/mzlib/private/sigmatch.ss
View File

@ -10,14 +10,14 @@
(lambda (s)
(cond
[(symbol? s)
(if (hash-table-get table s (lambda () #f))
(if (hash-table-get table s #f)
#f
(begin
(hash-table-put! table s s)
#t))]
[(and (pair? s) (symbol? (car s)))
(let ([name (car s)])
(if (hash-table-get table name (lambda () #f))
(if (hash-table-get table name #f)
#f
(let ([t (make-hash-table)])
(hash-table-put! table name t)
@ -33,6 +33,8 @@
(loop (format "~a:~a" s (car path))
(cdr path)))))
(define no-val (gensym))
(define (check-sig-match table sig path exact? who src-context dest-context wrapped? unwrap)
(and (wrapped? sig)
(vector? (unwrap sig))
@ -40,18 +42,18 @@
(lambda (s)
(cond
[(symbol? s)
(let ([v (hash-table-get table s
(lambda ()
(raise
(make-exn:fail:unit
(string->immutable-string
(format
"~a: ~a is missing a value name `~a', required by ~a"
who
src-context
(sig-path-name s path)
dest-context))
(current-continuation-marks)))))])
(let ([v (hash-table-get table s no-val)])
(when (eq? v no-val)
(raise
(make-exn:fail:unit
(string->immutable-string
(format
"~a: ~a is missing a value name `~a', required by ~a"
who
src-context
(sig-path-name s path)
dest-context))
(current-continuation-marks))))
(and v
(begin
(unless (symbol? v)
@ -70,18 +72,18 @@
(hash-table-put! table s #f)
#t)))]
[(and (pair? s) (symbol? (car s)))
(let ([v (hash-table-get table (car s)
(lambda ()
(raise
(make-exn:fail:unit
(string->immutable-string
(format
"~a: ~a is missing a sub-unit name `~a', required by ~a"
who
src-context
(sig-path-name (car s) path)
dest-context))
(current-continuation-marks)))))])
(let ([v (hash-table-get table (car s) no-val)])
(when (eq? v no-val)
(raise
(make-exn:fail:unit
(string->immutable-string
(format
"~a: ~a is missing a sub-unit name `~a', required by ~a"
who
src-context
(sig-path-name (car s) path)
dest-context))
(current-continuation-marks))))
(and v
(begin
(unless (hash-table? v)

12
collects/mzlib/unit.ss
View File

@ -105,7 +105,7 @@
;; Check that all exports are distinct (as symbols)
(let ([ht (make-hash-table)])
(for-each (lambda (name)
(when (hash-table-get ht (syntax-e name) (lambda () #f))
(when (hash-table-get ht (syntax-e name) #f)
(raise-syntax-error
#f
"duplicate export"
@ -218,17 +218,17 @@
(for-each
(lambda (kind+name)
(let ([name (cdr kind+name)])
(let ([l (hash-table-get ht (syntax-e name) (lambda () null))])
(let ([l (hash-table-get ht (syntax-e name) null)])
(hash-table-put! (if (eq? (car kind+name) 'val) ht stx-ht)
(syntax-e name)
(cons name l)))))
all-defined-names/kinds)
(for-each
(lambda (n)
(let ([v (hash-table-get ht (syntax-e n) (lambda () null))])
(let ([v (hash-table-get ht (syntax-e n) null)])
(unless (ormap (lambda (i) (bound-identifier=? i n)) v)
;; Either not defined, or defined as syntax:
(let ([stx-v (hash-table-get stx-ht (syntax-e n) (lambda () null))])
(let ([stx-v (hash-table-get stx-ht (syntax-e n) null)])
(if (ormap (lambda (i) (bound-identifier=? i n)) stx-v)
(raise-syntax-error
#f
@ -246,14 +246,14 @@
(let ([ht (make-hash-table)])
(for-each
(lambda (name)
(let ([l (hash-table-get ht (syntax-e name) (lambda () null))])
(let ([l (hash-table-get ht (syntax-e name) null)])
(hash-table-put! ht (syntax-e name) (cons name l))))
exported-names)
(let ([internal-names
(let loop ([l all-defined-val-names])
(cond
[(null? l) null]
[(let ([v (hash-table-get ht (syntax-e (car l)) (lambda () null))])
[(let ([v (hash-table-get ht (syntax-e (car l)) null)])
(ormap (lambda (i) (bound-identifier=? i (car l))) v))
(loop (cdr l))]
[else (cons (car l) (loop (cdr l)))]))])

4
collects/mzlib/unitsig.ss
View File

@ -57,9 +57,7 @@
(map
(lambda (name)
(list (let ([name (do-rename name (parsed-unit-renames a-unit))])
(hash-table-get vars
name
(lambda () name)))
(hash-table-get vars name name))
name))
(signature-vars sig)))
expr)]

11
collects/sgl/make-gl-info.ss
View File

@ -4,6 +4,7 @@
(prefix dynext: (lib "link.ss" "dynext"))
(lib "file.ss")
(lib "dirs.ss" "setup")
(lib "launcher.ss" "launcher")
(lib "string.ss" "srfi" "13"))
(provide make-gl-info)
@ -113,14 +114,15 @@ end-string
(dynext:link-extension #f (list file.o) file.so)
(delete/continue file.o)))
(define (build-helper compile-directory home)
(define (build-helper compile-directory home 3m?)
(let ((file (build-path compile-directory "make-gl-info-helper"))
(c (build-path compile-directory "make-gl-info-helper.c"))
(so (build-path compile-directory
"native"
(system-library-subpath #f)
(if 3m? "3m" 'same)
"make-gl-info-helper.so")))
(make-directory* (build-path compile-directory "native" (system-library-subpath #f)))
(make-directory* (build-path compile-directory "native" (system-library-subpath #f) (if 3m? "3m" 'same)))
(with-output-to-file c
(lambda () (display c-file))
'replace)
@ -166,7 +168,10 @@ end-string
(define gl-clampf-size 4)
(define gl-clampd-size 8)))
(else
(build-helper compile-directory home)
(build-helper compile-directory home #f)
(when (memq '3m (available-mzscheme-variants))
(parameterize ([dynext:link-variant '3m])
(build-helper compile-directory home #t)))
`(module gl-info mzscheme
(provide (all-defined))
,@(map

5
collects/syntax/primitives.ss
View File

@ -18,7 +18,8 @@
port-read-handler error-value->string-handler
call/ec call/cc hash-table-get
hash-table-map hash-table-for-each make-input-port make-output-port
current-module-name-resolver))
current-module-name-resolver
call-with-semaphore call-with-semaphore/enable-break))
;; The following primitives can compute return values by an
;; internal chained tail call (relevant to mzc)
@ -27,6 +28,8 @@
error
call-with-current-continuation
call-with-escape-continuation
call-with-semaphore
call-with-semaphore/enable-break
hash-table-get
write-image-to-file
syntax-local-value))

4
collects/syntax/private/boundmap.ss
View File

@ -38,7 +38,7 @@
(cdr i)))
(hash-table-get (identifier-mapping-ht bi)
(identifier->symbol id)
(lambda () null)))
null))
(fail))))
(define identifier-mapping-put!
@ -46,7 +46,7 @@
(let ([l (hash-table-get
(identifier-mapping-ht bi)
(identifier->symbol id)
(lambda () null))])
null)])
(hash-table-put!
(identifier-mapping-ht bi)
(identifier->symbol id)

6
doc/release-notes/mzscheme/HISTORY
View File

@ -1,3 +1,8 @@
Version 350.3
Changed hash-table-get to accept a non-prcedure third argument as
a default value (instead of requiring a thunk)
Improved 3m performance
Version 350.2
Changed the module name resolver protocol so that the resolver is
required to accept 1, 3, and 4 arguments; the new 4-argument mode
@ -6,6 +11,7 @@ Changed namespace-attach-module and namespace-unprotect-module
to accept quoted module paths, instead of only symbolic names
Fixed avoidable overflow and undeflow in magnitude and / for
inexact complex numbers
Fixed bug in continuation sharing
Version 350.1
Added define-member-name, member-name-key, and generate-member-key

8
src/Makefile.in
View File

@ -34,10 +34,11 @@ mred-stub: @MAKE_MRED@
mred3m-stub: @MAKE_MRED3M@
SETUP_ARGS = -mvqX "$(DESTDIR)$(collectsdir)" -M setup
install:
$(MAKE) plain-install
$(MAKE) setup-plt
"$(DESTDIR)$(bindir)/mzscheme3m" $(SETUP_ARGS)
$(MAKE) fix-paths
plain-install:
@ -52,9 +53,6 @@ install-normal:
mredinstall-stub: @MAKE_MREDINSTALL@
setup-plt:
"$(DESTDIR)$(bindir)/mzscheme" -mvqX "$(DESTDIR)$(collectsdir)" -M setup
plain-install-3m:
$(MAKE) install-normal
$(MAKE) mzinstall3m
@ -62,7 +60,7 @@ plain-install-3m:
install-3m:
$(MAKE) plain-install-3m
$(MAKE) setup-plt
"$(DESTDIR)$(bindir)/mzscheme3m" $(SETUP_ARGS)
$(MAKE) fix-paths
mredinstall3m-stub: @MAKE_MREDINSTALL3M@

1
src/mzscheme/gc2/Makefile.in
View File

@ -289,6 +289,7 @@ main.@LTO@: $(XSRCDIR)/main.c
gc2.@LTO@: $(srcdir)/gc2.c $(srcdir)/newgc.c $(srcdir)/compact.c $(srcdir)/newgc.c $(srcdir)/gc2.h \
$(srcdir)/vm_osx.c $(srcdir)/vm_mmap.c $(srcdir)/vm_osk.c $(srcdir)/alloc_cache.c $(srcdir)/my_qsort.c \
$(srcdir)/page_range.c $(srcdir)/protect_range.c $(srcdir)/../utils/splay.c \
$(srcdir)/weak.c $(srcdir)/fnls.c $(srcdir)/../include/scheme.h $(srcdir)/../src/schpriv.h
$(CC) $(CFLAGS) -c $(srcdir)/gc2.c -o gc2.@LTO@

32
src/mzscheme/gc2/alloc_cache.c
View File

@ -6,7 +6,7 @@
Requires (defined earlier):
system_free_pages --- called with len already rounded up to page size
page_size --- in bytes
my_qsort --- possibyl from my_qsort.c
my_qsort --- possibly from my_qsort.c
LOGICALLY_ALLOCATING_PAGES(len)
ACTUALLY_ALLOCATING_PAGES(len)
LOGICALLY_FREEING_PAGES(len)
@ -16,7 +16,7 @@
typedef struct {
void *start;
long len;
int age;
short age, zeroed;
} Free_Block;
#define BLOCKFREE_UNMAP_AGE 1
@ -39,10 +39,12 @@ static void collapse_adjacent_pages(void)
my_qsort(blockfree, BLOCKFREE_CACHE_SIZE, sizeof(Free_Block), compare_free_block);
j = 0;
for (i = 1; i < BLOCKFREE_CACHE_SIZE; i++) {
if ((blockfree[j].start + blockfree[j].len) ==blockfree[i].start) {
if ((blockfree[j].start + blockfree[j].len) == blockfree[i].start) {
blockfree[j].len += blockfree[i].len;
blockfree[i].start = NULL;
blockfree[i].len = 0;
if (!blockfree[i].zeroed)
blockfree[j].zeroed = 0;
} else
j = i;
}
@ -60,7 +62,8 @@ inline static void *find_cached_pages(size_t len, size_t alignment)
if (!alignment || !((unsigned long)r & (alignment - 1))) {
blockfree[i].start = NULL;
blockfree[i].len = 0;
memset(r, 0, len);
if (!blockfree[i].zeroed)
memset(r, 0, len);
LOGICALLY_ALLOCATING_PAGES(len);
return r;
}
@ -75,7 +78,8 @@ inline static void *find_cached_pages(size_t len, size_t alignment)
if (!alignment || !((unsigned long)r & (alignment - 1))) {
blockfree[i].start += len;
blockfree[i].len -= len;
memset(r, 0, len);
if (!blockfree[i].zeroed)
memset(r, 0, len);
LOGICALLY_ALLOCATING_PAGES(len);
return r;
}
@ -84,7 +88,8 @@ inline static void *find_cached_pages(size_t len, size_t alignment)
r = blockfree[i].start + (blockfree[i].len - len);
if (!((unsigned long)r & (alignment - 1))) {
blockfree[i].len -= len;
memset(r, 0, len);
if (!blockfree[i].zeroed)
memset(r, 0, len);
LOGICALLY_ALLOCATING_PAGES(len);
return r;
}
@ -98,7 +103,7 @@ inline static void *find_cached_pages(size_t len, size_t alignment)
return NULL;
}
static void free_pages(void *p, size_t len)
static void free_actual_pages(void *p, size_t len, int zeroed)
{
int i;
@ -106,19 +111,21 @@ static void free_pages(void *p, size_t len)
if (len & (page_size - 1))
len += page_size - (len & (page_size - 1));
LOGICALLY_FREEING_PAGES(len);
/* Try to free pages in larger blocks, since the OS may be slow. */
for (i = 0; i < BLOCKFREE_CACHE_SIZE; i++)
if(blockfree[i].start && (blockfree[i].len < (1024 * 1024))) {
if (p == blockfree[i].start + blockfree[i].len) {
blockfree[i].len += len;
if (!zeroed)
blockfree[i].zeroed = 0;
return;
}
if (p + len == blockfree[i].start) {
blockfree[i].start = p;
blockfree[i].len += len;
if (!zeroed)
blockfree[i].zeroed = 0;
return;
}
}
@ -128,6 +135,7 @@ static void free_pages(void *p, size_t len)
blockfree[i].start = p;
blockfree[i].len = len;
blockfree[i].age = 0;
blockfree[i].zeroed = zeroed;
return;
}
}
@ -140,6 +148,12 @@ static void free_pages(void *p, size_t len)
ACTUALLY_FREEING_PAGES(len);
}
static void free_pages(void *p, size_t len)
{
LOGICALLY_FREEING_PAGES(len);
free_actual_pages(p, len, 0);
}
static void flush_freed_pages(void)
{
int i;

7
src/mzscheme/gc2/compact.c
View File

@ -3932,6 +3932,11 @@ void *GC_malloc_one_tagged(size_t size_in_bytes)
return m;
}
void *GC_malloc_one_small_tagged(size_t size_in_bytes)
{
return GC_malloc_one_tagged(size_in_bytes);
}
#ifndef gcINLINE
# define gcINLINE inline
#endif
@ -4096,7 +4101,7 @@ void GC_free(void *p)
}
}
long GC_malloc_atomic_stays_put_threshold()
long GC_malloc_stays_put_threshold()
{
return BIGBLOCK_MIN_SIZE;
}

16
src/mzscheme/gc2/fnls.c
View File

@ -32,7 +32,13 @@ static int num_fnls;
#define Tree Fnl
#define Splay_Item(t) ((unsigned long)t->p)
#define Set_Splay_Item(t, v) (t)->p = (void *)v
#include "../sgc/splay.c"
#define splay fnl_splay
#define splay_insert fnl_splay_insert
#define splay_delete fnl_splay_delete
#include "../utils/splay.c"
#undef splay
#undef splay_insert
#undef splay_delete
void GC_set_finalizer(void *p, int tagged, int level, void (*f)(void *p, void *data),
void *data, void (**oldf)(void *p, void *data),
@ -47,7 +53,7 @@ void GC_set_finalizer(void *p, int tagged, int level, void (*f)(void *p, void *d
return;
}
splayed_finalizers = splay((unsigned long)p, splayed_finalizers);
splayed_finalizers = fnl_splay((unsigned long)p, splayed_finalizers);
fnl = splayed_finalizers;
if (fnl && (fnl->p == p)) {
if (oldf) *oldf = fnl->f;
@ -64,7 +70,7 @@ void GC_set_finalizer(void *p, int tagged, int level, void (*f)(void *p, void *d
if (fnl->next)
fnl->next->prev = fnl->prev;
--num_fnls;
splayed_finalizers = splay_delete((unsigned long)p, splayed_finalizers);
splayed_finalizers = fnl_splay_delete((unsigned long)p, splayed_finalizers);
}
return;
}
@ -125,7 +131,7 @@ void GC_set_finalizer(void *p, int tagged, int level, void (*f)(void *p, void *d
#endif
finalizers = fnl;
splayed_finalizers = splay_insert((unsigned long)p, fnl, splayed_finalizers);
splayed_finalizers = fnl_splay_insert((unsigned long)p, fnl, splayed_finalizers);
num_fnls++;
}
@ -140,7 +146,7 @@ static void reset_finalizer_tree()
for (fnl = finalizers; fnl; fnl = fnl->next) {
fnl->prev = prev;
splayed_finalizers = splay_insert((unsigned long)fnl->p, fnl, splayed_finalizers);
splayed_finalizers = fnl_splay_insert((unsigned long)fnl->p, fnl, splayed_finalizers);
prev = fnl;
}
}

12
src/mzscheme/gc2/gc2.h
View File

@ -126,6 +126,11 @@ GC2_EXTERN void *GC_malloc_one_tagged(size_t);
Alloc a tagged item, initially zeroed. MzScheme sets the tag
before a collection. */
GC2_EXTERN void *GC_malloc_one_small_tagged(size_t);
/*
Like GC_malloc_one_tagged, but the size must be less than 1kb,
it must not be zero, and it must be a multiple of the word size. */
GC2_EXTERN void *GC_malloc_one_xtagged(size_t);
/*
Alloc an item, initially zeroed. Rather than having a specific tag,
@ -191,10 +196,11 @@ GC2_EXTERN void GC_free_immobile_box(void **b);
Allocate (or free) a non-GCed box containing a pointer to a GCed
value. The pointer is stored as the first longword of the box. */
GC2_EXTERN long GC_malloc_atomic_stays_put_threshold();
GC2_EXTERN long GC_malloc_stays_put_threshold();
/*
Returns a minimum size for which atomic allocations generate
objects that never move. */
Returns a minimum size for which allocations generate
objects that never move, and where pointers are allowed
into the object's interior. */
/***************************************************************************/
/* Memory tracing */

50
src/mzscheme/gc2/newgc.c
View File

@ -164,6 +164,8 @@ inline static void free_used_pages(size_t len)
#define LOGICALLY_FREEING_PAGES(len) free_used_pages(len)
#define ACTUALLY_FREEING_PAGES(len) /* empty */
#include "page_range.c"
#if _WIN32
# include "vm_win.c"
# define MALLOCATOR_DEFINED
@ -185,6 +187,8 @@ void designate_modified(void *p);
# include "vm_mmap.c"
#endif
#include "protect_range.c"
#define malloc_dirty_pages(size,align) malloc_pages(size,align)
/*****************************************************************************/
@ -476,7 +480,29 @@ void *GC_malloc_atomic_uncollectable(size_t s) { return malloc(s); }
void *GC_malloc_allow_interior(size_t s) {return allocate_big(s, PAGE_ARRAY);}
void GC_free(void *p) {}
long GC_malloc_atomic_stays_put_threshold() { return gcWORDS_TO_BYTES(MAX_OBJECT_SIZEW); }
void *GC_malloc_one_small_tagged(size_t sizeb)
{
unsigned long newsize;
sizeb += WORD_SIZE;
newsize = gen0_alloc_page->size + sizeb;
if(newsize > GEN0_PAGE_SIZE) {
return GC_malloc_one_tagged(sizeb - WORD_SIZE);
} else {
void *retval = PTR(NUM(gen0_alloc_page) + gen0_alloc_page->size);
struct objhead *info = (struct objhead *)retval;
/* info->type = type; */ /* We know that the type field is already 0 */
info->size = (sizeb >> gcLOG_WORD_SIZE);
gen0_alloc_page->size = newsize;
gen0_current_size += sizeb;
return PTR(NUM(retval) + WORD_SIZE);
}
}
long GC_malloc_stays_put_threshold() { return gcWORDS_TO_BYTES(MAX_OBJECT_SIZEW); }
/* this function resizes generation 0 to the closest it can get (erring high)
to the size we've computed as ideal */
@ -563,7 +589,6 @@ inline static void reset_nursery(void)
/* } */
resize_gen0(new_gen0_size);
flush_freed_pages();
}
/* This procedure fundamentally returns true if a pointer is marked, and
@ -1805,6 +1830,8 @@ void GC_init_type_tags(int count, int weakbox, int ephemeron, int weakarray)
fixup_weak_array, 0, 0);
initialize_signal_handler();
GC_add_roots(&park, (char *)&park + sizeof(park) + 1);
initialize_protect_page_ranges(malloc_dirty_pages(APAGE_SIZE, APAGE_SIZE), APAGE_SIZE);
}
}
@ -2268,9 +2295,14 @@ static void prepare_pages_for_collection(void)
if(gc_full) {
/* we need to make sure that previous_size for every page is reset, so
we don't accidentally screw up the mark routine */
if (generations_available) {
for(i = 0; i < PAGE_TYPES; i++)
for(work = pages[i]; work; work = work->next)
add_protect_page_range(work, work->big_page ? work->size : APAGE_SIZE, APAGE_SIZE, 1);
flush_protect_page_ranges(1);
}
for(i = 0; i < PAGE_TYPES; i++)
for(work = pages[i]; work; work = work->next) {
protect_pages(work, work->big_page ? work->size : APAGE_SIZE, 1);
work->live_size = 0;
work->previous_size = HEADER_SIZEB;
}
@ -2279,9 +2311,11 @@ static void prepare_pages_for_collection(void)
pages in pages[] from the page map */
for(i = 0; i < PAGE_TYPES; i++)
for(work = pages[i]; work; work = work->next) {
protect_pages(work, work->big_page ? work->size : APAGE_SIZE, 1);
if (generations_available)
add_protect_page_range(work, work->big_page ? work->size : APAGE_SIZE, APAGE_SIZE, 1);
pagemap_remove(work);
}
flush_protect_page_ranges(1);
}
/* we do this here because, well, why not? */
@ -2330,7 +2364,6 @@ static void mark_backpointers(void)
}
work->previous_size = HEADER_SIZEB;
} else {
protect_pages(work, work->big_page ? work->size : APAGE_SIZE, 1);
GCDEBUG((DEBUGOUTF,"Setting previous_size on %p to %i\n", work,
work->size));
work->previous_size = work->size;
@ -2632,7 +2665,9 @@ static void protect_old_pages(void)
if(i != PAGE_ATOMIC)
for(page = pages[i]; page; page = page->next)
if(page->page_type != PAGE_ATOMIC)
protect_pages(page, page->size, 0);
add_protect_page_range(page, page->size, APAGE_SIZE, 0);
flush_protect_page_ranges(0);
}
static void gc_overmem_abort()
@ -2724,7 +2759,8 @@ static void garbage_collect(int force_full)
do_btc_accounting();
if (generations_available)
protect_old_pages();
flush_freed_pages();
if (gc_full)
flush_freed_pages();
reset_finalizer_tree();
/* new we do want the allocator freaking if we go over half */

145
src/mzscheme/gc2/page_range.c Normal file
View File

@ -0,0 +1,145 @@
/*
Provides:
initialize_page_ranges
flush_page_ranges
add_page_range
*/
typedef struct Range {
unsigned long start, len;
struct Range *left, *right, *prev, *next;
} Range;
#define Tree Range
#define Splay_Item(t) (t)->start
#define Set_Splay_Item(t, v) (t)->start = (v)
#define splay range_splay
#define splay_insert range_splay_insert
#define OMIT_SPLAY_DELETE
#include "../utils/splay.c"
#undef splay
#undef splay_insert
#undef OMIT_SPLAY_DELETE
#undef Tree
#undef Splay_Item
#undef Set_Splay_Item
typedef struct Page_Range {
Range *range_root, *range_start;
void *range_alloc_block;
unsigned long range_alloc_size;
unsigned long range_alloc_used;
} Page_Range;
static void initialize_page_ranges(Page_Range *pr, void *block, unsigned long size)
{
pr->range_root = NULL;
pr->range_start = NULL;
pr->range_alloc_block = block;
pr->range_alloc_size = size;
pr->range_alloc_used = 0;
}
static void compact_page_ranges(Page_Range *pr)
{
Range *work, *next;
unsigned long start, len;
for (work = pr->range_start; work; work = next) {
next = work->next;
start = work->start;
len = work->len;
/* Collapse adjacent nodes: */
while (next && (next->start == start + len)) {
len += next->len;
next = next->next;
}
work->start = start;
work->len = len;
work->next = next;
}
}
static void reset_page_ranges(Page_Range *pr)
{
pr->range_alloc_used = 0;
pr->range_root = NULL;
pr->range_start = NULL;
}
static int try_extend(Range *r, unsigned long start, unsigned long len)
{
if (!r)
return 0;
if (r->start == start + len) {
r->start = start;
r->len += len;
return 1;
}
if (r->start + r->len == start) {
r->len += len;
return 1;
}
return 0;
}
static int add_page_range(Page_Range *pr, void *_start, unsigned long len, unsigned long alignment)
{
unsigned long start = (unsigned long)_start;
Range *r, *range_root = pr->range_root;
len += (alignment - 1);
len -= (len & (alignment - 1));
range_root = range_splay(start, range_root);
if (range_root) {
if (try_extend(range_root, start, len)
|| try_extend(range_root->prev, start, len)
|| try_extend(range_root->next, start, len)) {
pr->range_root = range_root;
return 1;
}
}
r = (Range *)((char *)pr->range_alloc_block + pr->range_alloc_used);
pr->range_alloc_used += sizeof(Range);
if (pr->range_alloc_used > pr->range_alloc_size) {
return 0;
} else {
r->len = len;
if (range_root) {
if (start < range_root->start) {
r->next = range_root;
r->prev = range_root->prev;
if (r->prev)
r->prev->next = r;
else
pr->range_start = r;
range_root->prev = r;
} else {
r->prev = range_root;
r->next = range_root->next;
if (r->next)
r->next->prev = r;
range_root->next = r;
}
range_root = range_splay_insert(start, r, range_root);
} else {
r->prev = r->next = NULL;
r->left = r->right = NULL;
range_root = r;
r->start = start;
pr->range_start = r;
}
pr->range_root = range_root;
return 1;
}
}

34
src/mzscheme/gc2/protect_range.c Normal file
View File

@ -0,0 +1,34 @@
/*
Provides:
Requires:
[page_range.c exports]
[page allocator]
*/
static Page_Range protect_range;
static void initialize_protect_page_ranges(void *block, unsigned long size)
{
initialize_page_ranges(&protect_range, block, size);
}
static void flush_protect_page_ranges(int writeable)
{
Range *work;
compact_page_ranges(&protect_range);
for (work = protect_range.range_start; work; work = work->next) {
protect_pages((void *)work->start, work->len, writeable);
}
reset_page_ranges(&protect_range);
}
static void add_protect_page_range(void *_start, unsigned long len, unsigned long alignment, int writeable)
{
if (!add_page_range(&protect_range, _start, len, alignment)) {
flush_protect_page_ranges(writeable);
add_page_range(&protect_range, _start, len, alignment);
}
}

14
src/mzscheme/gc2/vm_mmap.c
View File

@ -95,9 +95,17 @@ static void *malloc_pages(size_t len, size_t alignment)
if (pre_extra)
if (munmap(r, pre_extra))
GCPRINT(GCOUTF, "Unmap warning: %lx, %ld, %d\n", (long)r, pre_extra, errno);
if (pre_extra < extra)
if (munmap(real_r + len, extra - pre_extra))
GCPRINT(GCOUTF, "Unmap warning: %lx, %ld, %d\n", (long)r, pre_extra, errno);
if (pre_extra < extra) {
if (!pre_extra) {
/* Instead of actually unmapping, put it in the cache, and there's
a good chance we can use it next time: */
ACTUALLY_ALLOCATING_PAGES(extra);
free_actual_pages(real_r + len, extra, 1);
} else {
if (munmap(real_r + len, extra - pre_extra))
GCPRINT(GCOUTF, "Unmap warning: %lx, %ld, %d\n", (long)r, pre_extra, errno);
}
}
r = real_r;
}

20
src/mzscheme/gc2/vm_osx.c
View File

@ -55,8 +55,9 @@ void designate_modified(void *p);
# define CHECK_USED_AGAINST_MAX(x) /* empty */
#endif
/* Forward declaration: */
/* Forward declarations: */
inline static void *find_cached_pages(size_t len, size_t alignment);
static void free_actual_pages(void *p, size_t len, int zeroed);
/* the structure of an exception msg and its reply */
typedef struct rep_msg {
@ -130,11 +131,18 @@ static void *malloc_pages(size_t len, size_t alignment)
}
}
if(pre_extra < extra) {
retval = vm_deallocate(task_self, (vm_address_t)real_r + len,
extra - pre_extra);
if(retval != KERN_SUCCESS) {
GCPRINT(GCOUTF, "WARNING: couldn't deallocate post-extra: %s\n",
mach_error_string(retval));
if (!pre_extra) {
/* Instead of actually unmapping, put it in the cache, and there's
a good chance we can use it next time: */
ACTUALLY_ALLOCATING_PAGES(extra);
free_actual_pages(real_r + len, extra, 1);
} else {
retval = vm_deallocate(task_self, (vm_address_t)real_r + len,
extra - pre_extra);
if(retval != KERN_SUCCESS) {
GCPRINT(GCOUTF, "WARNING: couldn't deallocate post-extra: %s\n",
mach_error_string(retval));
}
}
}
r = real_r;

6
src/mzscheme/include/scheme.h
View File

@ -1413,9 +1413,9 @@ MZ_EXTERN void scheme_jit_setjmp_prepare(mz_jit_jmp_buf b);
/* Allocation */
#define scheme_alloc_object() \
((Scheme_Object *) scheme_malloc_tagged(sizeof(Scheme_Simple_Object)))
((Scheme_Object *) scheme_malloc_small_tagged(sizeof(Scheme_Simple_Object)))
#define scheme_alloc_small_object() \
((Scheme_Object *) scheme_malloc_tagged(sizeof(Scheme_Small_Object)))
((Scheme_Object *) scheme_malloc_small_tagged(sizeof(Scheme_Small_Object)))
#define scheme_alloc_stubborn_object() \
((Scheme_Object *) scheme_malloc_stubborn_tagged(sizeof(Scheme_Simple_Object)))
#define scheme_alloc_stubborn_small_object() \
@ -1459,6 +1459,7 @@ void *scheme_malloc(size_t size);
# include "../gc2/gc2.h"
# endif
# define scheme_malloc_tagged GC_malloc_one_tagged
# define scheme_malloc_small_tagged(s) GC_malloc_one_small_tagged(gcWORDS_TO_BYTES(gcBYTES_TO_WORDS(s)))
# define scheme_malloc_array_tagged GC_malloc_array_tagged
# define scheme_malloc_atomic_tagged GC_malloc_atomic_tagged
# define scheme_malloc_stubborn_tagged GC_malloc_one_tagged
@ -1479,6 +1480,7 @@ extern void *scheme_malloc_uncollectable_tagged(size_t);
extern void *scheme_malloc_envunbox(size_t);
# else
# define scheme_malloc_tagged scheme_malloc
# define scheme_malloc_small_tagged scheme_malloc
# define scheme_malloc_array_tagged scheme_malloc
# define scheme_malloc_atomic_tagged scheme_malloc_atomic
# define scheme_malloc_stubborn_tagged scheme_malloc_stubborn

2
src/mzscheme/sgc/sgc.c
View File

@ -572,7 +572,7 @@ typedef struct {
static SectorPage **sector_pagetables;
#if !RELEASE_UNUSED_SECTORS
# include "splay.c"
# include "../utils/splay.c"
typedef struct SectorFreepage {
long size;

10
src/mzscheme/src/bignum.c
View File

@ -164,7 +164,7 @@ Scheme_Object *scheme_make_bignum(long v)
Small_Bignum *r;
r = MALLOC_ONE_TAGGED(Small_Bignum);
#if MZ_PRECISE_GC
SCHEME_SET_BIGINLINE(&r->o, 1);
SCHEME_SET_BIGINLINE(&r->o);
#endif
return scheme_make_small_bignum(v, r);
}
@ -174,7 +174,7 @@ Scheme_Object *scheme_make_bignum_from_unsigned(unsigned long v)
Small_Bignum *r;
r = MALLOC_ONE_TAGGED(Small_Bignum);
#if MZ_PRECISE_GC
SCHEME_SET_BIGINLINE(&r->o, 1);
SCHEME_SET_BIGINLINE(&r->o);
#endif
r->o.iso.so.type = scheme_bignum_type;
SCHEME_SET_BIGPOS(&r->o, 1);
@ -252,7 +252,7 @@ Scheme_Object *scheme_make_bignum_from_unsigned_long_long(umzlonglong v)
Small_Bignum *r;
r = MALLOC_ONE_TAGGED(Small_Bignum);
#if MZ_PRECISE_GC
SCHEME_SET_BIGINLINE(&r->o, 1);
SCHEME_SET_BIGINLINE(&r->o);
#endif
r->o.iso.so.type = scheme_bignum_type;
SCHEME_SET_BIGPOS(&r->o, 1);
@ -441,7 +441,7 @@ static Scheme_Object *make_single_bigdig_result(int pos, bigdig d)
sm = MALLOC_ONE_TAGGED(Small_Bignum);
sm->o.iso.so.type = scheme_bignum_type;
#if MZ_PRECISE_GC
SCHEME_SET_BIGINLINE(sm, 1);
SCHEME_SET_BIGINLINE(sm);
#endif
SCHEME_SET_BIGPOS(sm, pos);
SCHEME_BIGLEN(sm) = 1;
@ -562,7 +562,7 @@ Scheme_Object *scheme_bignum_negate(const Scheme_Object *n)
/* Can't share bigdig array when n is a Small_Bignum */
o = (Scheme_Object *)scheme_malloc_tagged(sizeof(Small_Bignum));
#if MZ_PRECISE_GC
SCHEME_SET_BIGINLINE(o, 1);
SCHEME_SET_BIGINLINE(o);
#endif
((Small_Bignum *)o)->v[0] = SCHEME_BIGDIG(n)[0];
SCHEME_BIGDIG(o) = ((Small_Bignum *) mzALIAS o)->v;

4467
src/mzscheme/src/cstartup.inc
View File

File diff suppressed because it is too large Load Diff

2
src/mzscheme/src/fun.c
View File

@ -2590,7 +2590,7 @@ apply(int argc, Scheme_Object *argv[])
}
num_rands += (argc - 2);
if (1 || num_rands > p->tail_buffer_size) {
if (num_rands > p->tail_buffer_size) {
rand_vec = MALLOC_N(Scheme_Object *, num_rands);
/* num_rands might be very big, so don't install it as the tail buffer */
} else

252
src/mzscheme/src/hash.c
View File

@ -28,15 +28,36 @@
#include <ctype.h>
#include <math.h>
int scheme_hash_request_count;
int scheme_hash_iteration_count;
#ifdef MZ_PRECISE_GC
# define PTR_TO_LONG(p) scheme_hash_key(p)
static short keygen;
XFORM_NONGCING static
#ifndef NO_INLINE_KEYWORD
MSC_IZE(inline)
#endif
long PTR_TO_LONG(Scheme_Object *o)
{
short v;
if (SCHEME_INTP(o))
return (long)o;
v = o->keyex;
if (!(v & 0xFFFC)) {
if (!keygen)
keygen += 4;
v |= keygen;
o->keyex = v;
keygen += 4;
}
return (o->type << 16) | v;
}
#else
# ifdef DOS_MEMORY
# include <dos.h>
# define PTR_TO_LONG(p) ((FP_SEG(p) << 4) + FP_OFF(p))
# else
# define PTR_TO_LONG(p) ((long)(p))
# endif
# define PTR_TO_LONG(p) ((long)(p))
#endif
#define FILL_FACTOR 1.4
@ -51,7 +72,7 @@ long scheme_hash_primes[] =
typedef int (*Hash_Compare_Proc)(void*, void*);
typedef long hash_v_t;
typedef unsigned long hash_v_t;
/*========================================================================*/
/* hashing functions */
@ -140,27 +161,23 @@ static Scheme_Object *do_hash(Scheme_Hash_Table *table, Scheme_Object *key, int
rehash_key:
if (table->make_hash_indices) {
table->make_hash_indices((void *)key, &h, &h2);
table->make_hash_indices((void *)key, (long *)&h, (long *)&h2);
h = h % size;
h2 = h2 % size;
} else {
long lkey;
lkey = PTR_TO_LONG((Scheme_Object *)key);
unsigned long lkey;
lkey = (unsigned long)PTR_TO_LONG((Scheme_Object *)key);
h = (lkey >> 2) % size;
h2 = (lkey >> 3) % size;
}
if (h < 0) h = -h;
if (h2 < 0) {
h2 = -h2;
if (h2 & 0x1)
h2++; /* note: table size is never even, so no % needed */
} else if (!h2)
if (!h2)
h2 = 2;
keys = table->keys;
if (table->compare) {
scheme_hash_request_count++;
while ((tkey = keys[h])) {
if (SAME_PTR(tkey, GONE)) {
if (set > 1) {
@ -178,9 +195,11 @@ static Scheme_Object *do_hash(Scheme_Hash_Table *table, Scheme_Object *key, int
} else
return table->vals[h];
}
scheme_hash_iteration_count++;
h = (h + h2) % size;
}
} else {
scheme_hash_request_count++;
while ((tkey = keys[h])) {
if (SAME_PTR(tkey, key)) {
if (set) {
@ -198,6 +217,7 @@ static Scheme_Object *do_hash(Scheme_Hash_Table *table, Scheme_Object *key, int
set = 1;
}
}
scheme_hash_iteration_count++;
h = (h + h2) % size;
}
}
@ -421,25 +441,23 @@ get_bucket (Scheme_Bucket_Table *table, const char *key, int add, Scheme_Bucket
rehash_key:
if (table->make_hash_indices) {
table->make_hash_indices((void *)key, &h, &h2);
table->make_hash_indices((void *)key, (long *)&h, (long *)&h2);
h = h % table->size;
h2 = h2 % table->size;
} else {
long lkey;
lkey = PTR_TO_LONG((Scheme_Object *)key);
unsigned long lkey;
lkey = (unsigned long)PTR_TO_LONG((Scheme_Object *)key);
h = (lkey >> 2) % table->size;
h2 = (lkey >> 3) % table->size;
}
if (h < 0) h = -h;
if (h2 < 0) h2 = -h2;
if (!h2)
h2 = 2;
else if (h2 & 0x1)
h2++;
if (table->weak) {
scheme_hash_request_count++;
while ((bucket = table->buckets[h])) {
if (bucket->key) {
void *hk = (void *)HT_EXTRACT_WEAK(bucket->key);
@ -456,14 +474,17 @@ get_bucket (Scheme_Bucket_Table *table, const char *key, int add, Scheme_Bucket
return bucket;
} else if (add)
break;
scheme_hash_iteration_count++;
h = (h + h2) % table->size;
}
} else {
scheme_hash_request_count++;
while ((bucket = table->buckets[h])) {
if (SAME_PTR(bucket->key, key))
return bucket;
else if (compare && !compare((void *)bucket->key, (void *)key))
return bucket;
scheme_hash_iteration_count++;
h = (h + h2) % table->size;
}
}
@ -697,195 +718,14 @@ int scheme_bucket_table_equal(Scheme_Bucket_Table *t1, Scheme_Bucket_Table *t2)
START_XFORM_SKIP;
typedef long (*Hash_Key_Proc)(Scheme_Object *o);
Hash_Key_Proc hash_key_procs[_scheme_last_normal_type_];
static short keygen;
static long hash_addr(Scheme_Object *o)
{
return (long)o;
}
static long hash_general(Scheme_Object *o)
{
if (!(((short *) mzALIAS o)[1] & 0xFFFC)) {
if (!keygen)
keygen += 4;
((short *) mzALIAS o)[1] |= keygen;
keygen += 4;
}
/* Relies on int = two shorts: */
return *(int *) mzALIAS o;
}
static long hash_symbol(Scheme_Object *o)
{
if (!(((short *) mzALIAS o)[1] & 0xFFFC)) {
Scheme_Symbol *s = (Scheme_Symbol *) mzALIAS o;
if (!(MZ_OPT_HASH_KEY(&s->iso) & 0x1)) {
/* Interned. Make key depend only on the content. */
int i, h = 0;
for (i = s->len; i--; ) {
h += (h << 5) + h + s->s[i];
}
h += (h << 2);
if (!(((short)h) & 0xFFFC))
h = 0x10;
MZ_OPT_HASH_KEY(&s->iso) |= (((short)h) & 0xFFFC);
} else
return hash_general(o);
}
/* Relies on int = two shorts: */
return *(int *) mzALIAS o;
}
static long hash_prim(Scheme_Object *o)
{
return (long)((Scheme_Primitive_Proc *)o)->prim_val;
}
static long hash_case(Scheme_Object *o)
{
Scheme_Case_Lambda *cl = (Scheme_Case_Lambda *)o;
if (cl->count)
return scheme_hash_key(cl->array[0]);
else
return scheme_case_closure_type << 2;
}
static long hash_bignum(Scheme_Object *o)
{
int i = SCHEME_BIGLEN(o);
bigdig *d = SCHEME_BIGDIG(o);
bigdig k = 0;
while (i--) {
k += d[i];
}
return (long)k;
}
void scheme_init_hash_key_procs(void)
{
#define PROC(t,f) hash_key_procs[t] = f
PROC(scheme_prim_type, hash_prim);
PROC(scheme_closed_prim_type, hash_prim);
PROC(scheme_closure_type, hash_general);
PROC(scheme_native_closure_type, hash_general);
PROC(scheme_case_closure_type, hash_case);
PROC(scheme_cont_type, hash_general);
PROC(scheme_escaping_cont_type, hash_general);
PROC(scheme_char_type, hash_addr);
PROC(scheme_bignum_type, hash_bignum);
PROC(scheme_rational_type, hash_general);
PROC(scheme_float_type, hash_general);
PROC(scheme_double_type, hash_general);
PROC(scheme_complex_izi_type, hash_general);
PROC(scheme_complex_type, hash_general);
PROC(scheme_char_string_type, hash_general);
PROC(scheme_byte_string_type, hash_general);
PROC(scheme_path_type, hash_general);
PROC(scheme_symbol_type, hash_symbol);
PROC(scheme_keyword_type, hash_symbol);
PROC(scheme_null_type, hash_addr);
PROC(scheme_pair_type, hash_general);
PROC(scheme_wrap_chunk_type, hash_general);
PROC(scheme_vector_type, hash_general);
PROC(scheme_input_port_type, hash_general);
PROC(scheme_output_port_type, hash_general);
PROC(scheme_eof_type, hash_addr);
PROC(scheme_true_type, hash_addr);
PROC(scheme_false_type, hash_addr);
PROC(scheme_void_type, hash_addr);
PROC(scheme_undefined_type, hash_addr);
PROC(scheme_syntax_compiler_type, hash_general);
PROC(scheme_macro_type, hash_general);
PROC(scheme_box_type, hash_general);
PROC(scheme_thread_type, hash_general);
PROC(scheme_thread_set_type, hash_general);
PROC(scheme_thread_suspend_type, hash_general);
PROC(scheme_thread_resume_type, hash_general);
PROC(scheme_thread_dead_type, hash_general);
PROC(scheme_structure_type, hash_general);
PROC(scheme_proc_struct_type, hash_general);
PROC(scheme_cont_mark_set_type, hash_general);
PROC(scheme_sema_type, hash_general);
PROC(scheme_channel_type, hash_general);
PROC(scheme_channel_put_type, hash_general);
PROC(scheme_hash_table_type, hash_general);
PROC(scheme_module_registry_type, hash_general);
PROC(scheme_bucket_table_type, hash_general);
PROC(scheme_weak_box_type, hash_general);
PROC(scheme_ephemeron_type, hash_general);
PROC(scheme_struct_type_type, hash_general);
PROC(scheme_set_macro_type, hash_general);
PROC(scheme_id_macro_type, hash_general);
PROC(scheme_listener_type, hash_general);
PROC(scheme_namespace_type, hash_general);
PROC(scheme_config_type, hash_general);
PROC(scheme_thread_cell_type, hash_general);
PROC(scheme_thread_cell_values_type, hash_general);
PROC(scheme_global_ref_type, hash_general);
PROC(scheme_will_executor_type, hash_general);
PROC(scheme_stx_type, hash_general);
PROC(scheme_module_index_type, hash_general);
PROC(scheme_custodian_type, hash_general);
PROC(scheme_random_state_type, hash_general);
PROC(scheme_regexp_type, hash_general);
PROC(scheme_compilation_top_type, hash_general);
PROC(scheme_placeholder_type, hash_general);
PROC(scheme_inspector_type, hash_general);
PROC(scheme_struct_property_type, hash_general);
PROC(scheme_rename_table_type, hash_general);
PROC(scheme_module_index_type, hash_general);
PROC(scheme_variable_type, hash_general);
PROC(scheme_module_variable_type, hash_general);
PROC(scheme_security_guard_type, hash_general);
PROC(scheme_evt_set_type, hash_general);
PROC(scheme_udp_type, hash_general);
PROC(scheme_udp_evt_type, hash_general);
PROC(scheme_wrap_evt_type, hash_general);
PROC(scheme_handle_evt_type, hash_general);
PROC(scheme_nack_evt_type, hash_general);
PROC(scheme_nack_guard_evt_type, hash_general);
PROC(scheme_poll_evt_type, hash_general);
PROC(scheme_always_evt_type, hash_general);
PROC(scheme_never_evt_type, hash_general);
PROC(scheme_progress_evt_type, hash_general);
PROC(scheme_write_evt_type, hash_general);
PROC(scheme_semaphore_repost_type, hash_general);
PROC(scheme_string_converter_type, hash_general);
PROC(scheme_alarm_type, hash_general);
PROC(scheme_special_comment_type, hash_general);
PROC(scheme_readtable_type, hash_general);
#undef PROC
/* No initialization needed anymore. */
}
long scheme_hash_key(Scheme_Object *o)
{
Scheme_Type t;
if (SCHEME_INTP(o))
return (long)o;
t = SCHEME_TYPE(o);
if (t >= _scheme_last_normal_type_) {
return hash_general(o);
} else {
#if 0
if (!hash_key_procs[t]) {
printf("Can't hash %d\n", t);
abort();
}
#endif
return hash_key_procs[t](o);
}
return PTR_TO_LONG(o);
}
END_XFORM_SKIP;

2
src/mzscheme/src/jit.c
View File

@ -344,7 +344,7 @@ static void *generate_one(mz_jit_state *old_jitter,
} else {
#ifdef MZ_PRECISE_GC
long minsz;
minsz = GC_malloc_atomic_stays_put_threshold();
minsz = GC_malloc_stays_put_threshold();
if (size < minsz)
size = minsz;
buffer = (char *)scheme_malloc_atomic(size);

16
src/mzscheme/src/list.c
View File

@ -1563,7 +1563,7 @@ static Scheme_Object *hash_table_put(int argc, Scheme_Object *argv[])
static Scheme_Object *hash_table_get(int argc, Scheme_Object *argv[])
{
void *v;
Scheme_Object *v;
if (!(SCHEME_HASHTP(argv[0]) || SCHEME_BUCKTP(argv[0])))
scheme_wrong_type("hash-table-get", "hash-table", 0, argc, argv);
@ -1571,7 +1571,7 @@ static Scheme_Object *hash_table_get(int argc, Scheme_Object *argv[])
if (SCHEME_BUCKTP(argv[0])){
Scheme_Bucket_Table *t = (Scheme_Bucket_Table *)argv[0];
if (t->mutex) scheme_wait_sema(t->mutex, 0);
v = scheme_lookup_in_table(t, (char *)argv[1]);
v = (Scheme_Object *)scheme_lookup_in_table(t, (char *)argv[1]);
if (t->mutex) scheme_post_sema(t->mutex);
} else {
Scheme_Hash_Table *t = (Scheme_Hash_Table *)argv[0];
@ -1581,10 +1581,14 @@ static Scheme_Object *hash_table_get(int argc, Scheme_Object *argv[])
}
if (v)
return (Scheme_Object *)v;
else if (argc == 3)
return _scheme_tail_apply(argv[2], 0, NULL);
else {
return v;
else if (argc == 3) {
v = argv[2];
if (SCHEME_PROCP(v))
return _scheme_tail_apply(v, 0, NULL);
else
return v;
} else {
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"hash-table-get: no value found for key: %V",
argv[1]);

23
src/mzscheme/src/module.c
View File

@ -175,7 +175,7 @@ static Scheme_Object *parse_requires(Scheme_Object *form,
Scheme_Object *rn, Scheme_Object *post_ex_rn,
Check_Func ck, void *data,
int start, int expstart, Scheme_Object *redef_modname,
int unpack_kern, int copy_vars,
int unpack_kern, int copy_vars, int can_save_marshal,
int *all_simple);
static void start_module(Scheme_Module *m, Scheme_Env *env, int restart, Scheme_Object *syntax_idx, int delay_exptime, int with_tt, Scheme_Object *cycle_list);
static void expstart_module(Scheme_Module *m, Scheme_Env *env, int restart, Scheme_Object *syntax_idx, int delay_exptime, int with_tt, Scheme_Object *cycle_list);
@ -969,7 +969,7 @@ static Scheme_Object *do_namespace_require(int argc, Scheme_Object *argv[], int
rn = scheme_make_module_rename(for_exp, mzMOD_RENAME_TOPLEVEL, NULL);
(void)parse_requires(form, scheme_false, env, rn, rn,
NULL, NULL, !etonly, etonly, NULL, 1, copy, NULL);
NULL, NULL, !etonly, etonly, NULL, 1, copy, 0, NULL);
brn = env->rename;
if (!brn) {
@ -4142,7 +4142,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
/* Add requires to renaming: */
imods = parse_requires(e, self_modidx, env->genv,
rn, post_ex_rn, check_require_name, tables, 0, 1,
redef_modname, 0, 0,
redef_modname, 0, 0, 1,
&all_simple_renames);
/* Add required modules to requires list: */
@ -4160,7 +4160,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
/* Add requires to renaming: */
imods = parse_requires(e, self_modidx, env->genv->exp_env,
et_rn, post_ex_et_rn, check_require_name, et_tables, 1, 0,
redef_modname, 0, 0,
redef_modname, 0, 0, 1,
&et_all_simple_renames);
/* Add required modules to et_requires list: */
@ -4182,7 +4182,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
/* Add requires to renaming: */
imods = parse_requires(e, self_modidx, env->genv->template_env,
tt_rn, post_ex_tt_rn, check_require_name, tt_tables, 0, 0,
redef_modname, 0, 0,
redef_modname, 0, 0, 1,
&tt_all_simple_renames);
/* Add required modules to tt_requires list: */
@ -5171,6 +5171,7 @@ void add_single_require(Scheme_Module_Exports *me, /* from module */
Scheme_Object *ename, /* NULL or symbol for a single import */
Scheme_Object *mark_src, /* default mark_src; if onlys, each is also mark_src */
int unpack_kern, int copy_vars, int for_unmarshal,
int can_save_marshal,
int *all_simple,
Check_Func ck, /* NULL or called for each addition */
void *data, Scheme_Object *form, Scheme_Object *cki /* ck args */
@ -5179,7 +5180,7 @@ void add_single_require(Scheme_Module_Exports *me, /* from module */
int j, var_count;
Scheme_Object *orig_idx = idx;
Scheme_Object **exs, **exsns, **exss;
int is_kern, has_context, save_marshal_info = 0, can_save_marshal = 1;
int is_kern, has_context, save_marshal_info = 0;
Scheme_Object *nominal_modidx, *one_exn, *prnt_iname, *name;
if (mark_src) {
@ -5405,7 +5406,7 @@ void scheme_do_module_rename_unmarshal(Scheme_Object *rn, Scheme_Object *info,
rn, NULL,
exns, NULL, prefix, NULL, NULL,
NULL,
0, 0, 1,
0, 0, 1, 0,
NULL,
NULL,
NULL, NULL, NULL);
@ -5417,7 +5418,7 @@ Scheme_Object *parse_requires(Scheme_Object *form,
Scheme_Object *rn, Scheme_Object *post_ex_rn,
Check_Func ck, void *data,
int start, int expstart, Scheme_Object *redef_modname,
int unpack_kern, int copy_vars,
int unpack_kern, int copy_vars, int can_save_marshal,
int *all_simple)
{
Scheme_Object *ll = form;
@ -5641,7 +5642,7 @@ Scheme_Object *parse_requires(Scheme_Object *form,
add_single_require(m->me, idx, env, rn, post_ex_rn,
exns, onlys, prefix, iname, ename,
mark_src,
unpack_kern, copy_vars && start, 0,
unpack_kern, copy_vars && start, 0, can_save_marshal,
all_simple,
ck, data, form, i);
@ -5720,7 +5721,7 @@ top_level_require_execute(Scheme_Object *data)
(void)parse_requires(form, modidx, env, rn, rn,
check_dup_require, ht, (for_phase > -1), (for_phase == 0), NULL,
!env->module, 0, NULL);
!env->module, 0, 0, NULL);
brn = env->rename;
if (!brn) {
@ -5796,7 +5797,7 @@ static Scheme_Object *do_require(Scheme_Object *form, Scheme_Comp_Env *env,
(void)parse_requires(form, modidx, genv, rn, rn,
check_dup_require, ht, 0, 0,
NULL, 0, 0, NULL);
NULL, 0, 0, 0, NULL);
if (rec[drec].comp) {
/* Dummy lets us access a top-level environment: */

63
src/mzscheme/src/read.c
View File

@ -262,6 +262,9 @@ typedef struct {
#define STACK_END(r) (local_list_stack_pos = r.pos, local_list_stack = r.stack)
#ifdef MZ_PRECISE_GC
/* Although list stacks should work with precise GC as implemented
below, there's much less to be gained with a generational GC, so
we keep it simple. */
# define USE_LISTSTACK(x) 0
#else
# define USE_LISTSTACK(x) x
@ -528,16 +531,35 @@ void scheme_init_read(Scheme_Env *env)
env);
}
static Scheme_Simple_Object *malloc_list_stack()
{
#ifdef MZ_PRECISE_GC
long sz = sizeof(Scheme_Simple_Object) * NUM_CELLS_PER_STACK;
Scheme_Simple_Object *r;
if (sz < GC_malloc_stays_put_threshold()) {
sz = GC_malloc_stays_put_threshold();
while (sz % sizeof(Scheme_Simple_Object)) {
sz++;
}
}
r = (Scheme_Simple_Object *)GC_malloc_array_tagged(sz);
/* Must set the tag on the first element: */
r[0].iso.so.type = scheme_pair_type;
return r;
#else
return MALLOC_N_RT(Scheme_Simple_Object, NUM_CELLS_PER_STACK);
#endif
}
void scheme_alloc_list_stack(Scheme_Thread *p)
{
Scheme_Simple_Object *sa;
p->list_stack_pos = 0;
sa = MALLOC_N_RT(Scheme_Simple_Object, NUM_CELLS_PER_STACK);
sa = malloc_list_stack();
p->list_stack = sa;
#ifdef MZ_PRECISE_GC
/* Must set the tag on the first element: */
p->list_stack[0].iso.so.type = scheme_pair_type;
#endif
}
void scheme_clean_list_stack(Scheme_Thread *p)
@ -545,6 +567,12 @@ void scheme_clean_list_stack(Scheme_Thread *p)
if (p->list_stack) {
memset(p->list_stack + p->list_stack_pos, 0,
(NUM_CELLS_PER_STACK - p->list_stack_pos) * sizeof(Scheme_Simple_Object));
#ifdef MZ_PRECISE_GC
if (!p->list_stack_pos) {
/* Must set the tag on the first element: */
p->list_stack[0].iso.so.type = scheme_pair_type;
}
#endif
}
}
@ -2176,7 +2204,7 @@ read_list(Scheme_Object *port,
if (local_list_stack_pos >= NUM_CELLS_PER_STACK) {
/* Overflow */
Scheme_Simple_Object *sa;
sa = MALLOC_N_RT(Scheme_Simple_Object, NUM_CELLS_PER_STACK);
sa = malloc_list_stack();
local_list_stack = sa;
local_list_stack_pos = 0;
}
@ -3700,20 +3728,25 @@ void scheme_ill_formed(struct CPort *port
);
}
static long read_compact_number(CPort *port)
/* Since read_compact_number is called often, we want it to be
a cheap call in 3m, so avoid anything that allocated --- even
error reporting, since we can make up a valid number. */
#define NUM_ZO_CHECK(x) if (!(x)) return 0;
XFORM_NONGCING static long read_compact_number(CPort *port)
{
/* >>> See also read_compact_number_from_port(), below. <<< */
long flag, v, a, b, c, d;
ZO_CHECK(port->pos < port->size);
NUM_ZO_CHECK(port->pos < port->size);
flag = CP_GETC(port);
if (flag < 252)
return flag;
else if (flag == 252) {
ZO_CHECK(port->pos + 1 < port->size);
NUM_ZO_CHECK(port->pos + 1 < port->size);
a = CP_GETC(port);
b = CP_GETC(port);
@ -3722,12 +3755,12 @@ static long read_compact_number(CPort *port)
+ (b << 8);
return v;
} else if (flag == 254) {
ZO_CHECK(port->pos < port->size);
NUM_ZO_CHECK(port->pos < port->size);
return -CP_GETC(port);
}
ZO_CHECK(port->pos + 3 < port->size);
NUM_ZO_CHECK(port->pos + 3 < port->size);
a = CP_GETC(port);
b = CP_GETC(port);
@ -4354,7 +4387,7 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
if (local_list_stack_pos >= NUM_CELLS_PER_STACK) {
/* Overflow */
Scheme_Simple_Object *sa;
sa = MALLOC_N_RT(Scheme_Simple_Object, NUM_CELLS_PER_STACK);
sa = malloc_list_stack();
local_list_stack = sa;
local_list_stack_pos = 0;
}
@ -4393,7 +4426,7 @@ static Scheme_Object *read_compact_list(int c, int proper, int use_stack, CPort
if (local_list_stack_pos >= NUM_CELLS_PER_STACK) {
/* Overflow */
Scheme_Simple_Object *sa;
sa = MALLOC_N_RT(Scheme_Simple_Object, NUM_CELLS_PER_STACK);
sa = malloc_list_stack();
local_list_stack = sa;
local_list_stack_pos = 0;
}
@ -4414,7 +4447,7 @@ static Scheme_Object *read_compact_list(int c, int proper, int use_stack, CPort
if (local_list_stack_pos >= NUM_CELLS_PER_STACK) {
/* Overflow */
Scheme_Simple_Object *sa;
sa = MALLOC_N_RT(Scheme_Simple_Object, NUM_CELLS_PER_STACK);
sa = malloc_list_stack();
local_list_stack = sa;
local_list_stack_pos = 0;
}
@ -4494,7 +4527,7 @@ static Scheme_Object *read_marshalled(int type, CPort *port)
static long read_compact_number_from_port(Scheme_Object *port)
{
/* >>> See also read_compact_number_port(), above. <<< */
/* >>> See also read_compact_number(), above. <<< */
long flag, v, a, b, c, d;

4
src/mzscheme/src/schemef.h
View File

@ -915,7 +915,7 @@ MZ_EXTERN Scheme_Object *scheme_make_location(Scheme_Object *src,
MZ_EXTERN int scheme_is_location(Scheme_Object *o);
MZ_EXTERN Scheme_Object *scheme_make_inspector(Scheme_Object *superior);
MZ_EXTERN int scheme_is_subinspector(Scheme_Object *i, Scheme_Object *sup);
XFORM_NONGCING MZ_EXTERN int scheme_is_subinspector(Scheme_Object *i, Scheme_Object *sup);
/*========================================================================*/
/* utilities */
@ -926,7 +926,7 @@ MZ_EXTERN int scheme_eqv(Scheme_Object *obj1, Scheme_Object *obj2);
MZ_EXTERN int scheme_equal(Scheme_Object *obj1, Scheme_Object *obj2);
#ifdef MZ_PRECISE_GC
MZ_EXTERN long scheme_hash_key(Scheme_Object *o);
XFORM_NONGCING MZ_EXTERN long scheme_hash_key(Scheme_Object *o);
#endif
MZ_EXTERN long scheme_equal_hash_key(Scheme_Object *o);
MZ_EXTERN long scheme_equal_hash_key2(Scheme_Object *o);

4
src/mzscheme/src/schpriv.h
View File

@ -29,7 +29,7 @@
#define _MALLOC_N(x, n, malloc) ((x*)malloc(sizeof(x)*(n)))
#define MALLOC_ONE(x) _MALLOC_N(x, 1, scheme_malloc)
#define MALLOC_ONE_TAGGED(x) _MALLOC_N(x, 1, scheme_malloc_tagged)
#define MALLOC_ONE_TAGGED(x) _MALLOC_N(x, 1, scheme_malloc_small_tagged)
#define MALLOC_N_TAGGED(x, n) _MALLOC_N(x, n, scheme_malloc_array_tagged)
#ifdef MZTAG_REQUIRED
# define scheme_malloc_rt(x) scheme_malloc_tagged(x)
@ -1107,7 +1107,7 @@ typedef struct {
# define SCHEME_BIGPOS(b) (MZ_OPT_HASH_KEY(&((Scheme_Bignum *)b)->iso) & 0x1)
# define SCHEME_SET_BIGPOS(b, v) MZ_OPT_HASH_KEY(&((Scheme_Bignum *)b)->iso) = ((v) | SCHEME_BIGINLINE(b))
# define SCHEME_BIGINLINE(b) (MZ_OPT_HASH_KEY(&((Scheme_Bignum *)b)->iso) & 0x2)
# define SCHEME_SET_BIGINLINE(b, v) MZ_OPT_HASH_KEY(&((Scheme_Bignum *)b)->iso) = (((v) << 1) | SCHEME_BIGPOS(b))
# define SCHEME_SET_BIGINLINE(b) MZ_OPT_HASH_KEY(&((Scheme_Bignum *)b)->iso) |= (0x2 | SCHEME_BIGPOS(b))
#else
# define SCHEME_BIGPOS(b) MZ_OPT_HASH_KEY(&((Scheme_Bignum *)b)->iso)
# define SCHEME_SET_BIGPOS(b, v) SCHEME_BIGPOS(b) = v

4
src/mzscheme/src/schvers.h
View File

@ -9,6 +9,6 @@
#define MZSCHEME_VERSION_MAJOR 350
#define MZSCHEME_VERSION_MINOR 2
#define MZSCHEME_VERSION_MINOR 3
#define MZSCHEME_VERSION "350.2" _MZ_SPECIAL_TAG
#define MZSCHEME_VERSION "350.3" _MZ_SPECIAL_TAG

2
src/mzscheme/src/setjmpup.c
View File

@ -329,7 +329,7 @@ void scheme_copy_stack(Scheme_Jumpup_Buf *b, void *base, void *start GC_VAR_STAC
static void uncopy_stack(int ok, Scheme_Jumpup_Buf *b, long *prev)
{
Scheme_Jumpup_Buf *c;
GC_CAN_IGNORE Scheme_Jumpup_Buf *c;
long top_delta = 0, bottom_delta = 0, size;
void *cfrom, *cto;

44
src/mzscheme/src/startup.inc
View File

@ -468,7 +468,8 @@
"(if(null? l) null(cons-immutable(car l)(list->immutable-list(cdr l))))))"
"(define-values(get-stx-info)"
"(lambda(orig-stx super-id defined-names gen-expr?)"
"(let((qs(if gen-expr?(lambda(x)(and x `((syntax-local-certifier)(quote-syntax ,x)))) values))"
"(let((cert-id(and gen-expr?(gensym))))"
"(let((qs(if gen-expr?(lambda(x)(and x `(,cert-id(quote-syntax ,x)))) values))"
"(every-other(lambda(l)"
"(let loop((l l)(r null))"
"(cond"
@ -502,7 +503,11 @@
"(map qs(struct-info-mutator-ids super-info)))"
"(values null null)))"
"((fields)(cdddr defined-names))"
"((wrap)(if gen-expr?(lambda(x)(cons 'list-immutable x)) values)))"
"((wrap)(if gen-expr?(lambda(x)(cons 'list-immutable x)) values))"
"((total-wrap)(if gen-expr?"
"(lambda(x) `(let((,cert-id(syntax-local-certifier))) ,x))"
" values)))"
"(total-wrap"
"(wrap"
"(list-immutable(qs(car defined-names))"
"(qs(cadr defined-names))"
@ -519,8 +524,8 @@
" initial-sets)))"
"(if super-id"
"(qs super-id)"
" #t))))"
" #f)))))"
" #t)))))"
" #f))))))"
"(provide get-stx-info))"
);
EVAL_ONE_STR(
@ -957,7 +962,7 @@
"(let loop((r r))"
"(cond"
"((syntax? r)"
"(let((l(hash-table-get ht(syntax-e r)(lambda() null))))"
"(let((l(hash-table-get ht(syntax-e r) null)))"
"(when(ormap(lambda(i)(bound-identifier=? i r)) l)"
"(raise-syntax-error "
"(syntax-e who)"
@ -1176,7 +1181,7 @@
"(if proto-r"
" #f"
"(lambda(r)"
"(let((l(hash-table-get ht(syntax-e r)(lambda() null))))"
"(let((l(hash-table-get ht(syntax-e r) null)))"
"(unless(and(pair? l)"
"(ormap(lambda(i)(bound-identifier=? i r)) l))"
"(hash-table-put! ht(syntax-e r)(cons r l)))))))))"
@ -1785,7 +1790,7 @@
"(unless(identifier? defined-name)"
"(raise-type-error 'check-duplicate-identifier"
" \"list of identifiers\" names))"
"(let((l(hash-table-get ht(syntax-e defined-name)(lambda() null))))"
"(let((l(hash-table-get ht(syntax-e defined-name) null)))"
"(when(ormap(lambda(i)(bound-identifier=? i defined-name)) l)"
"(escape defined-name))"
"(hash-table-put! ht(syntax-e defined-name)(cons defined-name l))))"
@ -2871,15 +2876,14 @@
"((s) "
"(when planet-resolver"
"(planet-resolver s))"
"(let((ht(hash-table-get"
" -module-hash-table-table"
"(let((ht(or(hash-table-get -module-hash-table-table"
"(namespace-module-registry(current-namespace))"
"(lambda()"
" #f)"
"(let((ht(make-hash-table)))"
"(hash-table-put! -module-hash-table-table"
"(namespace-module-registry(current-namespace))"
" ht)"
" ht)))))"
" ht))))"
"(hash-table-put! ht s 'attach)))"
"((s relto stx)(standard-module-name-resolver s relto stx #t))"
"((s relto stx load?)"
@ -2909,7 +2913,7 @@
"(cond"
"((string? s)"
"(let*((dir(get-dir)))"
"(or(hash-table-get -path-cache(cons s dir)(lambda() #f))"
"(or(hash-table-get -path-cache(cons s dir) #f)"
"(let((s(string->bytes/utf-8 s)))"
"(if(regexp-match-positions -re:ok-relpath s)"
"(let loop((path dir)(s s))"
@ -2935,10 +2939,9 @@
"(not(list? s)))"
" #f)"
"((eq?(car s) 'lib)"
"(hash-table-get"
" -path-cache"
"(or(hash-table-get -path-cache"
"(cons s(current-library-collection-paths))"
"(lambda()"
" #f)"
"(let((cols(let((len(length s)))"
"(if(= len 2)"
" (list \"mzlib\")"
@ -2951,7 +2954,7 @@
"(string?(cadr s))"
"(relative-path?(cadr s))"
"(let((p(-find-col 'standard-module-name-resolver(car cols)(cdr cols))))"
"(build-path p(cadr s))))))))"
"(build-path p(cadr s)))))))"
"((eq?(car s) 'file)"
"(and(=(length s) 2)"
"(let((p(cadr s)))"
@ -2999,17 +3002,16 @@
"(vector-ref s-parsed 6)"
"(let((m(regexp-match -re:suffix(path->bytes name))))"
"(if m(car m) #t))))"
"(ht(hash-table-get"
" -module-hash-table-table"
"(ht(or(hash-table-get -module-hash-table-table"
"(namespace-module-registry(current-namespace))"
"(lambda()"
" #f)"
"(let((ht(make-hash-table)))"
"(hash-table-put! -module-hash-table-table"
"(namespace-module-registry(current-namespace))"
" ht)"
" ht)))))"
" ht))))"
"(when load?"
"(let((got(hash-table-get ht modname(lambda() #f))))"
"(let((got(hash-table-get ht modname #f)))"
"(when got"
"(unless(or(symbol? got)(equal? suffix got))"
"(error"

188
src/mzscheme/src/startup.ss
View File

@ -575,60 +575,65 @@
;; if `defined-names' is #f.
;; If `expr?' is #t, then generate an expression to build the info,
;; otherwise build the info directly.
(let ([qs (if gen-expr? (lambda (x) (and x `((syntax-local-certifier) (quote-syntax ,x)))) values)]
[every-other (lambda (l)
(let loop ([l l][r null])
(cond
[(null? l) r]
[(null? (cdr l)) (cons (car l) r)]
[else (loop (cddr l) (cons (car l) r))])))]
[super-info (and super-id
(syntax-local-value super-id (lambda () #f)))])
(if super-id
;; Did we get valid super-info ?
(if (or (not (struct-info? super-info))
(not (struct-info-type-id super-info)))
(raise-syntax-error
#f
(if (struct-info? super-info)
"parent struct information does not include a type for subtyping"
(format "parent struct type not defined~a"
(let ([cert-id (and gen-expr? (gensym))])
(let ([qs (if gen-expr? (lambda (x) (and x `(,cert-id (quote-syntax ,x)))) values)]
[every-other (lambda (l)
(let loop ([l l][r null])
(cond
[(null? l) r]
[(null? (cdr l)) (cons (car l) r)]
[else (loop (cddr l) (cons (car l) r))])))]
[super-info (and super-id
(syntax-local-value super-id (lambda () #f)))])
(if super-id
;; Did we get valid super-info ?
(if (or (not (struct-info? super-info))
(not (struct-info-type-id super-info)))
(raise-syntax-error
#f
(if (struct-info? super-info)
"parent struct information does not include a type for subtyping"
(format "parent struct type not defined~a"
(if super-info
(format " (~a does not name struct type information)"
(syntax-e super-id))
"")))
orig-stx
super-id)))
(values
(if super-info
(struct-info-type-id super-info)
#f)
(if defined-names
(let-values ([(initial-gets initial-sets)
(if super-info
(format " (~a does not name struct type information)"
(syntax-e super-id))
"")))
orig-stx
super-id)))
(values
(if super-info
(struct-info-type-id super-info)
#f)
(if defined-names
(let-values ([(initial-gets initial-sets)
(if super-info
(values (map qs (struct-info-accessor-ids super-info))
(map qs (struct-info-mutator-ids super-info)))
(values null null))]
[(fields) (cdddr defined-names)]
[(wrap) (if gen-expr? (lambda (x) (cons 'list-immutable x)) values)])
(wrap
(list-immutable (qs (car defined-names))
(qs (cadr defined-names))
(qs (caddr defined-names))
(wrap
(list->immutable-list
(append (map qs (every-other fields))
initial-gets)))
(wrap
(list->immutable-list
(append (map qs (if (null? fields)
null
(every-other (cdr fields))))
initial-sets)))
(if super-id
(qs super-id)
#t))))
#f)))))
(values (map qs (struct-info-accessor-ids super-info))
(map qs (struct-info-mutator-ids super-info)))
(values null null))]
[(fields) (cdddr defined-names)]
[(wrap) (if gen-expr? (lambda (x) (cons 'list-immutable x)) values)]
[(total-wrap) (if gen-expr?
(lambda (x) `(let ([,cert-id (syntax-local-certifier)]) ,x))
values)])
(total-wrap
(wrap
(list-immutable (qs (car defined-names))
(qs (cadr defined-names))
(qs (caddr defined-names))
(wrap
(list->immutable-list
(append (map qs (every-other fields))
initial-gets)))
(wrap
(list->immutable-list
(append (map qs (if (null? fields)
null
(every-other (cdr fields))))
initial-sets)))
(if super-id
(qs super-id)
#t)))))
#f))))))
(provide get-stx-info))
@ -1144,7 +1149,7 @@
(let loop ([r r])
(cond
[(syntax? r)
(let ([l (hash-table-get ht (syntax-e r) (lambda () null))])
(let ([l (hash-table-get ht (syntax-e r) null)])
(when (ormap (lambda (i) (bound-identifier=? i r)) l)
(raise-syntax-error
(syntax-e who)
@ -1399,7 +1404,7 @@
(if proto-r
#f
(lambda (r)
(let ([l (hash-table-get ht (syntax-e r) (lambda () null))])
(let ([l (hash-table-get ht (syntax-e r) null)])
(unless (and (pair? l)
(ormap (lambda (i) (bound-identifier=? i r)) l))
(hash-table-put! ht (syntax-e r) (cons r l)))))))])
@ -2110,7 +2115,7 @@
(unless (identifier? defined-name)
(raise-type-error 'check-duplicate-identifier
"list of identifiers" names))
(let ([l (hash-table-get ht (syntax-e defined-name) (lambda () null))])
(let ([l (hash-table-get ht (syntax-e defined-name) null)])
(when (ormap (lambda (i) (bound-identifier=? i defined-name)) l)
(escape defined-name))
(hash-table-put! ht (syntax-e defined-name) (cons defined-name l))))
@ -3309,15 +3314,14 @@
(when planet-resolver
;; Let planet resolver register, too:
(planet-resolver s))
(let ([ht (hash-table-get
-module-hash-table-table
(namespace-module-registry (current-namespace))
(lambda ()
(let ([ht (make-hash-table)])
(hash-table-put! -module-hash-table-table
(namespace-module-registry (current-namespace))
ht)
ht)))])
(let ([ht (or (hash-table-get -module-hash-table-table
(namespace-module-registry (current-namespace))
#f)
(let ([ht (make-hash-table)])
(hash-table-put! -module-hash-table-table
(namespace-module-registry (current-namespace))
ht)
ht))])
(hash-table-put! ht s 'attach))]
[(s relto stx) (standard-module-name-resolver s relto stx #t)]
[(s relto stx load?)
@ -3350,7 +3354,7 @@
(cond
[(string? s)
(let* ([dir (get-dir)])
(or (hash-table-get -path-cache (cons s dir) (lambda () #f))
(or (hash-table-get -path-cache (cons s dir) #f)
(let ([s (string->bytes/utf-8 s)])
(if (regexp-match-positions -re:ok-relpath s)
;; Parse Unix-style relative path string
@ -3377,23 +3381,22 @@
(not (list? s)))
#f]
[(eq? (car s) 'lib)
(hash-table-get
-path-cache
(cons s (current-library-collection-paths))
(lambda ()
(let ([cols (let ([len (length s)])
(if (= len 2)
(list "mzlib")
(if (> len 2)
(cddr s)
#f)))])
(and cols
(andmap (lambda (x) (and (string? x)
(relative-path? x))) cols)
(string? (cadr s))
(relative-path? (cadr s))
(let ([p (-find-col 'standard-module-name-resolver (car cols) (cdr cols))])
(build-path p (cadr s)))))))]
(or (hash-table-get -path-cache
(cons s (current-library-collection-paths))
#f)
(let ([cols (let ([len (length s)])
(if (= len 2)
(list "mzlib")
(if (> len 2)
(cddr s)
#f)))])
(and cols
(andmap (lambda (x) (and (string? x)
(relative-path? x))) cols)
(string? (cadr s))
(relative-path? (cadr s))
(let ([p (-find-col 'standard-module-name-resolver (car cols) (cdr cols))])
(build-path p (cadr s))))))]
[(eq? (car s) 'file)
(and (= (length s) 2)
(let ([p (cadr s)])
@ -3442,18 +3445,17 @@
(vector-ref s-parsed 6)
(let ([m (regexp-match -re:suffix (path->bytes name))])
(if m (car m) #t)))]
[ht (hash-table-get
-module-hash-table-table
(namespace-module-registry (current-namespace))
(lambda ()
(let ([ht (make-hash-table)])
(hash-table-put! -module-hash-table-table
(namespace-module-registry (current-namespace))
ht)
ht)))])
[ht (or (hash-table-get -module-hash-table-table
(namespace-module-registry (current-namespace))
#f)
(let ([ht (make-hash-table)])
(hash-table-put! -module-hash-table-table
(namespace-module-registry (current-namespace))
ht)
ht))])
;; Loaded already?
(when load?
(let ([got (hash-table-get ht modname (lambda () #f))])
(let ([got (hash-table-get ht modname #f)])
(when got
;; Check the suffix, which gets lost when creating a key:
(unless (or (symbol? got) (equal? suffix got))

4
src/mzscheme/src/stxobj.c
View File

@ -2457,8 +2457,8 @@ Scheme_Object *scheme_stx_activate_certs(Scheme_Object *o)
/* stx comparison */
/*========================================================================*/
static int same_marks(WRAP_POS *_awl, WRAP_POS *_bwl, int ignore_barrier,
Scheme_Object *barrier_env, Scheme_Object *ignore_rib)
XFORM_NONGCING static int same_marks(WRAP_POS *_awl, WRAP_POS *_bwl, int ignore_barrier,
Scheme_Object *barrier_env, Scheme_Object *ignore_rib)
/* Compares the marks in two wraps lists. A result of 2 means that the
result depended on a mark barrier or barrier env. Use #f for barrier_env
to treat no rib envs as barriers; we check for barrier_env only in ribs

6
src/mzscheme/src/thread.c
View File

@ -131,6 +131,8 @@ extern void scheme_gmp_tls_snapshot(long *s, long *save);
extern void scheme_gmp_tls_restore_snapshot(long *s, long *save, int do_free);
extern int scheme_num_read_syntax_objects;
extern int scheme_hash_request_count;
extern int scheme_hash_iteration_count;
/*========================================================================*/
/* local variables and prototypes */
@ -6781,6 +6783,10 @@ static Scheme_Object *current_stats(int argc, Scheme_Object *argv[])
switch (SCHEME_VEC_SIZE(v)) {
default:
case 10:
SCHEME_VEC_ELS(v)[9] = scheme_make_integer(scheme_hash_iteration_count);
case 9:
SCHEME_VEC_ELS(v)[8] = scheme_make_integer(scheme_hash_request_count);
case 8:
SCHEME_VEC_ELS(v)[7] = scheme_make_integer(scheme_num_read_syntax_objects);
case 7:

15
src/mzscheme/sgc/splay.c → src/mzscheme/utils/splay.c
View File

@ -1,3 +1,14 @@
/*
Provides OR requires:
Tree (with left and right Tree fields)
Splay_Item
Set_Splay_Item
Provides, can can be renamed via macros (to support
multiplue uses of the file):
splay
splay_insert
splay_delete
*/
/*
An implementation of top-down splaying
D. Sleator <sleator@cs.cmu.edu>
@ -121,6 +132,8 @@ static Tree * splay_insert(unsigned long i, Tree * new, Tree * t) {
}
}
#ifndef OMIT_SPLAY_DELETE
static Tree * splay_delete(unsigned long i, Tree * t) {
/* Deletes i from the tree if it's there. */
/* Return a pointer to the resulting tree. */
@ -138,3 +151,5 @@ static Tree * splay_delete(unsigned long i, Tree * t) {
}
return t; /* It wasn't there */
}
#endif

7
src/wxmac/include/base/common.h
View File

@ -11,6 +11,13 @@
#ifndef wxb_commonh
#define wxb_commonh
/* We don't want all those "deprecated" messages: */
#ifndef WX_KEEP_DEPRECATED_WARNINGS
# include <AvailabilityMacros.h>
# undef DEPRECATED_ATTRIBUTE
# define DEPRECATED_ATTRIBUTE /**/
#endif
#ifdef OS_X
# include <Carbon/Carbon.h>
#else

4
src/wxmac/src/mac/wx_print.cc
View File

@ -8,14 +8,14 @@
* Copyright: (c) 1995, AIAI, University of Edinburgh
*/
#include "common.h"
#ifdef OS_X
# include <ApplicationServices/ApplicationServices.h>
#else
# include <ApplicationServices.h>
#endif
#include "common.h"
#if USE_PRINTING_ARCHITECTURE
#if USE_COMMON_DIALOGS