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

fix some mzc -e problems

Browse Source 
svn: r9379
This commit is contained in:
Matthew Flatt 2008-04-21 01:04:31 +00:00
parent 476c374751
commit 63c8b7ffde
8 changed files with 65 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
collects/compiler/private/driver.ss
View File

@ -1171,8 +1171,7 @@
#f #f ; no module entries
c-port)])
(fprintf c-port
"Scheme_Object * scheme_reload~a(Scheme_Env * env)~n{~n"
compiler:setup-suffix)
"static Scheme_Object * do_scheme_reload(Scheme_Env * env)~n{~n")
(fprintf c-port"~aScheme_Per_Load_Statics *PLS;~n"
vm->c:indent-spaces)
(fprintf c-port
@ -1188,9 +1187,17 @@
(fprintf c-port
"}~n~n")
(fprintf c-port
"~nvoid scheme_setup~a(Scheme_Env * env)~n{~n"
"Scheme_Object * scheme_reload~a(Scheme_Env * env)~n{~n"
compiler:setup-suffix)
(fprintf c-port"~areturn do_scheme_reload(env);~n"
vm->c:indent-spaces)
(fprintf c-port
"}~n~n")
(fprintf c-port
"~nstatic void do_scheme_setup(Scheme_Env * env)~n{~n")
(fprintf c-port
"~ascheme_set_tail_buffer_size(~a);~n"
vm->c:indent-spaces
@ -1218,14 +1225,23 @@
(fprintf c-port
"}~n~n")
(fprintf c-port
"~nvoid scheme_setup~a(Scheme_Env * env)~n{~n"
compiler:setup-suffix)
(fprintf c-port
"~ado_scheme_setup(env);~n"
vm->c:indent-spaces)
(fprintf c-port
"}~n~n")
(when (string=? "" compiler:setup-suffix)
(fprintf c-port
"~nScheme_Object * scheme_initialize(Scheme_Env * env)~n{~n")
(fprintf c-port "~ascheme_setup~a(env);~n"
(fprintf c-port "~ado_scheme_setup~a(env);~n"
vm->c:indent-spaces
compiler:setup-suffix)
(fprintf c-port "~areturn scheme_reload~a(env);~n"
(fprintf c-port "~areturn do_scheme_reload~a(env);~n"
vm->c:indent-spaces
compiler:setup-suffix)
(fprintf c-port

44
collects/compiler/to-core.ss
View File

@ -1,4 +1,4 @@
(module to-core mzscheme
(module to-core scheme/base
(require syntax/kerncase
syntax/stx
mzlib/list
@ -45,25 +45,25 @@
[else (list stx)]))
l)))
(define-struct lifted-info (counter id-map slot-map))
(define-struct lifted-info ([counter #:mutable] id-map slot-map))
(define (make-vars)
(make-lifted-info
0
(make-module-identifier-mapping)
(make-hash-table 'equal)))
(make-hash)))
(define (is-id-ref? v)
(or (identifier? v)
(and (stx-pair? v)
(identifier? (stx-car v))
(module-identifier=? #'#%top (stx-car v)))))
(free-identifier=? #'#%top (stx-car v)))))
(define (vars-sequence li)
(let loop ([i 0])
(if (= i (lifted-info-counter li))
null
(cons (let ([v (hash-table-get (lifted-info-slot-map li) i)])
(cons (let ([v (hash-ref (lifted-info-slot-map li) i)])
(if (is-id-ref? v)
#`(#%variable-reference #,v)
v))
@ -73,7 +73,7 @@
(let loop ([i 0])
(if (= i (lifted-info-counter li))
null
(let ([v (hash-table-get (lifted-info-slot-map li) i)])
(let ([v (hash-ref (lifted-info-slot-map li) i)])
(if (is-id-ref? v)
(cons #`(#,extract-stx #,vec-id #,i)
(loop (add1 i)))
@ -81,16 +81,16 @@
(define (is-run-time? stx)
(not (and (stx-pair? stx)
(or (module-identifier=? #'define-syntaxes (stx-car stx))
(module-identifier=? #'define-values-for-syntax (stx-car stx))))))
(or (free-identifier=? #'define-syntaxes (stx-car stx))
(free-identifier=? #'define-values-for-syntax (stx-car stx))))))
(define (has-symbol? decl magic-sym table)
(cond
[(hash-table-get table decl (lambda () #f))
[(hash-ref table decl (lambda () #f))
;; cycle/graph
#f]
[else
(hash-table-put! table decl #t)
(hash-set! table decl #t)
(cond
[(eq? magic-sym decl)
#t]
@ -108,21 +108,21 @@
(let ([magic-sym (string->symbol (format "magic~a~a"
(current-seconds)
(current-milliseconds)))])
(if (has-symbol? (map syntax-object->datum decls) magic-sym (make-hash-table))
(if (has-symbol? (map syntax->datum decls) magic-sym (make-hasheq))
(generate-magic decls)
magic-sym)))
(define (need-thunk? rhs)
(not (and (stx-pair? rhs)
(or (module-identifier=? #'lambda (stx-car rhs))
(module-identifier=? #'case-lambda (stx-car rhs))))))
(or (free-identifier=? #'lambda (stx-car rhs))
(free-identifier=? #'case-lambda (stx-car rhs))))))
(define (lift-sequence decls lookup-stx set-stx safe-vector-ref-stx extract-stx
in-module? simple-constant? stop-properties)
(let ([ct-vars (make-vars)]
[rt-vars (make-vars)]
[compile-time (datum->syntax-object #f (gensym 'compile-time))]
[run-time (datum->syntax-object #f (gensym 'run-time))]
[compile-time (datum->syntax #f (gensym 'compile-time))]
[run-time (datum->syntax #f (gensym 'run-time))]
[magic-sym (generate-magic decls)]
[magic-indirect (gensym)])
(let ([ct-converted
@ -136,7 +136,7 @@
in-module?
simple-constant? stop-properties)])
(if (and (not in-module?)
(module-identifier=? #'def #'define-syntaxes))
(free-identifier=? #'def #'define-syntaxes))
;; Don't try to name macro procedures, because it
;; inteferes with the 0-values hack at the top level
cvted
@ -284,12 +284,12 @@
[(and (pair? b)
(eq? '#%kernel (car b)))
;; Generate a syntax object that has the right run-time binding:
(datum->syntax-object #'here (cadr b) stx stx)]
(datum->syntax #'here (cadr b) stx stx)]
[else #f])))
(define (add-literal/pos stx li)
(let ([pos (lifted-info-counter li)])
(hash-table-put! (lifted-info-slot-map li) pos stx)
(hash-set! (lifted-info-slot-map li) pos stx)
(set-lifted-info-counter! li (add1 pos))
pos))
@ -322,10 +322,10 @@
[(_ stx e) (let ([old-s stx]
[new-s (quasisyntax e)])
(syntax-recertify
(datum->syntax-object new-s
(syntax-e new-s)
old-s
old-s)
(datum->syntax new-s
(syntax-e new-s)
old-s
old-s)
new-s
code-insp
#f))]))

8
collects/scribblings/inside/memory.scrbl
View File

@ -85,7 +85,7 @@ times).
With conservative collection, no registration is needed for the global
or static variables of an embedding program, unless it calls
@cpp{scheme_setup} or @cppi{scheme_set_stack_base} with a non-zero
@cpp{scheme_main_setup} or @cppi{scheme_set_stack_base} with a non-zero
first or second (respectively) argument. In that case, global and
static variables containing collectable pointers must be registered
with @cppi{scheme_register_static}. The @cppi{MZ_REGISTER_STATIC}
@ -686,7 +686,7 @@ Registers an extension's global variable that can contain Scheme
occur during the registration.}
@function[(int scheme_setup
@function[(int scheme_main_setup
[int no_auto_statics]
[Scheme_Main main]
[int argc]
@ -704,7 +704,7 @@ typedef int (*Scheme_Main)(Scheme_Env *env,
int argc, char **argv);
}
The result of @var{main} is the result of @cpp{scheme_setup}.
The result of @var{main} is the result of @cpp{scheme_main_setup}.
If @var{no_auto_statics} is non-zero, then static variables must be
explicitly registered with the garbage collector; see
@ -739,7 +739,7 @@ must be the beginning or end of a local-frame registration. Worse, in
CGC or 3m, if @cpp{real_main} is declared @cpp{static}, the compiler
may inline it and place variables containing collectable values deeper
in the stack than @cpp{dummy}. To avoid these problems, use
@cpp{scheme_setup}, instead.}
@cpp{scheme_main_setup}, instead.}
@function[(void scheme_set_stack_bounds
[void* stack_addr]

8
collects/scribblings/inside/namespaces.scrbl
View File

@ -11,10 +11,10 @@ and syntax.
The @cpp{scheme_basic_env} function must be called once by an
embedding program, before any other PLT Scheme function is called
(except @cpp{scheme_make_param}), but @cpp{scheme_setup} automatically
calls @cpp{scheme_basic_env}. The returned namespace is the initial
current namespace for the main Scheme thread. Scheme extensions cannot
call @cpp{scheme_basic_env}.
(except @cpp{scheme_make_param}), but @cpp{scheme_main_setup}
automatically calls @cpp{scheme_basic_env}. The returned namespace is
the initial current namespace for the main Scheme thread. Scheme
extensions cannot call @cpp{scheme_basic_env}.
The current thread's current namespace is available from
@cppi{scheme_get_env}, given the current parameterization (see

20
collects/scribblings/inside/overview.scrbl
View File

@ -296,13 +296,13 @@ To embed PLT Scheme CGC in a program, follow these steps:
installing from source also places this file in the installation's
@filepath{include} directory.}
@item{Start your main program through the @cpp{scheme_setup}
@item{Start your main program through the @cpp{scheme_main_setup}
trampoline, and put all uses of MzScheme functions inside the
function passed to @cpp{scheme_setup}. The @cpp{scheme_setup}
function passed to @cpp{scheme_main_setup}. The @cpp{scheme_main_setup}
function registers the current C stack location with the memory
manager. It also creates the initial namespace @cpp{Scheme_Env*} by
calling @cppi{scheme_basic_env} and passing the result to the
function provided to @cpp{scheme_setup}.}
function provided to @cpp{scheme_main_setup}.}
@item{Configure the namespace by adding module declarations. The
initial namespace contains declarations only for a few primitive
@ -390,13 +390,13 @@ static int run(Scheme_Env *e, int argc, char *argv[])
int main(int argc, char *argv[])
{
return scheme_setup(1, run, argc, argv);
return scheme_main_setup(1, run, argc, argv);
}
}
Under Mac OS X, or under Windows when MzScheme is compiled to a DLL
using Cygwin, the garbage collector cannot find static variables
automatically. In that case, @cppi{scheme_setup} must be called with a
automatically. In that case, @cppi{scheme_main_setup} must be called with a
non-zero first argument.
Under Windows (for any other build mode), the garbage collector finds
@ -404,9 +404,9 @@ static variables in an embedding program by examining all memory
pages. This strategy fails if a program contains multiple Windows
threads; a page may get unmapped by a thread while the collector is
examining the page, causing the collector to crash. To avoid this
problem, call @cpp{scheme_setup} with a non-zero first argument.
problem, call @cpp{scheme_main_setup} with a non-zero first argument.
When an embedding application calls @cpp{scheme_setup} with a non-zero
When an embedding application calls @cpp{scheme_main_setup} with a non-zero
first argument, it must register each of its static variables with
@cppi{MZ_REGISTER_STATIC} if the variable can contain a GCable
pointer. For example, if @cpp{curout} above is made @cpp{static}, then
@ -414,7 +414,7 @@ pointer. For example, if @cpp{curout} above is made @cpp{static}, then
@cpp{scheme_get_param}.
When building an embedded MzSchemeCGC to use SenoraGC (SGC) instead of
the default collector, @cpp{scheme_setup} must be called with a
the default collector, @cpp{scheme_main_setup} must be called with a
non-zero first argument. See @secref["im:memoryalloc"] for more
information.
@ -454,7 +454,7 @@ In addition, some library details are different:
}
For MzScheme3m, an embedding application must call @cpp{scheme_setup}
For MzScheme3m, an embedding application must call @cpp{scheme_main_setup}
with a non-zero first argument.
The simple embedding program from the previous section can be
@ -520,7 +520,7 @@ static int run(Scheme_Env *e, int argc, char *argv[])
int main(int argc, char *argv[])
{
return scheme_setup(1, run, argc, argv);
return scheme_main_setup(1, run, argc, argv);
}
}

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

@ -1696,7 +1696,7 @@ MZ_EXTERN void scheme_set_stack_bounds(void *base, void *deepest, int no_auto_st
/* More automatic start-up: */
typedef int (*Scheme_Main)(Scheme_Env *env, int argc, char **argv);
MZ_EXTERN int scheme_setup(int no_auto_statics, Scheme_Main _main, int argc, char **argv);
MZ_EXTERN int scheme_main_setup(int no_auto_statics, Scheme_Main _main, int argc, char **argv);
MZ_EXTERN void scheme_register_static(void *ptr, long size);

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

@ -266,14 +266,14 @@ static Scheme_Object *do_load_extension(const char *filename,
"load-extension: bad version %s (not %s) from \"%s\"",
vers, VERSION_AND_VARIANT, filename);
}
init_f = (Init_Procedure)dlsym(dl, SO_SYMBOL_PREFIX "scheme_initialize");
if (init_f) {
reload_f = (Reload_Procedure)dlsym(dl, SO_SYMBOL_PREFIX "scheme_reload");
if (reload_f)
modname_f = (Modname_Procedure)dlsym(dl, SO_SYMBOL_PREFIX "scheme_module_name");
}
if (!init_f || !reload_f || !modname_f) {
const char *err;
err = dlerror();

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

@ -88,7 +88,7 @@ void scheme_set_stack_base(void *base, int no_auto_statics)
use_registered_statics = no_auto_statics;
}
int scheme_setup(int no_auto_statics, Scheme_Main _main, int argc, char **argv)
int scheme_main_setup(int no_auto_statics, Scheme_Main _main, int argc, char **argv)
{
void *start_addr = &start_addr;