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

move definedness check for imported variable to link time instead of access time; add errortrace meta-language; tweak errortrace to avoid an unnecessary and loop-obscuring annotation; improve slightly bytecode optimizer's handling of w-c-m; improve JIT handling of w-c-m

Browse Source 
svn: r18678
This commit is contained in:
Matthew Flatt 2010-03-30 20:21:28 +00:00
parent cafd092994
commit 417be5d8e2
17 changed files with 842 additions and 463 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/errortrace/errortrace-lib.ss
View File

@ -8,6 +8,7 @@
scheme/contract
scheme/unit
scheme/runtime-path
(for-template scheme/base)
(for-syntax scheme/base))
(define oprintf

20
collects/errortrace/lang/body.ss Normal file
View File

@ -0,0 +1,20 @@
#lang scheme/base
(require (for-syntax scheme/base
syntax/strip-context
"../errortrace-lib.ss"))
(provide (rename-out [module-begin #%module-begin]))
(define-syntax (module-begin stx)
(syntax-case stx ()
[(_ lang . body)
(let ([e (annotate-top
(local-expand #`(module . #,(strip-context #`(n lang . body)))
'top-level
null)
0)])
(syntax-case e ()
[(mod nm lang (mb . body))
#'(#%plain-module-begin
(require (only-in lang) errortrace/errortrace-key)
. body)]))]))

30
collects/errortrace/lang/reader.ss Normal file
View File

@ -0,0 +1,30 @@
(module reader scheme/base
(require syntax/module-reader)
(provide (rename-out [et-read read]
[et-read-syntax read-syntax]
[et-get-info get-info]))
(define (wrap-reader p)
(lambda args
(let ([r (apply p args)])
;; Re-write module to use `errortrace':
(if (syntax? r)
(syntax-case r ()
[(mod name lang . body)
(quasisyntax/loc r
(mod name errortrace/lang/body (#,(datum->syntax #f '#%module-begin) lang . body)))])
`(,(car r) ,(cadr r) errortrace/lang/body (#%module-begin . ,(cddr r)))))))
(define-values (et-read et-read-syntax et-get-info)
(make-meta-reader
'errortrace
"language path"
(lambda (str)
(let ([s (string->symbol
(string-append (bytes->string/latin-1 str)
"/lang/reader"))])
(and (module-path? s) s)))
wrap-reader
wrap-reader
values)))

8
collects/errortrace/scribblings/errortrace.scrbl
View File

@ -99,6 +99,14 @@ top-level. The functions also can be accessed by importing
@schememodname[errortrace/errortrace-lib], which does not install any
handlers.
As a language name, @schememodname[errortrace] chains to another
language that is specified immediately after @schememodname[at-exp],
but instruments the module for debugging in the same way as if
@schememodname[errortrace] is required before loading the module from
source. Using the @schememodname[errortrace] meta-language is one way
to ensure that debugging instrumentation is present when the module is
compiled.}
@; ---------------------------------------------
@subsection[#:tag "instrumentation-and-profiling"]{Instrumentation and Profiling}

560
collects/errortrace/stacktrace.ss
View File

@ -2,6 +2,7 @@
(require scheme/unit
syntax/kerncase
syntax/stx
(for-template scheme/base)
(for-syntax scheme/base)) ; for matching
(provide stacktrace@ stacktrace^ stacktrace-imports^)
@ -154,54 +155,54 @@
(with-syntax ([expr sexpr]
[e se])
(kernel-syntax-case/phase sexpr phase
;; negligible time to eval
[id
(identifier? sexpr)
(syntax (begin e expr))]
[(quote _) (syntax (begin e expr))]
[(quote-syntax _) (syntax (begin e expr))]
[(#%top . d) (syntax (begin e expr))]
[(#%variable-reference . d) (syntax (begin e expr))]
;; No tail effect, and we want to account for the time
[(#%plain-lambda . _) (syntax (begin0 expr e))]
[(case-lambda . _) (syntax (begin0 expr e))]
[(set! . _) (syntax (begin0 expr e))]
[(let-values bindings . body)
(insert-at-tail* se sexpr phase)]
[(letrec-values bindings . body)
(insert-at-tail* se sexpr phase)]
[(begin . _)
(insert-at-tail* se sexpr phase)]
[(with-continuation-mark . _)
(insert-at-tail* se sexpr phase)]
[(begin0 body ...)
(certify sexpr (syntax (begin0 body ... e)))]
[(if test then else)
;; WARNING: se inserted twice!
(certify
sexpr
(rebuild
sexpr
(list
(cons #'then (insert-at-tail se (syntax then) phase))
(cons #'else (insert-at-tail se (syntax else) phase)))))]
[(#%plain-app . rest)
(if (stx-null? (syntax rest))
;; null constant
(syntax (begin e expr))
;; application; exploit guaranteed left-to-right evaluation
(insert-at-tail* se sexpr phase))]
[_else
(error 'errortrace
"unrecognized (non-top-level) expression form: ~e"
(syntax->datum sexpr))])))
;; negligible time to eval
[id
(identifier? sexpr)
(syntax (begin e expr))]
[(quote _) (syntax (begin e expr))]
[(quote-syntax _) (syntax (begin e expr))]
[(#%top . d) (syntax (begin e expr))]
[(#%variable-reference . d) (syntax (begin e expr))]
;; No tail effect, and we want to account for the time
[(#%plain-lambda . _) (syntax (begin0 expr e))]
[(case-lambda . _) (syntax (begin0 expr e))]
[(set! . _) (syntax (begin0 expr e))]
[(let-values bindings . body)
(insert-at-tail* se sexpr phase)]
[(letrec-values bindings . body)
(insert-at-tail* se sexpr phase)]
[(begin . _)
(insert-at-tail* se sexpr phase)]
[(with-continuation-mark . _)
(insert-at-tail* se sexpr phase)]
[(begin0 body ...)
(certify sexpr (syntax (begin0 body ... e)))]
[(if test then else)
;; WARNING: se inserted twice!
(certify
sexpr
(rebuild
sexpr
(list
(cons #'then (insert-at-tail se (syntax then) phase))
(cons #'else (insert-at-tail se (syntax else) phase)))))]
[(#%plain-app . rest)
(if (stx-null? (syntax rest))
;; null constant
(syntax (begin e expr))
;; application; exploit guaranteed left-to-right evaluation
(insert-at-tail* se sexpr phase))]
[_else
(error 'errortrace
"unrecognized (non-top-level) expression form: ~e"
(syntax->datum sexpr))])))
(define (profile-annotate-lambda name expr clause bodys-stx phase)
(let* ([bodys (stx->list bodys-stx)]
@ -329,234 +330,241 @@
(lambda (expr phase)
(test-coverage-point
(kernel-syntax-case/phase expr phase
[_
(identifier? expr)
(let ([b (identifier-binding expr phase)])
(cond
[(eq? 'lexical b)
;; lexical variable - no error possile
expr]
[(and (pair? b) (eq? '#%kernel (car b)))
;; built-in - no error possible
expr]
[else
;; might be undefined/uninitialized
(with-mark expr expr)]))]
[(#%top . id)
;; might be undefined/uninitialized
(with-mark expr expr)]
[(#%variable-reference . _)
;; no error possible
expr]
[(define-values names rhs)
top?
;; Can't put annotation on the outside
(let* ([marked
(with-mark expr
(annotate-named
(one-name #'names)
(syntax rhs)
phase))]
[with-coverage
(let loop ([stx #'names]
[obj marked])
(cond
[(not (syntax? stx)) obj]
[(identifier? stx)
(test-coverage-point obj stx phase)]
[(pair? (syntax-e stx))
(loop (car (syntax-e stx))
(loop (cdr (syntax-e stx))
obj))]
[else obj]))])
(certify
expr
(rebuild
expr
(list (cons #'rhs with-coverage)))))]
[(begin . exprs)
top?
(certify
expr
(annotate-seq expr
(syntax exprs)
annotate-top phase))]
[(define-syntaxes (name ...) rhs)
top?
(let ([marked (with-mark expr
(annotate-named
(one-name #'(name ...))
(syntax rhs)
(add1 phase)))])
(certify
expr
(rebuild expr (list (cons #'rhs marked)))))]
[(define-values-for-syntax (name ...) rhs)
top?
(let ([marked (with-mark expr
(annotate-named
(one-name (syntax (name ...)))
(syntax rhs)
(add1 phase)))])
(certify
expr
(rebuild expr (list (cons #'rhs marked)))))]
[(module name init-import (__plain-module-begin body ...))
;; Just wrap body expressions
(let ([bodys (syntax->list (syntax (body ...)))]
[mb (list-ref (syntax->list expr) 3)])
(let ([bodyl (map (lambda (b)
(annotate-top b 0))
bodys)])
(certify
expr
(rebuild
expr
(list (cons
mb
(certify
mb
(rebuild mb (map cons bodys bodyl)))))))))]
[(#%expression e)
top?
(certify expr #`(#%expression #,(annotate (syntax e) phase)))]
;; No way to wrap
[(#%require i ...) expr]
;; No error possible (and no way to wrap)
[(#%provide i ...) expr]
;; No error possible
[(quote _)
expr]
[(quote-syntax _)
expr]
;; Wrap body, also a profile point
[(#%plain-lambda args . body)
(certify
expr
(keep-lambda-properties
expr
(profile-annotate-lambda name expr expr (syntax body)
phase)))]
[(case-lambda clause ...)
(with-syntax ([([args . body] ...)
(syntax (clause ...))])
(let* ([clauses (syntax->list (syntax (clause ...)))]
[clausel (map
(lambda (body clause)
(profile-annotate-lambda
name expr clause body phase))
(syntax->list (syntax (body ...)))
clauses)])
(certify
expr
(keep-lambda-properties
expr
(rebuild expr (map cons clauses clausel))))))]
;; Wrap RHSs and body
[(let-values ([vars rhs] ...) . body)
(with-mark expr
(certify
expr
(annotate-let expr phase
(syntax (vars ...))
(syntax (rhs ...))
(syntax body))))]
[(letrec-values ([vars rhs] ...) . body)
(with-mark expr
(certify
expr
(annotate-let expr phase
(syntax (vars ...))
(syntax (rhs ...))
(syntax body))))]
;; Wrap RHS
[(set! var rhs)
(let ([new-rhs (annotate-named
(syntax var)
(syntax rhs)
phase)])
;; set! might fail on undefined variable, or too many values:
(with-mark expr
(certify
expr
(rebuild expr (list (cons #'rhs new-rhs))))))]
;; Wrap subexpressions only
[(begin e)
;; Single expression: no mark
(certify
expr
#`(begin #,(annotate (syntax e) phase)))]
[(begin . body)
(with-mark expr
(certify
expr
(annotate-seq expr #'body annotate phase)))]
[(begin0 . body)
(with-mark expr
(certify
expr
(annotate-seq expr #'body annotate phase)))]
[(if tst thn els)
(let ([w-tst (annotate (syntax tst) phase)]
[w-thn (annotate (syntax thn) phase)]
[w-els (annotate (syntax els) phase)])
(with-mark expr
(certify
expr
(rebuild expr (list (cons #'tst w-tst)
(cons #'thn w-thn)
(cons #'els w-els))))))]
[(if tst thn)
(let ([w-tst (annotate (syntax tst) phase)]
[w-thn (annotate (syntax thn) phase)])
(with-mark expr
(certify
expr
(rebuild expr (list (cons #'tst w-tst)
(cons #'thn w-thn))))))]
[(with-continuation-mark . body)
(with-mark expr
(certify
expr
(annotate-seq expr (syntax body)
annotate phase)))]
;; Wrap whole application, plus subexpressions
[(#%plain-app . body)
(cond
[(stx-null? (syntax body))
;; It's a null:
expr]
[(syntax-case* expr (#%plain-app void)
(if (positive? phase)
free-transformer-identifier=?
free-identifier=?)
[(#%plain-app void) #t]
[_else #f])
;; It's (void):
expr]
[else
(with-mark expr (certify
expr
(annotate-seq expr (syntax body)
annotate phase)))])]
[_else
(error 'errortrace "unrecognized expression form~a: ~e"
(if top? " at top-level" "")
(syntax->datum expr))])
[_
(identifier? expr)
(let ([b (identifier-binding expr phase)])
(cond
[(eq? 'lexical b)
;; lexical variable - no error possile
expr]
[(and (pair? b) (let-values ([(base rel) (module-path-index-split (car b))])
(equal? '(quote #%kernel) base)))
;; built-in - no error possible
expr]
[else
;; might be undefined/uninitialized
(with-mark expr expr)]))]
[(#%top . id)
;; might be undefined/uninitialized
(with-mark expr expr)]
[(#%variable-reference . _)
;; no error possible
expr]
[(define-values names rhs)
top?
;; Can't put annotation on the outside
(let* ([marked
(with-mark expr
(annotate-named
(one-name #'names)
(syntax rhs)
phase))]
[with-coverage
(let loop ([stx #'names]
[obj marked])
(cond
[(not (syntax? stx)) obj]
[(identifier? stx)
(test-coverage-point obj stx phase)]
[(pair? (syntax-e stx))
(loop (car (syntax-e stx))
(loop (cdr (syntax-e stx))
obj))]
[else obj]))])
(certify
expr
(rebuild
expr
(list (cons #'rhs with-coverage)))))]
[(begin . exprs)
top?
(certify
expr
(annotate-seq expr
(syntax exprs)
annotate-top phase))]
[(define-syntaxes (name ...) rhs)
top?
(let ([marked (with-mark expr
(annotate-named
(one-name #'(name ...))
(syntax rhs)
(add1 phase)))])
(certify
expr
(rebuild expr (list (cons #'rhs marked)))))]
[(define-values-for-syntax (name ...) rhs)
top?
(let ([marked (with-mark expr
(annotate-named
(one-name (syntax (name ...)))
(syntax rhs)
(add1 phase)))])
(certify
expr
(rebuild expr (list (cons #'rhs marked)))))]
[(module name init-import (__plain-module-begin body ...))
;; Just wrap body expressions
(let ([bodys (syntax->list (syntax (body ...)))]
[mb (list-ref (syntax->list expr) 3)])
(let ([bodyl (map (lambda (b)
(annotate-top b 0))
bodys)])
(certify
expr
(rebuild
expr
(list (cons
mb
(certify
mb
(rebuild mb (map cons bodys bodyl)))))))))]
[(#%expression e)
top?
(certify expr #`(#%expression #,(annotate (syntax e) phase)))]
;; No way to wrap
[(#%require i ...) expr]
;; No error possible (and no way to wrap)
[(#%provide i ...) expr]
;; No error possible
[(quote _)
expr]
[(quote-syntax _)
expr]
;; Wrap body, also a profile point
[(#%plain-lambda args . body)
(certify
expr
(keep-lambda-properties
expr
(profile-annotate-lambda name expr expr (syntax body)
phase)))]
[(case-lambda clause ...)
(with-syntax ([([args . body] ...)
(syntax (clause ...))])
(let* ([clauses (syntax->list (syntax (clause ...)))]
[clausel (map
(lambda (body clause)
(profile-annotate-lambda
name expr clause body phase))
(syntax->list (syntax (body ...)))
clauses)])
(certify
expr
(keep-lambda-properties
expr
(rebuild expr (map cons clauses clausel))))))]
;; Wrap RHSs and body
[(let-values ([vars rhs] ...) . body)
(with-mark expr
(certify
expr
(annotate-let expr phase
(syntax (vars ...))
(syntax (rhs ...))
(syntax body))))]
[(letrec-values ([vars rhs] ...) . body)
(let ([fm (certify
expr
(annotate-let expr phase
(syntax (vars ...))
(syntax (rhs ...))
(syntax body)))])
(kernel-syntax-case/phase expr phase
[(lv ([(var1) (#%plain-lambda . _)]) var2)
(and (identifier? #'var2)
(free-identifier=? #'var1 #'var2))
fm]
[_
(with-mark expr fm)]))]
;; Wrap RHS
[(set! var rhs)
(let ([new-rhs (annotate-named
(syntax var)
(syntax rhs)
phase)])
;; set! might fail on undefined variable, or too many values:
(with-mark expr
(certify
expr
(rebuild expr (list (cons #'rhs new-rhs))))))]
;; Wrap subexpressions only
[(begin e)
;; Single expression: no mark
(certify
expr
#`(begin #,(annotate (syntax e) phase)))]
[(begin . body)
(with-mark expr
(certify
expr
(annotate-seq expr #'body annotate phase)))]
[(begin0 . body)
(with-mark expr
(certify
expr
(annotate-seq expr #'body annotate phase)))]
[(if tst thn els)
(let ([w-tst (annotate (syntax tst) phase)]
[w-thn (annotate (syntax thn) phase)]
[w-els (annotate (syntax els) phase)])
(with-mark expr
(certify
expr
(rebuild expr (list (cons #'tst w-tst)
(cons #'thn w-thn)
(cons #'els w-els))))))]
[(if tst thn)
(let ([w-tst (annotate (syntax tst) phase)]
[w-thn (annotate (syntax thn) phase)])
(with-mark expr
(certify
expr
(rebuild expr (list (cons #'tst w-tst)
(cons #'thn w-thn))))))]
[(with-continuation-mark . body)
(with-mark expr
(certify
expr
(annotate-seq expr (syntax body)
annotate phase)))]
;; Wrap whole application, plus subexpressions
[(#%plain-app . body)
(cond
[(stx-null? (syntax body))
;; It's a null:
expr]
[(syntax-case* expr (#%plain-app void)
(if (positive? phase)
free-transformer-identifier=?
free-identifier=?)
[(#%plain-app void) #t]
[_else #f])
;; It's (void):
expr]
[else
(with-mark expr (certify
expr
(annotate-seq expr (syntax body)
annotate phase)))])]
[_else
(error 'errortrace "unrecognized expression form~a: ~e"
(if top? " at top-level" "")
(syntax->datum expr))])
expr
phase)))

50
collects/tests/future/future.ss
View File

@ -103,15 +103,47 @@ We should also test deep continuations.
[f3 (future (λ () (< (touch f2) 1)))])
(touch f3)))
(check-equal?
'((1) (1))
(let ([f1 (future (lambda ()
(with-continuation-mark
'x 1
(current-continuation-marks))))]
[f2 (future (lambda ()
(with-continuation-mark
'x 1
(current-continuation-marks))))])
(list (continuation-mark-set->list (touch f1) 'x)
(continuation-mark-set->list (touch f2) 'x))))
(check-equal?
'((1 0) (1 0))
(let ([f1 (future (lambda ()
(with-continuation-mark
'x 1
(current-continuation-marks))))]
[f2 (future (lambda ()
(with-continuation-mark
'x 1
(current-continuation-marks))))])
(with-continuation-mark
'x 0
(list (continuation-mark-set->list (touch f1) 'x)
(continuation-mark-set->list (touch f2) 'x)))))
(check-equal?
'((1 0) (1) ())
(let ([f1 (future (lambda ()
(with-continuation-mark
'x 1
(current-continuation-marks))))]
[f2 (future (lambda ()
(with-continuation-mark
'x 1
(current-continuation-marks))))])
(list (continuation-mark-set->list (with-continuation-mark 'x 0
(touch f1))
'x)
(continuation-mark-set->list (touch f2) 'x)
(continuation-mark-set->list (current-continuation-marks) 'x))))

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

@ -1817,7 +1817,8 @@ static Scheme_Object *make_toplevel(mzshort depth, int position, int resolved, i
}
Scheme_Object *scheme_register_toplevel_in_prefix(Scheme_Object *var, Scheme_Comp_Env *env,
Scheme_Compile_Info *rec, int drec)
Scheme_Compile_Info *rec, int drec,
int imported)
{
Comp_Prefix *cp = env->prefix;
Scheme_Hash_Table *ht;
@ -1838,7 +1839,7 @@ Scheme_Object *scheme_register_toplevel_in_prefix(Scheme_Object *var, Scheme_Com
if (o)
return o;
o = make_toplevel(0, cp->num_toplevels, 0, 0);
o = make_toplevel(0, cp->num_toplevels, 0, imported ? SCHEME_TOPLEVEL_READY : 0);
cp->num_toplevels++;
scheme_hash_set(ht, var, o);
@ -3094,6 +3095,24 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
return (Scheme_Object *)b;
}
int scheme_is_imported(Scheme_Object *var, Scheme_Comp_Env *env)
{
if (env->genv->module) {
if (SAME_TYPE(SCHEME_TYPE(var), scheme_module_variable_type)) {
if (!SAME_OBJ(((Module_Variable *)var)->modidx, env->genv->module->self_modidx))
return 1;
} else
return 1;
} else {
if (SAME_TYPE(SCHEME_TYPE(var), scheme_variable_type)) {
if (!SAME_OBJ(((Scheme_Bucket_With_Home *)var)->home, env->genv))
return 1;
} else
return 1;
}
return 0;
}
Scheme_Object *scheme_extract_unsafe(Scheme_Object *o)
{
Scheme_Env *home = ((Scheme_Bucket_With_Home *)o)->home;

94
src/mzscheme/src/eval.c
View File

@ -124,6 +124,9 @@
#include "schpriv.h"
#include "schrunst.h"
#include "schexpobs.h"
#ifdef MZ_USE_FUTURES
# include "future.h"
#endif
#ifdef USE_STACKAVAIL
#include <malloc.h>
@ -959,8 +962,8 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved,
&& (1 <= ((Scheme_Primitive_Proc *)app->rator)->mu.maxa)) {
note_match(1, vals, warn_info);
if ((vals == 1) || (vals < 0)) {
/* can omit an unsafe op */
return 1;
if (scheme_omittable_expr(app->rand, 1, fuel - 1, resolved, warn_info))
return 1;
}
}
return 0;
@ -998,8 +1001,9 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved,
&& (2 <= ((Scheme_Primitive_Proc *)app->rator)->mu.maxa)) {
note_match(1, vals, warn_info);
if ((vals == 1) || (vals < 0)) {
/* can omit an unsafe op */
return 1;
if (scheme_omittable_expr(app->rand1, 1, fuel - 1, resolved, warn_info)
&& scheme_omittable_expr(app->rand2, 1, fuel - 1, resolved, warn_info))
return 1;
}
}
}
@ -1844,6 +1848,7 @@ static Scheme_Object *link_module_variable(Scheme_Object *modidx,
{
Scheme_Object *modname;
Scheme_Env *menv;
Scheme_Bucket *bkt;
int self = 0;
/* If it's a name id, resolve the name. */
@ -1893,7 +1898,23 @@ static Scheme_Object *link_module_variable(Scheme_Object *modidx,
}
}
return (Scheme_Object *)scheme_global_bucket(varname, menv);
bkt = scheme_global_bucket(varname, menv);
if (!self) {
if (!bkt->val) {
scheme_wrong_syntax("link", NULL, varname,
"reference (phase %d) to a variable in module"
" %D that is uninitialized (phase level %d); reference"
" appears in module: %D",
env->phase,
exprs ? SCHEME_CDR(modname) : modname,
mod_phase,
env->module ? env->module->modname : scheme_false);
}
if (!(((Scheme_Bucket_With_Flags *)bkt)->flags & (GLOB_IS_IMMUTATED | GLOB_IS_LINKED)))
((Scheme_Bucket_With_Flags *)bkt)->flags |= GLOB_IS_LINKED;
}
return (Scheme_Object *)bkt;
}
static Scheme_Object *link_toplevel(Scheme_Object **exprs, int which, Scheme_Env *env,
@ -4082,6 +4103,11 @@ static Scheme_Object *optimize_wcm(Scheme_Object *o, Optimize_Info *info, int co
b = scheme_optimize_expr(wcm->body, info, scheme_optimize_tail_context(context));
if (scheme_omittable_expr(k, 1, 20, 0, info)
&& scheme_omittable_expr(v, 1, 20, 0, info)
&& scheme_omittable_expr(b, -1, 20, 0, info))
return b;
/* info->single_result is already set */
info->preserves_marks = 0;
@ -4426,6 +4452,27 @@ Scheme_Object *scheme_optimize_clone(int dup_ok, Scheme_Object *expr, Optimize_I
return (Scheme_Object *)b2;
}
case scheme_with_cont_mark_type:
{
Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)expr, *wcm2;
wcm2 = MALLOC_ONE_TAGGED(Scheme_With_Continuation_Mark);
wcm2->so.type = scheme_with_cont_mark_type;
expr = scheme_optimize_clone(dup_ok, wcm->key, info, delta, closure_depth);
if (!expr) return NULL;
wcm2->key = expr;
expr = scheme_optimize_clone(dup_ok, wcm->val, info, delta, closure_depth);
if (!expr) return NULL;
wcm2->val = expr;
expr = scheme_optimize_clone(dup_ok, wcm->body, info, delta, closure_depth);
if (!expr) return NULL;
wcm2->body = expr;
return (Scheme_Object *)wcm2;
}
case scheme_compiled_unclosed_procedure_type:
return scheme_clone_closure_compilation(dup_ok, expr, info, delta, closure_depth);
case scheme_compiled_toplevel_type:
@ -6590,7 +6637,8 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
return scheme_extract_flfxnum(var);
} else if (SAME_TYPE(SCHEME_TYPE(var), scheme_variable_type)
|| SAME_TYPE(SCHEME_TYPE(var), scheme_module_variable_type))
return scheme_register_toplevel_in_prefix(var, env, rec, drec);
return scheme_register_toplevel_in_prefix(var, env, rec, drec,
scheme_is_imported(var, env));
else
return var;
} else {
@ -7293,7 +7341,7 @@ top_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec,
c = (Scheme_Object *)scheme_global_bucket(c, env->genv);
}
return scheme_register_toplevel_in_prefix(c, env, rec, drec);
return scheme_register_toplevel_in_prefix(c, env, rec, drec, 0);
}
static Scheme_Object *
@ -8018,13 +8066,10 @@ static MZ_MARK_STACK_TYPE clone_meta_cont_set_mark(Scheme_Meta_Continuation *mc,
return 0;
}
static MZ_MARK_STACK_TYPE new_segment_set_mark(long segpos, long pos, Scheme_Object *key, Scheme_Object *val)
void scheme_new_mark_segment(Scheme_Thread *p)
{
Scheme_Thread *p = scheme_current_thread;
Scheme_Cont_Mark *cm = NULL;
int c = p->cont_mark_seg_count;
Scheme_Cont_Mark **segs, *seg;
long findpos;
/* Note: we perform allocations before changing p to avoid GC trouble,
since MzScheme adjusts a thread's cont_mark_stack_segments on GC. */
@ -8036,22 +8081,22 @@ static MZ_MARK_STACK_TYPE new_segment_set_mark(long segpos, long pos, Scheme_Obj
p->cont_mark_seg_count++;
p->cont_mark_stack_segments = segs;
seg = p->cont_mark_stack_segments[segpos];
cm = seg + pos;
findpos = MZ_CONT_MARK_STACK;
MZ_CONT_MARK_STACK++;
cm->key = key;
cm->val = val;
cm->pos = MZ_CONT_MARK_POS; /* always odd */
cm->cache = NULL;
return findpos;
}
#ifdef MZ_USE_FUTURES
static void ts_scheme_new_mark_segment(Scheme_Thread *p) XFORM_SKIP_PROC
{
if (scheme_use_rtcall)
scheme_rtcall_new_mark_segment(p);
else
scheme_new_mark_segment(p);
}
#else
# define ts_scheme_new_mark_segment scheme_new_mark_segment
#endif
MZ_MARK_STACK_TYPE scheme_set_cont_mark(Scheme_Object *key, Scheme_Object *val)
/* This function can be called inside a future thread */
{
Scheme_Thread *p = scheme_current_thread;
Scheme_Cont_Mark *cm = NULL;
@ -8116,8 +8161,7 @@ MZ_MARK_STACK_TYPE scheme_set_cont_mark(Scheme_Object *key, Scheme_Object *val)
pos = ((long)findpos) & SCHEME_MARK_SEGMENT_MASK;
if (segpos >= p->cont_mark_seg_count) {
/* Need a new segment */
return new_segment_set_mark(segpos, pos, key, val);
ts_scheme_new_mark_segment(p);
}
seg = p->cont_mark_stack_segments[segpos];

190
src/mzscheme/src/future.c
View File

@ -20,9 +20,6 @@
#include "schpriv.h"
//This will be TRUE if primitive tracking has been enabled
//by the program
static Scheme_Object *future_p(int argc, Scheme_Object *argv[])
{
if (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_future_type))
@ -290,8 +287,7 @@ typedef struct future_thread_params_t {
/* Plumbing for MzScheme initialization */
/**********************************************************************/
//Invoked by the runtime on startup to make
//primitives known
/* Invoked by the runtime on startup to make primitives known */
void scheme_init_futures(Scheme_Env *env)
{
Scheme_Object *v;
@ -378,8 +374,8 @@ static void init_future_thread(Scheme_Future_State *fs, int i)
Scheme_Thread *skeleton;
Scheme_Object **runstack_start;
//Create the worker thread pool. These threads will
//'queue up' and wait for futures to become available
/* Create the worker thread pool. These threads will
'queue up' and wait for futures to become available. */
fts = (Scheme_Future_Thread_State *)malloc(sizeof(Scheme_Future_Thread_State));
memset(fts, 0, sizeof(Scheme_Future_Thread_State));
@ -454,12 +450,19 @@ static void end_gc_not_ok(Scheme_Future_Thread_State *fts,
Scheme_Object **current_rs)
/* must have mutex_lock */
{
Scheme_Thread *p;
scheme_set_runstack_limits(MZ_RUNSTACK_START,
fts->runstack_size,
(current_rs
? current_rs XFORM_OK_MINUS MZ_RUNSTACK_START
: fts->runstack_size),
fts->runstack_size);
p = scheme_current_thread;
p->runstack = MZ_RUNSTACK;
p->runstack_start = MZ_RUNSTACK_START;
p->cont_mark_stack = MZ_CONT_MARK_STACK;
p->cont_mark_pos = MZ_CONT_MARK_POS;
/* FIXME: clear scheme_current_thread->ku.multiple.array ? */
@ -543,7 +546,7 @@ void scheme_future_gc_pause()
}
/**********************************************************************/
/* Primitive implementations */
/* Primitive implementations */
/**********************************************************************/
Scheme_Object *future(int argc, Scheme_Object *argv[])
@ -556,7 +559,7 @@ Scheme_Object *future(int argc, Scheme_Object *argv[])
Scheme_Native_Closure_Data *ncd;
Scheme_Object *lambda = argv[0];
//Input validation
/* Input validation */
scheme_check_proc_arity("future", 0, 0, argc, argv);
if (fs->future_threads_created < THREAD_POOL_SIZE) {
@ -572,7 +575,7 @@ Scheme_Object *future(int argc, Scheme_Object *argv[])
nc = (Scheme_Native_Closure*)lambda;
ncd = nc->code;
//Create the future descriptor and add to the queue as 'pending'
/* Create the future descriptor and add to the queue as 'pending' */
ft = MALLOC_ONE_TAGGED(future_t);
ft->so.type = scheme_future_type;
@ -581,7 +584,7 @@ Scheme_Object *future(int argc, Scheme_Object *argv[])
ft->orig_lambda = lambda;
ft->status = PENDING;
//JIT compile the code if not already jitted
/* JIT the code if not already JITted */
if (ncd->code == scheme_on_demand_jit_code)
{
scheme_on_demand_generate_lambda(nc, 0, NULL);
@ -596,7 +599,7 @@ Scheme_Object *future(int argc, Scheme_Object *argv[])
mzrt_mutex_lock(fs->future_mutex);
enqueue_future(fs, ft);
//Signal that a future is pending
/* Signal that a future is pending */
mzrt_sema_post(fs->future_pending_sema);
mzrt_mutex_unlock(fs->future_mutex);
@ -682,8 +685,8 @@ Scheme_Object *touch(int argc, Scheme_Object *argv[])
}
mzrt_mutex_unlock(fs->future_mutex);
//Spin waiting for primitive calls or a return value from
//the worker thread
/* Spin waiting for primitive calls or a return value from
the worker thread */
while (1) {
scheme_block_until(future_ready, NULL, (Scheme_Object*)ft, 0);
mzrt_mutex_lock(fs->future_mutex);
@ -692,16 +695,15 @@ Scheme_Object *touch(int argc, Scheme_Object *argv[])
retval = ft->retval;
LOG("Successfully touched future %d\n", ft->id);
// fflush(stdout);
mzrt_mutex_unlock(fs->future_mutex);
break;
}
else if (ft->rt_prim)
{
//Invoke the primitive and stash the result
//Release the lock so other threads can manipulate the queue
//while the runtime call executes
/* Invoke the primitive and stash the result.
Release the lock so other threads can manipulate the queue
while the runtime call executes. */
mzrt_mutex_unlock(fs->future_mutex);
LOG2("Invoking primitive %p on behalf of future %d...", ft->rt_prim, ft->id);
invoke_rtcall(fs, ft);
@ -756,9 +758,9 @@ Scheme_Object *processor_count(int argc, Scheme_Object *argv[])
return scheme_make_integer(cpucount);
}
//Entry point for a worker thread allocated for
//executing futures. This function will never terminate
//(until the process dies).
/* Entry point for a worker thread allocated for
executing futures. This function will never terminate
(until the process dies). */
void *worker_thread_future_loop(void *arg)
XFORM_SKIP_PROC
/* Called in future thread; runtime thread is blocked until ready_sema
@ -779,7 +781,7 @@ void *worker_thread_future_loop(void *arg)
GC_instance = params->shared_GC;
scheme_current_thread = params->thread_skeleton;
//Set processor affinity
/* Set processor affinity */
/*mzrt_mutex_lock(fs->future_mutex);
static unsigned long cur_cpu_mask = 1;
if (pthread_setaffinity_np(pthread_self(), sizeof(g_cur_cpu_mask), &g_cur_cpu_mask))
@ -823,31 +825,32 @@ void *worker_thread_future_loop(void *arg)
if (ft) {
LOG0("Got a signal that a future is pending...");
//Work is available for this thread
/* Work is available for this thread */
ft->status = RUNNING;
mzrt_mutex_unlock(fs->future_mutex);
ft->thread_short_id = fts->id;
//Set up the JIT compiler for this thread
/* Set up the JIT compiler for this thread */
scheme_jit_fill_threadlocal_table();
jitcode = (Scheme_Object* (*)(Scheme_Object*, int, Scheme_Object**))(ft->code);
fts->current_ft = ft;
//Run the code
//Passing no arguments for now.
//The lambda passed to a future will always be a parameterless
//function.
//From this thread's perspective, this call will never return
//until all the work to be done in the future has been completed,
//including runtime calls.
//If jitcode asks the runrtime thread to do work, then
//a GC can occur.
/* Run the code:
The lambda passed to a future will always be a parameterless
function.
From this thread's perspective, this call will never return
until all the work to be done in the future has been completed,
including runtime calls.
If jitcode asks the runrtime thread to do work, then
a GC can occur. */
LOG("Running JIT code at %p...\n", ft->code);
MZ_RUNSTACK = MZ_RUNSTACK_START + fts->runstack_size;
MZ_CONT_MARK_STACK = 0;
MZ_CONT_MARK_POS = (MZ_MARK_POS_TYPE)1;
scheme_current_thread->error_buf = &newbuf;
if (scheme_future_setjmp(newbuf)) {
@ -862,10 +865,10 @@ void *worker_thread_future_loop(void *arg)
LOG("Finished running JIT code at %p.\n", ft->code);
// Get future again, since a GC may have occurred
/* Get future again, since a GC may have occurred */
ft = fts->current_ft;
//Set the return val in the descriptor
/* Set the return val in the descriptor */
mzrt_mutex_lock(fs->future_mutex);
ft->work_completed = 1;
ft->retval = v;
@ -873,10 +876,14 @@ void *worker_thread_future_loop(void *arg)
/* In case of multiple values: */
send_special_result(ft, v);
//Update the status
/* Update the status */
ft->status = FINISHED;
dequeue_future(fs, ft);
/* Clear stacks */
MZ_RUNSTACK = MZ_RUNSTACK_START + fts->runstack_size;
MZ_CONT_MARK_STACK = 0;
scheme_signal_received_at(fs->signal_handle);
}
@ -918,10 +925,6 @@ void scheme_check_future_work()
}
}
//Returns 0 if the call isn't actually executed by this function,
//i.e. if we are already running on the runtime thread. Otherwise returns
//1, and 'retval' is set to point to the return value of the runtime
//call invocation.
static void future_do_runtimecall(Scheme_Future_Thread_State *fts,
void *func,
int is_atomic)
@ -931,11 +934,11 @@ static void future_do_runtimecall(Scheme_Future_Thread_State *fts,
future_t *future;
Scheme_Future_State *fs = scheme_future_state;
//Fetch the future descriptor for this thread
/* Fetch the future descriptor for this thread */
future = fts->current_ft;
//set up the arguments for the runtime call
//to be picked up by the main rt thread
/* Set up the arguments for the runtime call
to be picked up by the main rt thread */
mzrt_mutex_lock(fs->future_mutex);
future->prim_func = func;
@ -950,14 +953,16 @@ static void future_do_runtimecall(Scheme_Future_Thread_State *fts,
}
}
//Update the future's status to waiting
/* Update the future's status to waiting */
future->status = WAITING_FOR_PRIM;
scheme_signal_received_at(fs->signal_handle);
//Wait for the signal that the RT call is finished
future->arg_p = scheme_current_thread;
/* Wait for the signal that the RT call is finished */
future->can_continue_sema = fts->worker_can_continue_sema;
end_gc_not_ok(fts, fs, MZ_RUNSTACK);
end_gc_not_ok(fts, fs, MZ_RUNSTACK); /* we rely on this putting MZ_CONT_MARK_STACK into the thread record */
mzrt_mutex_unlock(fs->future_mutex);
mzrt_sema_wait(fts->worker_can_continue_sema);
@ -966,7 +971,7 @@ static void future_do_runtimecall(Scheme_Future_Thread_State *fts,
start_gc_not_ok(fs);
mzrt_mutex_unlock(fs->future_mutex);
//Fetch the future instance again, in case the GC has moved the pointer
/* Fetch the future instance again, in case the GC has moved the pointer */
future = fts->current_ft;
if (future->no_retval) {
@ -1057,6 +1062,62 @@ unsigned long scheme_rtcall_alloc(const char *who, int src_type)
#endif
void scheme_rtcall_new_mark_segment(Scheme_Thread *p)
XFORM_SKIP_PROC
/* Called in future thread */
{
future_t *future;
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
future = fts->current_ft;
future->time_of_request = scheme_get_inexact_milliseconds();
future->source_of_request = "[allocate_mark_segment]";
future->source_type = FSRC_OTHER;
future->prim_protocol = SIG_ALLOC_MARK_SEGMENT;
future->arg_s0 = (Scheme_Object *)p;
future_do_runtimecall(fts, (void*)scheme_new_mark_segment, 1);
}
static int push_marks(future_t *f, Scheme_Cont_Frame_Data *d)
{
Scheme_Thread *p2, *p;
long i, pos, delta;
Scheme_Cont_Mark *seg;
if (f->arg_p) {
p2 = f->arg_p;
if (p2->cont_mark_stack) {
scheme_push_continuation_frame(d);
p = scheme_current_thread;
delta = MZ_CONT_MARK_POS - p2->cont_mark_pos;
if (delta < 0) delta = 0;
for (i = p2->cont_mark_stack; i--; ) {
seg = p2->cont_mark_stack_segments[i >> SCHEME_LOG_MARK_SEGMENT_SIZE];
pos = i & SCHEME_MARK_SEGMENT_MASK;
MZ_CONT_MARK_POS = seg[pos].pos + delta;
scheme_set_cont_mark(seg[pos].key, seg[pos].val);
}
MZ_CONT_MARK_POS = p2->cont_mark_pos + delta;
return 1;
}
}
return 0;
}
static void pop_marks(Scheme_Cont_Frame_Data *d)
{
scheme_pop_continuation_frame(d);
}
static void receive_special_result(future_t *f, Scheme_Object *retval, int clear)
XFORM_SKIP_PROC
/* Called in future or runtime thread */
@ -1106,12 +1167,15 @@ static void send_special_result(future_t *f, Scheme_Object *retval)
}
}
//Does the work of actually invoking a primitive on behalf of a
//future. This function is always invoked on the main (runtime)
//thread.
/* Does the work of actually invoking a primitive on behalf of a
future. This function is always invoked on the main (runtime)
thread. */
static void do_invoke_rtcall(Scheme_Future_State *fs, future_t *future)
/* Called in runtime thread */
{
Scheme_Cont_Frame_Data mark_d;
int need_pop;
#ifdef DEBUG_FUTURES
g_rtcall_count++;
#endif
@ -1141,6 +1205,13 @@ static void do_invoke_rtcall(Scheme_Future_State *fs, future_t *future)
future->time_of_request,
src);
}
if ((future->source_type == FSRC_RATOR)
|| (future->source_type == FSRC_MARKS))
need_pop = push_marks(future, &mark_d);
else
need_pop = 0;
future->arg_p = NULL;
switch (future->prim_protocol)
{
@ -1162,15 +1233,26 @@ static void do_invoke_rtcall(Scheme_Future_State *fs, future_t *future)
break;
}
#endif
case SIG_ALLOC_MARK_SEGMENT:
{
Scheme_Thread *p_seg;
p_seg = (Scheme_Thread *)future->arg_s0;
future->arg_s0 = NULL;
scheme_new_mark_segment(p_seg);
break;
}
# include "jit_ts_runtime_glue.c"
default:
scheme_signal_error("unknown protocol %d", future->prim_protocol);
break;
}
if (need_pop)
pop_marks(&mark_d);
mzrt_mutex_lock(fs->future_mutex);
//Signal the waiting worker thread that it
//can continue running machine code
/* Signal the waiting worker thread that it
can continue running machine code */
if (future->can_continue_sema) {
mzrt_sema_post(future->can_continue_sema);
future->can_continue_sema= NULL;
@ -1202,8 +1284,8 @@ static void invoke_rtcall(Scheme_Future_State * volatile fs, future_t * volatile
if (scheme_setjmp(newbuf)) {
mzrt_mutex_lock(fs->future_mutex);
future->no_retval = 1;
//Signal the waiting worker thread that it
//can continue running machine code
/* Signal the waiting worker thread that it
can continue running machine code */
mzrt_sema_post(future->can_continue_sema);
future->can_continue_sema = NULL;
mzrt_mutex_unlock(fs->future_mutex);

15
src/mzscheme/src/future.h
View File

@ -37,6 +37,7 @@ typedef void* (*prim_pvoid_pvoid_pvoid_t)(void*, void*);
#define FSRC_OTHER 0
#define FSRC_RATOR 1
#define FSRC_PRIM 2
#define FSRC_MARKS 3
typedef struct future_t {
Scheme_Object so;
@ -50,7 +51,7 @@ typedef struct future_t {
Scheme_Object *orig_lambda;
void *code;
//Runtime call stuff
/* Runtime call stuff */
int rt_prim; /* flag to indicate waiting for a prim call */
int rt_prim_is_atomic;
double time_of_request;
@ -76,6 +77,7 @@ typedef struct future_t {
Scheme_Object *arg_s2;
Scheme_Object **arg_S2;
int arg_i2;
Scheme_Thread *arg_p;
Scheme_Object *retval_s;
void *retval_p; /* use only with conservative GC */
@ -97,12 +99,12 @@ typedef struct future_t {
struct future_t *next_waiting_atomic;
} future_t;
//Primitive instrumentation stuff
/* Primitive instrumentation stuff */
//Signature flags for primitive invocations
//Here the convention is SIG_[arg1type]_[arg2type]..._[return type]
#define SIG_VOID_VOID_3ARGS 1 //void -> void, copy 3 args from runstack
#define SIG_ALLOC 2 //void -> void*
/* Signature flags for primitive invocations */
#define SIG_VOID_VOID_3ARGS 1
#define SIG_ALLOC 2
#define SIG_ALLOC_MARK_SEGMENT 3
# include "jit_ts_protos.h"
@ -120,6 +122,7 @@ extern Scheme_Object *scheme_ts_scheme_force_value_same_mark(Scheme_Object *v);
extern void scheme_rtcall_void_void_3args(const char *who, int src_type, prim_void_void_3args_t f);
extern unsigned long scheme_rtcall_alloc(const char *who, int src_type);
extern void scheme_rtcall_new_mark_segment(Scheme_Thread *p);
#else

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

@ -170,6 +170,7 @@ SHARED_OK static void *finish_tail_call_code, *finish_tail_call_fixup_code;
SHARED_OK static void *module_run_start_code, *module_exprun_start_code, *module_start_start_code;
SHARED_OK static void *box_flonum_from_stack_code;
SHARED_OK static void *fl1_fail_code, *fl2rr_fail_code[2], *fl2fr_fail_code[2], *fl2rf_fail_code[2];
SHARED_OK static void *wcm_code, *wcm_nontail_code;
typedef struct {
MZTAG_IF_REQUIRED
@ -828,7 +829,7 @@ static void raise_bad_call_with_values(Scheme_Object *f)
static Scheme_Object *call_with_values_from_multiple_result(Scheme_Object *f)
{
Scheme_Thread *p = scheme_current_thread;
Scheme_Thread *p = scheme_current_thread;
if (SAME_OBJ(p->ku.multiple.array, p->values_buffer))
p->values_buffer = NULL;
return _scheme_apply(f, p->ku.multiple.count, p->ku.multiple.array);
@ -836,7 +837,7 @@ static Scheme_Object *call_with_values_from_multiple_result(Scheme_Object *f)
static Scheme_Object *call_with_values_from_multiple_result_multi(Scheme_Object *f)
{
Scheme_Thread *p = scheme_current_thread;
Scheme_Thread *p = scheme_current_thread;
if (SAME_OBJ(p->ku.multiple.array, p->values_buffer))
p->values_buffer = NULL;
return _scheme_apply_multi(f, p->ku.multiple.count, p->ku.multiple.array);
@ -1003,7 +1004,7 @@ static void mz_pushr_p_it(mz_jit_state *jitter, int reg)
jitter->need_set_rs = 1;
}
static void mz_popr_p_it(mz_jit_state *jitter, int reg)
static void mz_popr_p_it(mz_jit_state *jitter, int reg, int discard)
/* de-sync's rs */
{
int v;
@ -1019,7 +1020,8 @@ static void mz_popr_p_it(mz_jit_state *jitter, int reg)
else
jitter->mappings[jitter->num_mappings] = ((v << 2) | 0x1);
mz_rs_ldr(reg);
if (!discard)
mz_rs_ldr(reg);
mz_rs_inc(1);
jitter->need_set_rs = 1;
@ -1314,7 +1316,8 @@ static int stack_safety(mz_jit_state *jitter, int cnt, int offset)
/* de-sync's rs: */
#define mz_pushr_p(x) mz_pushr_p_it(jitter, x)
#define mz_popr_p(x) mz_popr_p_it(jitter, x)
#define mz_popr_p(x) mz_popr_p_it(jitter, x, 0)
#define mz_popr_x() mz_popr_p_it(jitter, JIT_R1, 1)
#if 0
/* Debugging: at each _finish(), double-check that the runstack register has been
@ -6197,6 +6200,7 @@ static int generate_inlined_type_test(mz_jit_state *jitter, Scheme_App2_Rec *app
jit_ldxi_p(JIT_R1, JIT_R0, (long)&((Scheme_Chaperone *)0x0)->val);
jit_ldxi_s(JIT_R1, JIT_R1, &((Scheme_Object *)0x0)->type);
mz_patch_branch(ref3);
CHECK_LIMIT();
__END_INNER_TINY__(branch_short);
}
if (lo_ty == hi_ty) {
@ -6673,6 +6677,7 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
mz_patch_branch(ref);
__END_TINY_JUMPS__(1);
}
CHECK_LIMIT();
if (!for_fl)
(void)jit_ldxi_i(JIT_R0, JIT_R0, &SCHEME_VEC_SIZE(0x0));
@ -6768,6 +6773,7 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
(void)jit_calli(unbox_code);
ref2 = jit_jmpi(jit_forward());
mz_patch_branch(ref);
CHECK_LIMIT();
__END_TINY_JUMPS__(1);
(void)jit_ldxi_p(JIT_R0, JIT_R0, &SCHEME_BOX_VAL(0x0));
@ -9226,7 +9232,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
/* de-sync's; result goes to target */
{
Scheme_Type type;
int result_ignored, orig_target;
int result_ignored, orig_target, not_wmc_again;
#ifdef DO_STACK_CHECK
# include "mzstkchk.h"
@ -9267,6 +9273,8 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
CHECK_LIMIT();
}
not_wmc_again = !is_tail;
type = SCHEME_TYPE(obj);
switch (type) {
case scheme_toplevel_type:
@ -10179,27 +10187,23 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
/* Key: */
generate_non_tail(wcm->key, jitter, 0, 1, 0); /* sync'd below */
mz_pushr_p(JIT_R0); /* sync'd below */
CHECK_LIMIT();
if (SCHEME_TYPE(wcm->val) > _scheme_values_types_) {
/* No need to push mark onto value stack: */
jit_movr_p(JIT_V1, JIT_R0);
generate_non_tail(wcm->val, jitter, 0, 1, 0); /* sync'd below */
CHECK_LIMIT();
} else {
mz_pushr_p(JIT_R0);
generate_non_tail(wcm->val, jitter, 0, 1, 0); /* sync'd below */
CHECK_LIMIT();
mz_popr_p(JIT_V1); /* sync'd below */
}
/* Value: */
generate_non_tail(wcm->val, jitter, 0, 1, 0); /* sync'd below */
CHECK_LIMIT();
mz_pushr_p(JIT_R0); /* sync'd below */
/* Key and value are on runstack */
mz_rs_sync();
JIT_UPDATE_THREAD_RSPTR_IF_NEEDED();
mz_prepare(2);
jit_pusharg_p(JIT_R0);
jit_pusharg_p(JIT_V1);
(void)mz_finish(ts_scheme_set_cont_mark);
CHECK_LIMIT();
if (not_wmc_again) {
(void)jit_calli(wcm_nontail_code);
not_wmc_again = 0;
} else
(void)jit_calli(wcm_code);
mz_popr_x();
mz_popr_x();
END_JIT_DATA(18);
@ -11745,6 +11749,133 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
}
}
/* wcm_[nontail_]code */
/* key and value are on runstack */
{
GC_CAN_IGNORE jit_insn *refloop, *ref, *ref2, *ref3, *ref4, *ref5, *ref7, *ref8;
wcm_code = jit_get_ip().ptr;
mz_prolog(JIT_R2);
(void)mz_tl_ldi_p(JIT_R2, tl_scheme_current_cont_mark_stack);
/* R2 has counter for search */
refloop = _jit.x.pc;
(void)mz_tl_ldi_p(JIT_R1, tl_scheme_current_thread);
jit_ldxi_i(JIT_R0, JIT_R1, &((Scheme_Thread *)0x0)->cont_mark_stack_bottom);
ref = jit_bler_i(jit_forward(), JIT_R2, JIT_R0); /* => double-check meta-continuation */
CHECK_LIMIT();
jit_subi_l(JIT_R2, JIT_R2, 1);
jit_ldxi_p(JIT_R0, JIT_R1, &((Scheme_Thread *)0x0)->cont_mark_stack_segments);
jit_rshi_l(JIT_V1, JIT_R2, SCHEME_LOG_MARK_SEGMENT_SIZE);
jit_lshi_l(JIT_V1, JIT_V1, JIT_LOG_WORD_SIZE);
jit_ldxr_p(JIT_R0, JIT_R0, JIT_V1); /* R0 now points to the right array */
CHECK_LIMIT();
jit_andi_l(JIT_V1, JIT_R2, SCHEME_MARK_SEGMENT_MASK);
jit_movi_l(JIT_R1, sizeof(Scheme_Cont_Mark));
jit_mulr_l(JIT_V1, JIT_V1, JIT_R1);
jit_addr_l(JIT_R0, JIT_R0, JIT_V1);
CHECK_LIMIT();
/* R0 now points to the right record */
(void)mz_tl_ldi_l(JIT_R1, tl_scheme_current_cont_mark_pos);
jit_ldxi_l(JIT_V1, JIT_R0, &((Scheme_Cont_Mark *)0x0)->pos);
ref2 = jit_bltr_l(jit_forward(), JIT_V1, JIT_R1); /* => try to allocate new slot */
jit_ldxi_p(JIT_R1, JIT_RUNSTACK, WORDS_TO_BYTES(1));
jit_ldxi_p(JIT_V1, JIT_R0, &((Scheme_Cont_Mark *)0x0)->key);
ref3 = jit_beqr_p(jit_forward(), JIT_V1, JIT_R1); /* => found right destination */
CHECK_LIMIT();
(void)jit_jmpi(refloop);
/* Double-check meta-continuation */
/* R1 has thread pointer */
mz_patch_branch(ref);
jit_ldxi_i(JIT_R0, JIT_R1, &((Scheme_Thread *)0x0)->cont_mark_pos_bottom);
(void)mz_tl_ldi_l(JIT_R2, tl_scheme_current_cont_mark_pos);
jit_subi_l(JIT_R2, JIT_R2, 2);
ref = jit_bner_i(jit_forward(), JIT_R2, JIT_R0); /* => try to allocate new slot */
jit_ldxi_p(JIT_R1, JIT_R1, &((Scheme_Thread *)0x0)->meta_continuation);
ref7 = jit_beqi_l(jit_forward(), JIT_R1, NULL); /* => try to allocate new slot */
/* we need to check a meta-continuation... take the slow path. */
ref8 = jit_jmpi(jit_forward());
CHECK_LIMIT();
/* Entry point when we know we're not in non-tail position with respect
to any enclosing wcm: */
wcm_nontail_code = jit_get_ip().ptr;
mz_prolog(JIT_R2);
/* Try to allocate new slot: */
mz_patch_branch(ref);
mz_patch_branch(ref2);
mz_patch_branch(ref7);
(void)mz_tl_ldi_p(JIT_R2, tl_scheme_current_cont_mark_stack);
jit_rshi_l(JIT_V1, JIT_R2, SCHEME_LOG_MARK_SEGMENT_SIZE - JIT_LOG_WORD_SIZE);
(void)mz_tl_ldi_p(JIT_R1, tl_scheme_current_thread);
jit_ldxi_i(JIT_R0, JIT_R1, &((Scheme_Thread *)0x0)->cont_mark_seg_count);
ref4 = jit_bger_i(jit_forward(), JIT_V1, JIT_R0); /* => take slow path */
CHECK_LIMIT();
jit_ldxi_p(JIT_R0, JIT_R1, &((Scheme_Thread *)0x0)->cont_mark_stack_segments);
jit_rshi_l(JIT_V1, JIT_R2, SCHEME_LOG_MARK_SEGMENT_SIZE);
jit_lshi_l(JIT_V1, JIT_V1, JIT_LOG_WORD_SIZE);
jit_ldxr_p(JIT_R0, JIT_R0, JIT_V1);
CHECK_LIMIT();
/* R0 now points to the right array */
jit_andi_l(JIT_V1, JIT_R2, SCHEME_MARK_SEGMENT_MASK);
jit_movi_l(JIT_R1, sizeof(Scheme_Cont_Mark));
jit_mulr_l(JIT_V1, JIT_V1, JIT_R1);
jit_addr_l(JIT_R0, JIT_R0, JIT_V1);
CHECK_LIMIT();
/* R0 now points to the right record */
/* Increment counter: */
jit_addi_l(JIT_R2, JIT_R2, 1);
mz_tl_sti_p(tl_scheme_current_cont_mark_stack, JIT_R2, JIT_R1);
/* Fill in record at R0: */
mz_patch_branch(ref3);
(void)mz_tl_ldi_l(JIT_R1, tl_scheme_current_cont_mark_pos);
jit_stxi_l(&((Scheme_Cont_Mark *)0x0)->pos, JIT_R0, JIT_R1);
jit_ldxi_p(JIT_R1, JIT_RUNSTACK, WORDS_TO_BYTES(1));
jit_stxi_p(&((Scheme_Cont_Mark *)0x0)->key, JIT_R0, JIT_R1);
jit_ldxi_p(JIT_R1, JIT_RUNSTACK, WORDS_TO_BYTES(0));
jit_stxi_p(&((Scheme_Cont_Mark *)0x0)->val, JIT_R0, JIT_R1);
jit_movi_p(JIT_R1, NULL);
jit_stxi_p(&((Scheme_Cont_Mark *)0x0)->cache, JIT_R0, JIT_R1);
ref5 = jit_jmpi(jit_forward());
CHECK_LIMIT();
/* slow path: */
mz_patch_branch(ref4);
mz_patch_ucbranch(ref8);
JIT_UPDATE_THREAD_RSPTR_IF_NEEDED();
jit_ldxi_p(JIT_R0, JIT_RUNSTACK, WORDS_TO_BYTES(0));
jit_ldxi_p(JIT_V1, JIT_RUNSTACK, WORDS_TO_BYTES(1));
CHECK_LIMIT();
mz_prepare(2);
jit_pusharg_p(JIT_R0);
jit_pusharg_p(JIT_V1);
(void)mz_finish(scheme_set_cont_mark);
CHECK_LIMIT();
mz_patch_ucbranch(ref5);
mz_epilog(JIT_R2);
register_sub_func(jitter, wcm_code, scheme_false);
}
return 1;
}

78
src/mzscheme/src/jit_ts.c
View File

@ -16,8 +16,8 @@
define_ts_siS_s(_scheme_apply_multi_from_native, FSRC_RATOR)
define_ts_siS_s(_scheme_apply_from_native, FSRC_RATOR)
define_ts_siS_s(_scheme_tail_apply_from_native, FSRC_RATOR)
define_ts_s_s(scheme_force_value_same_mark, FSRC_OTHER)
define_ts_s_s(scheme_force_one_value_same_mark, FSRC_OTHER)
define_ts_s_s(scheme_force_value_same_mark, FSRC_MARKS)
define_ts_s_s(scheme_force_one_value_same_mark, FSRC_MARKS)
#if defined(INLINE_FP_OPS) && !defined(CAN_INLINE_ALLOC)
define_ts__s(malloc_double, FSRC_OTHER)
#endif
@ -41,46 +41,45 @@ define_ts_z_p(GC_malloc_one_small_tagged, FSRC_OTHER)
#endif
define_ts_n_s(scheme_make_native_closure, FSRC_OTHER)
define_ts_n_s(scheme_make_native_case_closure, FSRC_OTHER)
define_ts_bsi_v(call_set_global_bucket, FSRC_OTHER)
define_ts_bsi_v(call_set_global_bucket, FSRC_MARKS)
define_ts_s_s(scheme_make_envunbox, FSRC_OTHER)
define_ts_s_s(make_global_ref, FSRC_OTHER)
define_ts_iiS_v(lexical_binding_wrong_return_arity, FSRC_OTHER)
define_ts_ss_m(scheme_set_cont_mark, FSRC_OTHER)
define_ts_iiS_v(call_wrong_return_arity, FSRC_OTHER)
define_ts_b_v(scheme_unbound_global, FSRC_OTHER)
define_ts_iiS_v(lexical_binding_wrong_return_arity, FSRC_MARKS)
define_ts_iiS_v(call_wrong_return_arity, FSRC_MARKS)
define_ts_b_v(scheme_unbound_global, FSRC_MARKS)
define_ts_Sl_s(scheme_delayed_rename, FSRC_OTHER)
define_ts_iS_s(scheme_checked_car, FSRC_OTHER)
define_ts_iS_s(scheme_checked_cdr, FSRC_OTHER)
define_ts_iS_s(scheme_checked_caar, FSRC_OTHER)
define_ts_iS_s(scheme_checked_cadr, FSRC_OTHER)
define_ts_iS_s(scheme_checked_cdar, FSRC_OTHER)
define_ts_iS_s(scheme_checked_cddr, FSRC_OTHER)
define_ts_iS_s(scheme_checked_mcar, FSRC_OTHER)
define_ts_iS_s(scheme_checked_mcdr, FSRC_OTHER)
define_ts_iS_s(scheme_checked_set_mcar, FSRC_OTHER)
define_ts_iS_s(scheme_checked_set_mcdr, FSRC_OTHER)
define_ts_s_s(scheme_unbox, FSRC_OTHER)
define_ts_s_s(scheme_vector_length, FSRC_OTHER)
define_ts_s_s(scheme_flvector_length, FSRC_OTHER)
define_ts_si_s(scheme_struct_ref, FSRC_OTHER)
define_ts_sis_v(scheme_struct_set, FSRC_OTHER)
define_ts_s_s(tail_call_with_values_from_multiple_result, FSRC_OTHER)
define_ts_s_v(raise_bad_call_with_values, FSRC_OTHER)
define_ts_s_s(call_with_values_from_multiple_result_multi, FSRC_OTHER)
define_ts_s_s(call_with_values_from_multiple_result, FSRC_OTHER)
define_ts_iS_s(scheme_checked_vector_ref, FSRC_OTHER)
define_ts_iS_s(scheme_checked_vector_set, FSRC_OTHER)
define_ts_iS_s(scheme_checked_string_ref, FSRC_OTHER)
define_ts_iS_s(scheme_checked_string_set, FSRC_OTHER)
define_ts_iS_s(scheme_checked_byte_string_ref, FSRC_OTHER)
define_ts_iS_s(scheme_checked_byte_string_set, FSRC_OTHER)
define_ts_iS_s(scheme_checked_flvector_ref, FSRC_OTHER)
define_ts_iS_s(scheme_checked_flvector_set, FSRC_OTHER)
define_ts_iS_s(scheme_checked_syntax_e, FSRC_OTHER)
define_ts_iS_s(scheme_extract_checked_procedure, FSRC_OTHER)
define_ts_S_s(apply_checked_fail, FSRC_OTHER)
define_ts_iS_s(scheme_checked_car, FSRC_MARKS)
define_ts_iS_s(scheme_checked_cdr, FSRC_MARKS)
define_ts_iS_s(scheme_checked_caar, FSRC_MARKS)
define_ts_iS_s(scheme_checked_cadr, FSRC_MARKS)
define_ts_iS_s(scheme_checked_cdar, FSRC_MARKS)
define_ts_iS_s(scheme_checked_cddr, FSRC_MARKS)
define_ts_iS_s(scheme_checked_mcar, FSRC_MARKS)
define_ts_iS_s(scheme_checked_mcdr, FSRC_MARKS)
define_ts_iS_s(scheme_checked_set_mcar, FSRC_MARKS)
define_ts_iS_s(scheme_checked_set_mcdr, FSRC_MARKS)
define_ts_s_s(scheme_unbox, FSRC_MARKS)
define_ts_s_s(scheme_vector_length, FSRC_MARKS)
define_ts_s_s(scheme_flvector_length, FSRC_MARKS)
define_ts_si_s(scheme_struct_ref, FSRC_MARKS)
define_ts_sis_v(scheme_struct_set, FSRC_MARKS)
define_ts_s_s(tail_call_with_values_from_multiple_result, FSRC_MARKS)
define_ts_s_v(raise_bad_call_with_values, FSRC_MARKS)
define_ts_s_s(call_with_values_from_multiple_result_multi, FSRC_MARKS)
define_ts_s_s(call_with_values_from_multiple_result, FSRC_MARKS)
define_ts_iS_s(scheme_checked_vector_ref, FSRC_MARKS)
define_ts_iS_s(scheme_checked_vector_set, FSRC_MARKS)
define_ts_iS_s(scheme_checked_string_ref, FSRC_MARKS)
define_ts_iS_s(scheme_checked_string_set, FSRC_MARKS)
define_ts_iS_s(scheme_checked_byte_string_ref, FSRC_MARKS)
define_ts_iS_s(scheme_checked_byte_string_set, FSRC_MARKS)
define_ts_iS_s(scheme_checked_flvector_ref, FSRC_MARKS)
define_ts_iS_s(scheme_checked_flvector_set, FSRC_MARKS)
define_ts_iS_s(scheme_checked_syntax_e, FSRC_MARKS)
define_ts_iS_s(scheme_extract_checked_procedure, FSRC_MARKS)
define_ts_S_s(apply_checked_fail, FSRC_MARKS)
define_ts_iSi_s(scheme_build_list_offset, FSRC_OTHER)
define_ts_siS_v(wrong_argument_count, FSRC_OTHER)
define_ts_siS_v(wrong_argument_count, FSRC_MARKS)
#else
# define ts__scheme_apply_multi_from_native _scheme_apply_multi_from_native
# define ts__scheme_apply_from_native _scheme_apply_from_native
@ -110,7 +109,6 @@ define_ts_siS_v(wrong_argument_count, FSRC_OTHER)
# define ts_scheme_make_envunbox scheme_make_envunbox
# define ts_make_global_ref make_global_ref
# define ts_lexical_binding_wrong_return_arity lexical_binding_wrong_return_arity
# define ts_scheme_set_cont_mark scheme_set_cont_mark
# define ts_call_wrong_return_arity call_wrong_return_arity
# define ts_scheme_unbound_global scheme_unbound_global
# define ts_scheme_delayed_rename scheme_delayed_rename
@ -127,6 +125,8 @@ define_ts_siS_v(wrong_argument_count, FSRC_OTHER)
# define ts_scheme_unbox scheme_unbox
# define ts_scheme_vector_length scheme_vector_length
# define ts_scheme_flvector_length scheme_flvector_length
# define ts_scheme_struct_ref scheme_struct_ref
# define ts_scheme_struct_set scheme_struct_set
# define ts_tail_call_with_values_from_multiple_result tail_call_with_values_from_multiple_result
# define ts_raise_bad_call_with_values raise_bad_call_with_values
# define ts_call_with_values_from_multiple_result_multi call_with_values_from_multiple_result_multi

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

@ -5589,6 +5589,7 @@ static int future_MARK(void *p, struct NewGC *gc) {
gcMARK2(f->arg_S1, gc);
gcMARK2(f->arg_s2, gc);
gcMARK2(f->arg_S2, gc);
gcMARK2(f->arg_p, gc);
gcMARK2(f->retval_s, gc);
gcMARK2(f->retval, gc);
gcMARK2(f->multiple_array, gc);
@ -5612,6 +5613,7 @@ static int future_FIXUP(void *p, struct NewGC *gc) {
gcFIXUP2(f->arg_S1, gc);
gcFIXUP2(f->arg_s2, gc);
gcFIXUP2(f->arg_S2, gc);
gcFIXUP2(f->arg_p, gc);
gcFIXUP2(f->retval_s, gc);
gcFIXUP2(f->retval, gc);
gcFIXUP2(f->multiple_array, gc);

1
src/mzscheme/src/mzmarksrc.c
View File

@ -2294,6 +2294,7 @@ future {
gcMARK2(f->arg_S1, gc);
gcMARK2(f->arg_s2, gc);
gcMARK2(f->arg_S2, gc);
gcMARK2(f->arg_p, gc);
gcMARK2(f->retval_s, gc);
gcMARK2(f->retval, gc);
gcMARK2(f->multiple_array, gc);

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

@ -600,6 +600,8 @@ extern Scheme_Object *scheme_apply_thread_thunk(Scheme_Object *rator);
#define GLOB_HAS_HOME_PTR 32
/* Scheme-level constant (cannot be changed further): */
#define GLOB_IS_IMMUTATED 64
/* Linked from other (cannot be undefined): */
#define GLOB_IS_LINKED 128
typedef struct {
Scheme_Bucket bucket;
@ -1249,6 +1251,8 @@ typedef struct Scheme_Cont_Mark {
MZ_MARK_POS_TYPE pos; /* Odd numbers - so they look like non-pointers */
} Scheme_Cont_Mark;
void scheme_new_mark_segment(Scheme_Thread *p);
typedef struct Scheme_Cont_Mark_Chain {
Scheme_Inclhash_Object iso; /* 0x1 => next is from different meta-continuation */
Scheme_Object *key;
@ -2216,6 +2220,7 @@ Scheme_Object *scheme_lookup_binding(Scheme_Object *symbol, Scheme_Comp_Env *env
Scheme_Object *certs, Scheme_Object *in_modidx,
Scheme_Env **_menv, int *_protected,
Scheme_Object **_lexical_binding_id);
int scheme_is_imported(Scheme_Object *var, Scheme_Comp_Env *env);
Scheme_Object *scheme_extract_unsafe(Scheme_Object *o);
Scheme_Object *scheme_extract_flfxnum(Scheme_Object *o);
@ -2268,7 +2273,8 @@ void scheme_delay_load_closure(Scheme_Closure_Data *data);
Scheme_Object *scheme_compiled_void(void);
Scheme_Object *scheme_register_toplevel_in_prefix(Scheme_Object *var, Scheme_Comp_Env *env,
Scheme_Compile_Info *rec, int drec);
Scheme_Compile_Info *rec, int drec,
int imported);
Scheme_Object *scheme_register_stx_in_prefix(Scheme_Object *var, Scheme_Comp_Env *env,
Scheme_Compile_Info *rec, int drec);
void scheme_register_unsafe_in_prefix(Scheme_Comp_Env *env,

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

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "4.2.5.3"
#define MZSCHEME_VERSION "4.2.5.4"
#define MZSCHEME_VERSION_X 4
#define MZSCHEME_VERSION_Y 2
#define MZSCHEME_VERSION_Z 5
#define MZSCHEME_VERSION_W 3
#define MZSCHEME_VERSION_W 4
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

42
src/mzscheme/src/syntax.c
View File

@ -640,7 +640,8 @@ void scheme_set_global_bucket(char *who, Scheme_Bucket *b, Scheme_Object *val,
{
if ((b->val || set_undef)
&& ((b->so.type != scheme_variable_type)
|| !(((Scheme_Bucket_With_Flags *)b)->flags & GLOB_IS_IMMUTATED)))
|| !(((Scheme_Bucket_With_Flags *)b)->flags & GLOB_IS_IMMUTATED))
&& (val || !(((Scheme_Bucket_With_Flags *)b)->flags & GLOB_IS_LINKED)))
b->val = val;
else {
if (((Scheme_Bucket_With_Home *)b)->home->module) {
@ -658,17 +659,21 @@ void scheme_set_global_bucket(char *who, Scheme_Bucket *b, Scheme_Object *val,
msg,
who,
(b->val
? (is_set
? "modify a constant"
: "re-define a constant")
: "set identifier before its definition"),
? (!val
? "undefine variable that is used by other modules"
: (is_set
? "modify a constant"
: "re-define a constant"))
: "set variable before its definition"),
(Scheme_Object *)b->key,
((Scheme_Bucket_With_Home *)b)->home->module->modname);
} else {
scheme_raise_exn(MZEXN_FAIL_CONTRACT_VARIABLE, b->key,
"%s: cannot %s identifier: %S",
"%s: cannot %s variable: %S",
who,
b->val ? "change constant" : "set undefined",
(val
? (b->val ? "change constant" : "set undefined")
: "undefine"),
(Scheme_Object *)b->key);
}
}
@ -1124,7 +1129,7 @@ defn_targets_syntax (Scheme_Object *var, Scheme_Comp_Env *env, Scheme_Compile_In
-1, env->genv->mod_phase);
}
/* Get indirection through the prefix: */
bucket = scheme_register_toplevel_in_prefix(bucket, env, rec, drec);
bucket = scheme_register_toplevel_in_prefix(bucket, env, rec, drec, 0);
pr = cons(bucket, scheme_null);
if (last)
@ -1729,7 +1734,7 @@ set_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec,
if (SAME_TYPE(SCHEME_TYPE(var), scheme_variable_type)
|| SAME_TYPE(SCHEME_TYPE(var), scheme_module_variable_type)) {
var = scheme_register_toplevel_in_prefix(var, env, rec, drec);
var = scheme_register_toplevel_in_prefix(var, env, rec, drec, 0);
if (env->genv->module)
SCHEME_TOPLEVEL_FLAGS(var) |= SCHEME_TOPLEVEL_MUTATED;
}
@ -1987,23 +1992,10 @@ ref_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec,
if (SAME_TYPE(SCHEME_TYPE(var), scheme_variable_type)
|| SAME_TYPE(SCHEME_TYPE(var), scheme_module_variable_type)) {
int imported = 0;
/* It must be in the module being compiled/expanded. */
if (env->genv->module) {
if (SAME_TYPE(SCHEME_TYPE(var), scheme_module_variable_type)) {
if (!SAME_OBJ(((Module_Variable *)var)->modidx, env->genv->module->self_modidx))
imported = 1;
} else
imported = 1;
} else {
if (SAME_TYPE(SCHEME_TYPE(var), scheme_variable_type)) {
if (!SAME_OBJ(((Scheme_Bucket_With_Home *)var)->home, env->genv))
imported = 1;
} else
imported = 1;
}
imported = scheme_is_imported(var, env);
if (rec[drec].comp) {
var = scheme_register_toplevel_in_prefix(var, env, rec, drec);
var = scheme_register_toplevel_in_prefix(var, env, rec, drec, 0);
if (!imported && env->genv->module)
SCHEME_TOPLEVEL_FLAGS(var) |= SCHEME_TOPLEVEL_MUTATED;
}
@ -5858,7 +5850,7 @@ Scheme_Object *scheme_make_environment_dummy(Scheme_Comp_Env *env)
/* Get a prefixed-based accessor for a dummy top-level bucket. It's
used to "link" to the right environment at run time. The #f as
a toplevel is handled in the prefix linker specially. */
return scheme_register_toplevel_in_prefix(scheme_false, env, NULL, 0);
return scheme_register_toplevel_in_prefix(scheme_false, env, NULL, 0, 0);
}
Scheme_Env *scheme_environment_from_dummy(Scheme_Object *dummy)