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

[Places] fall back to threads

Browse Source
This commit is contained in:
Kevin Tew 2011-02-28 12:36:21 -07:00
parent 13d371fa5e
commit eaebcf5fd6
11 changed files with 1132 additions and 964 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/racket/main.rkt
View File

@ -20,6 +20,7 @@
racket/function
racket/path
racket/file
racket/place
racket/port
racket/cmdline
racket/promise
@ -49,6 +50,7 @@
racket/function
racket/path
racket/file
racket/place
racket/port
racket/cmdline
racket/promise

113
collects/racket/place.rkt
View File

@ -1,10 +1,14 @@
#lang scheme/base
(require '#%place)
(require '#%futures)
(define (place-channel-send/recv ch msg)
(place-channel-send ch msg)
(place-channel-recv ch))
#lang racket/base
(require (prefix-in pl- '#%place)
'#%boot
(only-in '#%paramz parameterization-key make-custodian-from-main)
(only-in '#%futures processor-count)
'#%place-struct
racket/fixnum
racket/flonum
racket/vector
(only-in unstable/struct struct->list)
(for-syntax racket/base))
(provide place
place-sleep
@ -15,4 +19,97 @@
place-channel?
place?
place-channel-send/recv
processor-count)
processor-count
(rename-out [pl-place-enabled? place-enabled?]))
(define-struct TH-place (th ch) #:property prop:evt (lambda (x) (TH-place-channel-out (TH-place-ch x))))
(define (place-channel-send/recv ch msg)
(place-channel-send ch msg)
(place-channel-recv ch))
(define (make-th-async-channel)
(define ch (make-channel))
(values
(thread
(lambda ()
(let loop ()
(channel-put ch (thread-receive))
(loop))))
ch))
(define (th-place mod funcname)
(define-values (pch cch) (th-place-channel))
(define th (thread (lambda ()
(with-continuation-mark
parameterization-key
orig-paramz
(parameterize ([current-namespace (make-base-namespace)]
[current-custodian (make-custodian-from-main)])
((dynamic-require mod funcname) cch))))))
(TH-place th pch))
(define (th-place-sleep n) (sleep n))
(define (th-place-wait pl) (thread-wait (TH-place-th pl)))
(define (th-place-channel)
(define-values (as ar) (make-th-async-channel))
(define-values (bs br) (make-th-async-channel))
(define pch (TH-place-channel ar bs))
(define cch (TH-place-channel br as))
(values pch cch))
(define (deep-copy x)
(define (dcw o)
(cond
[(ormap (lambda (x) (x o)) (list number? char? boolean? null? void? string? symbol? TH-place-channel?)) o]
[(cond
[(path? o) (path->bytes o)]
[(bytes? o) (if (pl-place-shared? o) o (bytes-copy o))]
[(fxvector? o) (if (pl-place-shared? o) o (fxvector-copy o))]
[(flvector? o) (if (pl-place-shared? o) o (flvector-copy o))]
[else #f])
=> values]
[(TH-place? o) (dcw (TH-place-ch o))]
[(pair? o) (cons (dcw (car o)) (dcw (cdr o)))]
[(vector? o) (vector-map! dcw (vector-copy o))]
[(struct? o)
(define key (prefab-struct-key o))
(when (not key)
(error "Must be a prefab struct"))
(apply make-prefab-struct key (map dcw (struct->list o)))]
[else (error "Error not place serializable ~a" o)]))
(dcw x))
(define (th-place-channel-send pl msg)
(define th
(cond
[(TH-place? pl) (TH-place-channel-out (TH-place-ch pl))]
[(TH-place-channel? pl) (TH-place-channel-out pl)]
[else (raise-type-error 'place-channel-send "expect a place? or place-channel?" pl)]))
(sync (thread-resume-evt th))
(thread-send th
(deep-copy msg)))
(define (th-place-channel-recv pl)
(channel-get
(cond
[(TH-place? pl) (TH-place-channel-in (TH-place-ch pl))]
[(TH-place-channel? pl) (TH-place-channel-in pl)]
[else (raise-type-error 'place-channel-recv "expect a place? or place-channel?" pl)])))
(define (th-place-channel? pl)
(or (TH-place? pl)
(TH-place-channel? pl)))
(define-syntax-rule (define-pl x p t) (define x (if (pl-place-enabled?) p t)))
(define-pl place pl-place th-place)
(define-pl place-sleep pl-place-sleep th-place-sleep)
(define-pl place-wait pl-place-wait th-place-wait)
(define-pl place-channel pl-place-channel th-place-channel)
(define-pl place-channel-send pl-place-channel-send th-place-channel-send)
(define-pl place-channel-recv pl-place-channel-recv th-place-channel-recv)
(define-pl place-channel? pl-place-channel? th-place-channel?)
(define-pl place? pl-place? TH-place?)

2
src/racket/include/scheme.h
View File

@ -308,11 +308,9 @@ typedef struct Scheme_Vector {
Scheme_Object *els[1];
} Scheme_Vector;
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
# define SHARED_ALLOCATED 0x2
# define SHARED_ALLOCATEDP(so) (MZ_OPT_HASH_KEY((Scheme_Inclhash_Object *)(so)) & SHARED_ALLOCATED)
# define SHARED_ALLOCATED_SET(so) (MZ_OPT_HASH_KEY((Scheme_Inclhash_Object *)(so)) |= SHARED_ALLOCATED)
#endif
typedef struct Scheme_Double_Vector {
Scheme_Inclhash_Object iso; /* & 0x2 indicates allocated in the MASTERGC */

1790
src/racket/src/cstartup.inc
View File

File diff suppressed because it is too large Load Diff

38
src/racket/src/number.c
View File

@ -100,19 +100,15 @@ static Scheme_Object *flvector (int argc, Scheme_Object *argv[]);
static Scheme_Object *flvector_p (int argc, Scheme_Object *argv[]);
static Scheme_Object *flvector_length (int argc, Scheme_Object *argv[]);
static Scheme_Object *make_flvector (int argc, Scheme_Object *argv[]);
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
static Scheme_Object *shared_flvector (int argc, Scheme_Object *argv[]);
static Scheme_Object *make_shared_flvector (int argc, Scheme_Object *argv[]);
#endif
static Scheme_Object *fxvector (int argc, Scheme_Object *argv[]);
static Scheme_Object *fxvector_p (int argc, Scheme_Object *argv[]);
static Scheme_Object *fxvector_length (int argc, Scheme_Object *argv[]);
static Scheme_Object *make_fxvector (int argc, Scheme_Object *argv[]);
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
static Scheme_Object *shared_fxvector (int argc, Scheme_Object *argv[]);
static Scheme_Object *make_shared_fxvector (int argc, Scheme_Object *argv[]);
#endif
static Scheme_Object *integer_to_fl (int argc, Scheme_Object *argv[]);
static Scheme_Object *fl_to_integer (int argc, Scheme_Object *argv[]);
@ -604,13 +600,8 @@ void scheme_init_flfxnum_number(Scheme_Env *env)
1, 2),
env);
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
GLOBAL_PRIM_W_ARITY("shared-flvector", shared_flvector, 0, -1, env);
GLOBAL_PRIM_W_ARITY("make-shared-flvector", make_shared_flvector, 1, 2, env);
#else
GLOBAL_PRIM_W_ARITY("shared-flvector", flvector, 0, -1, env);
GLOBAL_PRIM_W_ARITY("make-shared-flvector", make_flvector, 1, 2, env);
#endif
p = scheme_make_immed_prim(flvector_length, "flvector-length", 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
@ -647,13 +638,8 @@ void scheme_init_flfxnum_number(Scheme_Env *env)
1, 2),
env);
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
GLOBAL_PRIM_W_ARITY("shared-fxvector", shared_fxvector, 0, -1, env);
GLOBAL_PRIM_W_ARITY("make-shared-fxvector", make_shared_fxvector, 1, 2, env);
#else
GLOBAL_PRIM_W_ARITY("shared-fxvector", fxvector, 0, -1, env);
GLOBAL_PRIM_W_ARITY("make-shared-fxvector", make_fxvector, 1, 2, env);
#endif
p = scheme_make_immed_prim(fxvector_length, "fxvector-length", 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
@ -3347,20 +3333,22 @@ Scheme_Double_Vector *scheme_alloc_flvector(intptr_t size)
return vec;
}
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
static Scheme_Double_Vector *alloc_shared_flvector(intptr_t size)
{
Scheme_Double_Vector *vec;
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
void *original_gc;
original_gc = GC_switch_to_master_gc();
#endif
vec = scheme_alloc_flvector(size);
SHARED_ALLOCATED_SET(vec);
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
GC_switch_back_from_master(original_gc);
#endif
return vec;
}
#endif
static Scheme_Object *do_flvector (const char *name, Scheme_Double_Vector *vec, int argc, Scheme_Object *argv[])
{
@ -3382,12 +3370,10 @@ static Scheme_Object *flvector (int argc, Scheme_Object *argv[])
return do_flvector("flvector", scheme_alloc_flvector(argc), argc, argv);
}
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
static Scheme_Object *shared_flvector (int argc, Scheme_Object *argv[])
{
return do_flvector("shared-flvector", alloc_shared_flvector(argc), argc, argv);
}
#endif
static Scheme_Object *flvector_p (int argc, Scheme_Object *argv[])
{
@ -3423,11 +3409,9 @@ static Scheme_Object *do_make_flvector (const char *name, int as_shared, int arg
scheme_wrong_type(name, "flonum", 1, argc, argv);
}
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
if (as_shared)
vec = alloc_shared_flvector(size);
else
#endif
vec = scheme_alloc_flvector(size);
if (argc > 1)
@ -3446,12 +3430,10 @@ static Scheme_Object *make_flvector (int argc, Scheme_Object *argv[])
return do_make_flvector("make-flvector", 0, argc, argv);
}
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
static Scheme_Object *make_shared_flvector (int argc, Scheme_Object *argv[])
{
return do_make_flvector("make-shared-flvector", 1, argc, argv);
}
#endif
Scheme_Object *scheme_flvector_length(Scheme_Object *vec)
{
@ -3535,20 +3517,22 @@ Scheme_Vector *scheme_alloc_fxvector(intptr_t size)
return vec;
}
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
static Scheme_Vector *alloc_shared_fxvector(intptr_t size)
{
Scheme_Vector *vec;
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
void *original_gc;
original_gc = GC_switch_to_master_gc();
#endif
vec = scheme_alloc_fxvector(size);
SHARED_ALLOCATED_SET(vec);
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
GC_switch_back_from_master(original_gc);
#endif
return vec;
}
#endif
static Scheme_Object *do_fxvector (const char *name, Scheme_Vector *vec, int argc, Scheme_Object *argv[])
{
@ -3570,12 +3554,10 @@ static Scheme_Object *fxvector (int argc, Scheme_Object *argv[])
return do_fxvector("fxvector", scheme_alloc_fxvector(argc), argc, argv);
}
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
static Scheme_Object *shared_fxvector (int argc, Scheme_Object *argv[])
{
return do_fxvector("shared-fxvector", alloc_shared_fxvector(argc), argc, argv);
}
#endif
static Scheme_Object *fxvector_p (int argc, Scheme_Object *argv[])
{
@ -3609,11 +3591,9 @@ static Scheme_Object *do_make_fxvector (const char *name, int as_shared, int arg
scheme_wrong_type(name, "fixnum", 1, argc, argv);
}
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
if (as_shared)
vec = alloc_shared_fxvector(size);
else
#endif
vec = scheme_alloc_fxvector(size);
{
@ -3632,12 +3612,10 @@ static Scheme_Object *make_fxvector (int argc, Scheme_Object *argv[])
return do_make_fxvector("make-fxvector", 0, argc, argv);
}
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
static Scheme_Object *make_shared_fxvector (int argc, Scheme_Object *argv[])
{
return do_make_fxvector("make-shared-fxvector", 1, argc, argv);
}
#endif
Scheme_Object *scheme_fxvector_length(Scheme_Object *vec)
{

38
src/racket/src/places.c
View File

@ -1,6 +1,7 @@
#include "schpriv.h"
/* READ ONLY SHARABLE GLOBALS */
static Scheme_Object* scheme_place_enabled(int argc, Scheme_Object *args[]);
static Scheme_Object* scheme_place_shared(int argc, Scheme_Object *args[]);
#ifdef MZ_USE_PLACES
@ -10,6 +11,7 @@
#endif
READ_ONLY static Scheme_Object *scheme_def_place_exit_proc;
SHARED_OK static int scheme_places_enabled = 1;
SHARED_OK mz_proc_thread *scheme_master_proc_thread;
THREAD_LOCAL_DECL(mz_proc_thread *proc_thread_self);
@ -27,12 +29,8 @@ static Scheme_Place_Async_Channel *scheme_place_async_channel_create();
static Scheme_Place_Bi_Channel *scheme_place_bi_channel_create();
static Scheme_Place_Bi_Channel *scheme_place_bi_peer_channel_create(Scheme_Place_Bi_Channel *orig);
static int scheme_place_channel_ready(Scheme_Object *so, Scheme_Schedule_Info *sinfo);
static void scheme_place_async_send(Scheme_Place_Async_Channel *ch, Scheme_Object *o);
static Scheme_Object *scheme_place_async_recv(Scheme_Place_Async_Channel *ch);
static Scheme_Object *scheme_places_deep_copy_to_master(Scheme_Object *so);
/* Scheme_Object *scheme_places_deep_copy(Scheme_Object *so); */
@ -51,6 +49,8 @@ static void *place_start_proc_after_stack(void *data_arg, void *stack_base);
#else
SHARED_OK static int scheme_places_enabled = 0;
# define PLACE_PRIM_W_ARITY(name, func, a1, a2, env) GLOBAL_PRIM_W_ARITY(name, not_implemented, a1, a2, env)
static Scheme_Object *not_implemented(int argc, Scheme_Object **argv)
@ -78,14 +78,16 @@ void scheme_init_place(Scheme_Env *env)
plenv = scheme_primitive_module(scheme_intern_symbol("#%place"), env);
PLACE_PRIM_W_ARITY("place", scheme_place, 2, 2, plenv);
PLACE_PRIM_W_ARITY("place-sleep", scheme_place_sleep, 1, 1, plenv);
PLACE_PRIM_W_ARITY("place-wait", scheme_place_wait, 1, 1, plenv);
PLACE_PRIM_W_ARITY("place?", scheme_place_p, 1, 1, plenv);
PLACE_PRIM_W_ARITY("place-channel", scheme_place_channel, 0, 0, plenv);
PLACE_PRIM_W_ARITY("place-channel-send", scheme_place_send, 1, 2, plenv);
PLACE_PRIM_W_ARITY("place-channel-recv", scheme_place_recv, 1, 1, plenv);
PLACE_PRIM_W_ARITY("place-channel?", scheme_place_channel_p, 1, 1, plenv);
GLOBAL_PRIM_W_ARITY("place-enabled?", scheme_place_enabled, 0, 0, plenv);
GLOBAL_PRIM_W_ARITY("place-shared?", scheme_place_shared, 1, 1, plenv);
PLACE_PRIM_W_ARITY("place", scheme_place, 2, 2, plenv);
PLACE_PRIM_W_ARITY("place-sleep", scheme_place_sleep, 1, 1, plenv);
PLACE_PRIM_W_ARITY("place-wait", scheme_place_wait, 1, 1, plenv);
PLACE_PRIM_W_ARITY("place?", scheme_place_p, 1, 1, plenv);
PLACE_PRIM_W_ARITY("place-channel", scheme_place_channel, 0, 0, plenv);
PLACE_PRIM_W_ARITY("place-channel-send", scheme_place_send, 1, 2, plenv);
PLACE_PRIM_W_ARITY("place-channel-recv", scheme_place_recv, 1, 1, plenv);
PLACE_PRIM_W_ARITY("place-channel?", scheme_place_channel_p, 1, 1, plenv);
#ifdef MZ_USE_PLACES
REGISTER_SO(scheme_def_place_exit_proc);
@ -95,6 +97,16 @@ void scheme_init_place(Scheme_Env *env)
}
static Scheme_Object* scheme_place_enabled(int argc, Scheme_Object *args[]) {
return (scheme_places_enabled == 0) ? scheme_false : scheme_true;
}
static Scheme_Object* scheme_place_shared(int argc, Scheme_Object *args[]) {
return SHARED_ALLOCATEDP(args[0]) ? scheme_true : scheme_false;
}
void scheme_init_places_once() {
#ifdef MZ_USE_PLACES
scheme_add_evt(scheme_place_type, (Scheme_Ready_Fun)scheme_place_channel_ready, NULL, NULL, 1);

40
src/racket/src/startup.inc
View File

@ -420,21 +420,25 @@
"(loop)))))))"
);
EVAL_ONE_STR(
"(module #%builtin '#%kernel"
"(#%require '#%expobs"
"(only '#%foreign) "
"(only '#%unsafe) "
"(only '#%flfxnum) "
" '#%paramz"
" '#%network"
" '#%utils"
"(only '#%place)"
"(only '#%futures)))"
"(module #%place-struct '#%kernel"
"(define-values(struct:TH-place-channel TH-place-channel TH-place-channel? "
" TH-place-channel-ref TH-place-channel-set!)"
"(make-struct-type 'TH-place-channel #f 2 0 #f(list(cons prop:evt(lambda(x)(TH-place-channel-ref x 0))))))"
"(define-values(TH-place-channel-in TH-place-channel-out) "
"(values"
"(lambda(x)(TH-place-channel-ref x 0))"
"(lambda(x)(TH-place-channel-ref x 1))))"
"(#%provide "
" struct:TH-place-channel"
" TH-place-channel "
" TH-place-channel? "
" TH-place-channel-in"
" TH-place-channel-out))"
);
EVAL_ONE_STR(
"(module #%boot '#%kernel"
"(#%require '#%min-stx '#%utils '#%paramz)"
"(#%provide boot seal)"
"(#%provide boot seal orig-paramz)"
"(define-values(dll-suffix)"
"(system-type 'so-suffix))"
"(define-values(default-load/use-compiled)"
@ -810,4 +814,18 @@
"(set! orig-paramz"
"(reparameterize "
"(continuation-mark-set-first #f parameterization-key))))))"
);
EVAL_ONE_STR(
"(module #%builtin '#%kernel"
"(#%require '#%expobs"
"(only '#%foreign) "
"(only '#%unsafe) "
"(only '#%flfxnum) "
" '#%boot"
" '#%place-struct"
" '#%paramz"
" '#%network"
" '#%utils"
"(only '#%place)"
"(only '#%futures)))"
);

49
src/racket/src/startup.rktl
View File

@ -493,21 +493,29 @@
(eval e)
(loop)))))))
;; ----------------------------------------
;; A module that collects all the built-in modules,
;; so that it's easier to keep them attached in new
;; namespaces.
(module #%builtin '#%kernel
(#%require '#%expobs
(only '#%foreign) ; so it's attached, but doesn't depend on any exports
(only '#%unsafe) ; ditto
(only '#%flfxnum) ; ditto
'#%paramz
'#%network
'#%utils
(only '#%place)
(only '#%futures)))
(module #%place-struct '#%kernel
(define-values (struct:TH-place-channel TH-place-channel TH-place-channel?
TH-place-channel-ref TH-place-channel-set!)
(make-struct-type 'TH-place-channel #f 2 0 #f (list (cons prop:evt (lambda (x) (TH-place-channel-ref x 0))))))
(define-values (TH-place-channel-in TH-place-channel-out)
(values
(lambda (x) (TH-place-channel-ref x 0))
(lambda (x) (TH-place-channel-ref x 1))))
(#%provide
struct:TH-place-channel
TH-place-channel
TH-place-channel?
TH-place-channel-in
TH-place-channel-out))
;; ----------------------------------------
;; Handlers to install on startup
@ -515,7 +523,7 @@
(module #%boot '#%kernel
(#%require '#%min-stx '#%utils '#%paramz)
(#%provide boot seal)
(#%provide boot seal orig-paramz)
(define-values (dll-suffix)
(system-type 'so-suffix))
@ -915,3 +923,22 @@
(set! orig-paramz
(reparameterize
(continuation-mark-set-first #f parameterization-key))))))
;; ----------------------------------------
;; A module that collects all the built-in modules,
;; so that it's easier to keep them attached in new
;; namespaces.
(module #%builtin '#%kernel
(#%require '#%expobs
(only '#%foreign) ; so it's attached, but doesn't depend on any exports
(only '#%unsafe) ; ditto
(only '#%flfxnum) ; ditto
'#%boot
'#%place-struct
'#%paramz
'#%network
'#%utils
(only '#%place)
(only '#%futures)))

7
src/racket/src/string.c
View File

@ -266,10 +266,8 @@ static Scheme_Object *string_normalize_kc (int argc, Scheme_Object *argv[]);
static Scheme_Object *string_normalize_d (int argc, Scheme_Object *argv[]);
static Scheme_Object *string_normalize_kd (int argc, Scheme_Object *argv[]);
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
static Scheme_Object *make_shared_byte_string (int argc, Scheme_Object *argv[]);
static Scheme_Object *shared_byte_string (int argc, Scheme_Object *argv[]);
#endif
static Scheme_Object *make_byte_string (int argc, Scheme_Object *argv[]);
static Scheme_Object *byte_string (int argc, Scheme_Object *argv[]);
@ -695,13 +693,8 @@ scheme_init_string (Scheme_Env *env)
0, -1),
env);
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
GLOBAL_PRIM_W_ARITY("make-shared-bytes", make_shared_byte_string, 1, 2, env);
GLOBAL_PRIM_W_ARITY("shared-bytes", shared_byte_string, 0, -1, env);
#else
GLOBAL_PRIM_W_ARITY("make-shared-bytes", make_byte_string, 1, 2, env);
GLOBAL_PRIM_W_ARITY("shared-bytes", byte_string, 0, -1, env);
#endif
scheme_add_global_constant("bytes-length",
scheme_make_folding_prim(byte_string_length,

10
src/racket/src/strops.inc
View File

@ -87,14 +87,16 @@ X(scheme_alloc, _string)(intptr_t size, Xchar fill)
return str;
}
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC) && defined(GENERATING_BYTE)
#if defined(GENERATING_BYTE)
Scheme_Object *
X(scheme_alloc_shared, _string)(intptr_t size, Xchar fill)
{
Scheme_Object *str;
Xchar *s;
intptr_t i;
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
void *original_gc;
#endif
if (size < 0) {
str = scheme_make_integer(size);
@ -102,7 +104,9 @@ X(scheme_alloc_shared, _string)(intptr_t size, Xchar fill)
-1, 0, &str);
}
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
original_gc = GC_switch_to_master_gc();
#endif
str = scheme_alloc_object();
str->type = scheme_x_string_type;
SHARED_ALLOCATED_SET(str);
@ -111,7 +115,9 @@ X(scheme_alloc_shared, _string)(intptr_t size, Xchar fill)
s = (Xchar *)scheme_malloc_atomic(sizeof(Xchar)*(size + 1));
else
s = (Xchar *)scheme_malloc_fail_ok(scheme_malloc_atomic, sizeof(Xchar)*(size + 1));
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
GC_switch_back_from_master(original_gc);
#endif
for (i = size; i--; ) {
s[i] = fill;
@ -176,7 +182,7 @@ X__(string) (int argc, Scheme_Object *argv[])
return str;
}
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC) && defined(GENERATING_BYTE)
#if defined(GENERATING_BYTE)
static Scheme_Object *
X_(make_shared, string) (int argc, Scheme_Object *argv[])
{

7
src/racket/src/thread.c
View File

@ -331,6 +331,7 @@ static Scheme_Object *evt_p(int argc, Scheme_Object *args[]);
static Scheme_Object *evts_to_evt(int argc, Scheme_Object *args[]);
static Scheme_Object *make_custodian(int argc, Scheme_Object *argv[]);
static Scheme_Object *make_custodian_from_main(int argc, Scheme_Object *argv[]);
static Scheme_Object *custodian_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *custodian_close_all(int argc, Scheme_Object *argv[]);
static Scheme_Object *custodian_to_list(int argc, Scheme_Object *argv[]);
@ -632,6 +633,7 @@ void scheme_init_paramz(Scheme_Env *env)
GLOBAL_PRIM_W_ARITY("extend-parameterization" , extend_parameterization , 1, -1, newenv);
GLOBAL_PRIM_W_ARITY("check-for-break" , check_break_now , 0, 0, newenv);
GLOBAL_PRIM_W_ARITY("reparameterize" , reparameterize , 1, 1, newenv);
GLOBAL_PRIM_W_ARITY("make-custodian-from-main", make_custodian_from_main, 0, 0, newenv);
scheme_finish_primitive_module(newenv);
scheme_protect_primitive_provide(newenv, NULL);
@ -1409,6 +1411,11 @@ static Scheme_Object *make_custodian(int argc, Scheme_Object *argv[])
return (Scheme_Object *)scheme_make_custodian(m);
}
static Scheme_Object *make_custodian_from_main(int argc, Scheme_Object *argv[])
{
return (Scheme_Object *)scheme_make_custodian(NULL);
}
static Scheme_Object *custodian_p(int argc, Scheme_Object *argv[])
{
return SCHEME_CUSTODIANP(argv[0]) ? scheme_true : scheme_false;