350.3
svn: r3571
This commit is contained in:
Matthew Flatt
parent
a4f230d00a
commit
ebe051694d
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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,8 +42,8 @@
|
|||
(lambda (s)
|
||||
(cond
|
||||
[(symbol? s)
|
||||
(let ([v (hash-table-get table s
|
||||
(lambda ()
|
||||
(let ([v (hash-table-get table s no-val)])
|
||||
(when (eq? v no-val)
|
||||
(raise
|
||||
(make-exn:fail:unit
|
||||
(string->immutable-string
|
||||
|
|
@ -51,7 +53,7 @@
|
|||
src-context
|
||||
(sig-path-name s path)
|
||||
dest-context))
|
||||
(current-continuation-marks)))))])
|
||||
(current-continuation-marks))))
|
||||
(and v
|
||||
(begin
|
||||
(unless (symbol? v)
|
||||
|
|
@ -70,8 +72,8 @@
|
|||
(hash-table-put! table s #f)
|
||||
#t)))]
|
||||
[(and (pair? s) (symbol? (car s)))
|
||||
(let ([v (hash-table-get table (car s)
|
||||
(lambda ()
|
||||
(let ([v (hash-table-get table (car s) no-val)])
|
||||
(when (eq? v no-val)
|
||||
(raise
|
||||
(make-exn:fail:unit
|
||||
(string->immutable-string
|
||||
|
|
@ -81,7 +83,7 @@
|
|||
src-context
|
||||
(sig-path-name (car s) path)
|
||||
dest-context))
|
||||
(current-continuation-marks)))))])
|
||||
(current-continuation-marks))))
|
||||
(and v
|
||||
(begin
|
||||
(unless (hash-table? v)
|
||||
|
|
|
|||
|
|
@ -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)))]))])
|
||||
|
|
|
|||
|
|
@ -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)]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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@
|
||||
|
|
|
|||
|
|
@ -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@
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -43,6 +43,8 @@ static void collapse_adjacent_pages(void)
|
|||
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,6 +62,7 @@ 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;
|
||||
if (!blockfree[i].zeroed)
|
||||
memset(r, 0, len);
|
||||
LOGICALLY_ALLOCATING_PAGES(len);
|
||||
return r;
|
||||
|
|
@ -75,6 +78,7 @@ 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;
|
||||
if (!blockfree[i].zeroed)
|
||||
memset(r, 0, len);
|
||||
LOGICALLY_ALLOCATING_PAGES(len);
|
||||
return r;
|
||||
|
|
@ -84,6 +88,7 @@ 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;
|
||||
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;
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
}
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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 */
|
||||
|
|
|
|||
|
|
@ -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,6 +2759,7 @@ static void garbage_collect(int force_full)
|
|||
do_btc_accounting();
|
||||
if (generations_available)
|
||||
protect_old_pages();
|
||||
if (gc_full)
|
||||
flush_freed_pages();
|
||||
reset_finalizer_tree();
|
||||
|
||||
|
|
|
|||
145
src/mzscheme/gc2/page_range.c
Normal file
145
src/mzscheme/gc2/page_range.c
Normal 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
34
src/mzscheme/gc2/protect_range.c
Normal 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);
|
||||
}
|
||||
}
|
||||
|
|
@ -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 (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;
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -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,6 +131,12 @@ static void *malloc_pages(size_t len, size_t alignment)
|
|||
}
|
||||
}
|
||||
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 {
|
||||
retval = vm_deallocate(task_self, (vm_address_t)real_r + len,
|
||||
extra - pre_extra);
|
||||
if(retval != KERN_SUCCESS) {
|
||||
|
|
@ -137,6 +144,7 @@ static void *malloc_pages(size_t len, size_t alignment)
|
|||
mach_error_string(retval));
|
||||
}
|
||||
}
|
||||
}
|
||||
r = real_r;
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -28,16 +28,37 @@
|
|||
#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)
|
||||
#else
|
||||
# ifdef DOS_MEMORY
|
||||
# include <dos.h>
|
||||
# define PTR_TO_LONG(p) ((FP_SEG(p) << 4) + FP_OFF(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
|
||||
# define PTR_TO_LONG(p) ((long)(p))
|
||||
#endif
|
||||
#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;
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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]);
|
||||
|
|
|
|||
|
|
@ -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: */
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -575,7 +575,8 @@
|
|||
;; 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)]
|
||||
(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
|
||||
|
|
@ -610,7 +611,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))
|
||||
|
|
@ -627,8 +632,8 @@
|
|||
initial-sets)))
|
||||
(if super-id
|
||||
(qs super-id)
|
||||
#t))))
|
||||
#f)))))
|
||||
#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
|
||||
(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?)
|
||||
|
|
@ -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,10 +3381,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")
|
||||
|
|
@ -3393,7 +3396,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)])
|
||||
|
|
@ -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
|
||||
[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))])
|
||||
;; 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))
|
||||
|
|
|
|||
|
|
@ -2457,7 +2457,7 @@ Scheme_Object *scheme_stx_activate_certs(Scheme_Object *o)
|
|||
/* stx comparison */
|
||||
/*========================================================================*/
|
||||
|
||||
static int same_marks(WRAP_POS *_awl, WRAP_POS *_bwl, int ignore_barrier,
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user