diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index a66bf5d99a..97cb733bc9 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -391,4 +391,4 @@ (post-dummy-event) ; why do we need this? 'nextEventMatchingMask:' seems to hang if we don't use it (set-ffi-obj! 'scheme_sleep #f _pointer (function-ptr sleep-until-event (_fun #:atomic? #t - _float _pointer -> _void)))) + _float _gcpointer -> _void)))) diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index 010211efa7..e89ef6fb11 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -66,7 +66,7 @@ (define-mz scheme_add_evt (_fun _Scheme_Type (_fun #:atomic? #t _scheme -> _int) - (_fun #:atomic? #t _scheme _pointer -> _void) + (_fun #:atomic? #t _scheme _gcpointer -> _void) _pointer _int -> _void)) @@ -189,7 +189,7 @@ _racket _racket -> _void) _racket ; data _int ; strong? - -> _pointer)) + -> _gcpointer)) (define (shutdown-eventspace! e ignored) ;; atomic mode diff --git a/collects/mred/private/wx/gtk/queue.rkt b/collects/mred/private/wx/gtk/queue.rkt index 110e8932d6..766176e7d1 100644 --- a/collects/mred/private/wx/gtk/queue.rkt +++ b/collects/mred/private/wx/gtk/queue.rkt @@ -118,10 +118,10 @@ (define POLLERR #x8) (define POLLHUP #x10) -(define-mz scheme_get_fdset (_fun _pointer _int -> _pointer)) -(define-mz scheme_fdset (_fun _pointer _int -> _void)) -(define-mz scheme_set_wakeup_time (_fun _pointer _double -> _void)) -(define-mz scheme_add_fd_eventmask (_fun _pointer _int -> _void) +(define-mz scheme_get_fdset (_fun _pointer _int -> _gcpointer)) +(define-mz scheme_fdset (_fun _gcpointer _int -> _void)) +(define-mz scheme_set_wakeup_time (_fun _gcpointer _double -> _void)) +(define-mz scheme_add_fd_eventmask (_fun _gcpointer _int -> _void) #:fail #f) (define (install-wakeup fds) diff --git a/src/racket/gc2/gc2.h b/src/racket/gc2/gc2.h index 03f91a3c8a..ccf513479f 100644 --- a/src/racket/gc2/gc2.h +++ b/src/racket/gc2/gc2.h @@ -262,6 +262,12 @@ GC2_EXTERN intptr_t GC_malloc_stays_put_threshold(); objects that never move, and where pointers are allowed into the object's interior. */ +GC2_EXTERN int GC_is_on_allocated_page(void *p); +/* + Returns 1 if p refers to a page of memory on which + the GC allocates objects (although p may or may not + be a valid pointer to the start of an alloctaed object). */ + /***************************************************************************/ /* Memory tracing */ /***************************************************************************/ diff --git a/src/racket/gc2/newgc.c b/src/racket/gc2/newgc.c index 1086f85f71..4697cb8aa0 100644 --- a/src/racket/gc2/newgc.c +++ b/src/racket/gc2/newgc.c @@ -2962,6 +2962,13 @@ void GC_fixup(void *pp) GC_fixup2(pp, GC_get_GC()); } +int GC_is_on_allocated_page(void *p) +{ + NewGC *gc = GC_get_GC(); + return !!pagemap_find_page(gc->page_maps, p); +} + + /*****************************************************************************/ /* memory stats and traces */ /*****************************************************************************/ diff --git a/src/racket/src/port.c b/src/racket/src/port.c index daf83aeef3..c8dc1573d3 100644 --- a/src/racket/src/port.c +++ b/src/racket/src/port.c @@ -730,7 +730,7 @@ void *scheme_alloc_fdset_array(int count, int permanent) if (permanent) return scheme_malloc_eternal(count * (dynamic_fd_size + sizeof(intptr_t))); else - return scheme_malloc_atomic(count * (dynamic_fd_size + sizeof(intptr_t))); + return scheme_malloc_atomic_allow_interior(count * (dynamic_fd_size + sizeof(intptr_t))); } void *scheme_init_fdset_array(void *fdarray, int count) diff --git a/src/racket/src/salloc.c b/src/racket/src/salloc.c index 6a216914a2..b8a3707ddd 100644 --- a/src/racket/src/salloc.c +++ b/src/racket/src/salloc.c @@ -529,6 +529,18 @@ Scheme_Object *scheme_make_external_cptr(GC_CAN_IGNORE void *cptr, Scheme_Object o = scheme_make_cptr(NULL, typetag); SCHEME_CPTR_FLAGS(o) |= 0x1; SCHEME_CPTR_VAL(o) = cptr; + +#if 0 + /* For debugging. An external pointer onto a GCable page is + not necessarily a bug (e.g. it might be a Win32 handle that + happens to look like a pointer to a GCable page) --- but it + probably is, so it's worth a look when it happens. */ +# ifdef MZ_PRECISE_GC + if (GC_is_on_allocated_page(cptr)) + printf("%p is on collectable page\n", cptr); +# endif +#endif + return o; }