From 417be5d8e2726c12f84e7e3fa6f24aa74f463abc Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 30 Mar 2010 20:21:28 +0000 Subject: [PATCH] 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 svn: r18678 --- collects/errortrace/errortrace-lib.ss | 1 + collects/errortrace/lang/body.ss | 20 + collects/errortrace/lang/reader.ss | 30 + .../errortrace/scribblings/errortrace.scrbl | 8 + collects/errortrace/stacktrace.ss | 560 +++++++++--------- collects/tests/future/future.ss | 50 +- src/mzscheme/src/env.c | 23 +- src/mzscheme/src/eval.c | 94 ++- src/mzscheme/src/future.c | 190 ++++-- src/mzscheme/src/future.h | 15 +- src/mzscheme/src/jit.c | 179 +++++- src/mzscheme/src/jit_ts.c | 78 +-- src/mzscheme/src/mzmark.c | 2 + src/mzscheme/src/mzmarksrc.c | 1 + src/mzscheme/src/schpriv.h | 8 +- src/mzscheme/src/schvers.h | 4 +- src/mzscheme/src/syntax.c | 42 +- 17 files changed, 842 insertions(+), 463 deletions(-) create mode 100644 collects/errortrace/lang/body.ss create mode 100644 collects/errortrace/lang/reader.ss diff --git a/collects/errortrace/errortrace-lib.ss b/collects/errortrace/errortrace-lib.ss index 9fa0f402e4..364f671256 100644 --- a/collects/errortrace/errortrace-lib.ss +++ b/collects/errortrace/errortrace-lib.ss @@ -8,6 +8,7 @@ scheme/contract scheme/unit scheme/runtime-path + (for-template scheme/base) (for-syntax scheme/base)) (define oprintf diff --git a/collects/errortrace/lang/body.ss b/collects/errortrace/lang/body.ss new file mode 100644 index 0000000000..c89d5b359e --- /dev/null +++ b/collects/errortrace/lang/body.ss @@ -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)]))])) diff --git a/collects/errortrace/lang/reader.ss b/collects/errortrace/lang/reader.ss new file mode 100644 index 0000000000..b0f8dc71fd --- /dev/null +++ b/collects/errortrace/lang/reader.ss @@ -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))) diff --git a/collects/errortrace/scribblings/errortrace.scrbl b/collects/errortrace/scribblings/errortrace.scrbl index 92fbe8514d..aea23f9b09 100644 --- a/collects/errortrace/scribblings/errortrace.scrbl +++ b/collects/errortrace/scribblings/errortrace.scrbl @@ -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} diff --git a/collects/errortrace/stacktrace.ss b/collects/errortrace/stacktrace.ss index 3d5e69db48..5b68746492 100644 --- a/collects/errortrace/stacktrace.ss +++ b/collects/errortrace/stacktrace.ss @@ -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))) diff --git a/collects/tests/future/future.ss b/collects/tests/future/future.ss index 761b14b93c..69fd4463c5 100644 --- a/collects/tests/future/future.ss +++ b/collects/tests/future/future.ss @@ -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)))) diff --git a/src/mzscheme/src/env.c b/src/mzscheme/src/env.c index 9d15f93356..63edb919ad 100644 --- a/src/mzscheme/src/env.c +++ b/src/mzscheme/src/env.c @@ -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; diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index 64a5bfeeaa..433b7df1e3 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -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 @@ -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]; diff --git a/src/mzscheme/src/future.c b/src/mzscheme/src/future.c index 2c8e8e1ac4..ea0a90b2e0 100644 --- a/src/mzscheme/src/future.c +++ b/src/mzscheme/src/future.c @@ -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); diff --git a/src/mzscheme/src/future.h b/src/mzscheme/src/future.h index 7e6a9b494f..751085e3f2 100644 --- a/src/mzscheme/src/future.h +++ b/src/mzscheme/src/future.h @@ -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 diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c index 211d407f0f..a303552e52 100644 --- a/src/mzscheme/src/jit.c +++ b/src/mzscheme/src/jit.c @@ -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; } diff --git a/src/mzscheme/src/jit_ts.c b/src/mzscheme/src/jit_ts.c index b2b66c2e7d..50e8fafaf0 100644 --- a/src/mzscheme/src/jit_ts.c +++ b/src/mzscheme/src/jit_ts.c @@ -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 diff --git a/src/mzscheme/src/mzmark.c b/src/mzscheme/src/mzmark.c index 1c0210a27d..fd4c86c588 100644 --- a/src/mzscheme/src/mzmark.c +++ b/src/mzscheme/src/mzmark.c @@ -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); diff --git a/src/mzscheme/src/mzmarksrc.c b/src/mzscheme/src/mzmarksrc.c index e7a2538c15..2a3a6d771a 100644 --- a/src/mzscheme/src/mzmarksrc.c +++ b/src/mzscheme/src/mzmarksrc.c @@ -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); diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index dcc6e14287..9cc124afcf 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -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, diff --git a/src/mzscheme/src/schvers.h b/src/mzscheme/src/schvers.h index 78095ec7fd..3b2cffeec1 100644 --- a/src/mzscheme/src/schvers.h +++ b/src/mzscheme/src/schvers.h @@ -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) diff --git a/src/mzscheme/src/syntax.c b/src/mzscheme/src/syntax.c index d1b4ed06b7..0b7bc83c84 100644 --- a/src/mzscheme/src/syntax.c +++ b/src/mzscheme/src/syntax.c @@ -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)