diff --git a/collects/compiler/mzc.h b/collects/compiler/mzc.h index 472b23d802..6d24a04498 100644 --- a/collects/compiler/mzc.h +++ b/collects/compiler/mzc.h @@ -9,6 +9,36 @@ "invoke-unit: cannot link to undefined identifier: %S", \ (Scheme_Object*)(x)->key); +#ifdef NO_INLINE_KEYWORD +# define MZC_INLINE /* */ +#else +# define MZC_INLINE MSC_IZE(inline) +#endif + +#define MZC_GLOBAL_PREPARE(vec, pos) (SCHEME_VEC_ELS(vec)[pos] = SCHEME_PTR_VAL(SCHEME_VEC_ELS(vec)[pos])) +static MZC_INLINE Scheme_Object *MZC_GLOBAL_LOOKUP(Scheme_Object *vec, int pos) { + Scheme_Bucket *bucket = (Scheme_Bucket *)SCHEME_VEC_ELS(vec)[pos]; + Scheme_Object *o = bucket->val; + if (o) + return o; + else { + scheme_unbound_global(bucket); + return NULL; + } +} + +static MZC_INLINE Scheme_Object *MZC_GLOBAL_ASSIGN(Scheme_Object *vec, int pos, Scheme_Object *val) { + Scheme_Bucket *bucket = (Scheme_Bucket *)SCHEME_VEC_ELS(vec)[pos]; + scheme_set_global_bucket("set!", bucket, val, 0); + return scheme_void; +} + +#define MZC_KNOWN_SAFE_VECTOR_REF(vec, pos) (SCHEME_VEC_ELS(vec)[pos]) + +#define MZC_APPLY_MAGIC(val, n) \ + scheme_eval_compiled_sized_string_with_magic(top_level_bytecode_ ## n, sizeof(top_level_bytecode_ ## n), NULL, \ + scheme_intern_symbol(top_level_magic_sym_ ## n), val, 1) + #define DO_FUEL_POLL ((scheme_fuel_counter-- <= 0) ? (scheme_process_block(0), 0) : 0) #define _scheme_direct_apply_primitive_multi_poll(prim, argc, argv) \ diff --git a/collects/compiler/private/analyze.ss b/collects/compiler/private/analyze.ss index 2ac57e6482..f1ef80f216 100644 --- a/collects/compiler/private/analyze.ss +++ b/collects/compiler/private/analyze.ss @@ -167,19 +167,15 @@ (define compiler:define-list null) (define compiler:per-load-define-list null) - (define compiler:per-invoke-define-list null) (define compiler:local-define-list null) (define compiler:local-per-load-define-list null) - (define compiler:local-per-invoke-define-list null) (define (compiler:get-define-list) compiler:define-list) (define (compiler:get-per-load-define-list) compiler:per-load-define-list) - (define (compiler:get-per-invoke-define-list) compiler:per-invoke-define-list) (define (compiler:init-define-lists!) (set! compiler:define-list null) (set! compiler:per-load-define-list null) - (set! compiler:per-invoke-define-list null) (set! compiler:global-symbols (make-hash-table)) (set! compiler:primitive-refs empty-set)) @@ -189,14 +185,10 @@ (define (compiler:add-local-per-load-define-list! def) (set! compiler:local-per-load-define-list (cons def compiler:local-per-load-define-list))) - (define (compiler:add-local-per-invoke-define-list! def) - (set! compiler:local-per-invoke-define-list - (cons def compiler:local-per-invoke-define-list))) (define (prepare-local-lists) (set! compiler:local-define-list null) - (set! compiler:local-per-load-define-list null) - (set! compiler:local-per-invoke-define-list null)) + (set! compiler:local-per-load-define-list null)) (define (move-over-local-lists) (set! compiler:define-list @@ -205,38 +197,9 @@ (set! compiler:per-load-define-list (append! compiler:per-load-define-list (reverse! compiler:local-per-load-define-list))) - (set! compiler:per-invoke-define-list - (append! compiler:per-invoke-define-list - (reverse! compiler:local-per-invoke-define-list))) (set! compiler:local-define-list null) - (set! compiler:local-per-load-define-list null) - (set! compiler:local-per-invoke-define-list null)) - - (define (compiler:finish-syntax-constants!) - (set! compiler:local-define-list null) - (set! compiler:local-per-load-define-list null) - (set! compiler:local-per-invoke-define-list null) - - (begin0 - ;; Return this result - it's a number - (const:finish-syntax-constants!) - - (unless (and (null? compiler:local-per-load-define-list) - (null? compiler:local-per-invoke-define-list)) - (set! compiler:define-list - (append! compiler:define-list - (reverse! compiler:local-define-list))) - (set! compiler:per-load-define-list - (append! compiler:per-load-define-list - (reverse! compiler:local-per-load-define-list))) - (set! compiler:per-invoke-define-list - (append! compiler:per-invoke-define-list - (reverse! compiler:local-per-invoke-define-list))) - - (set! compiler:local-define-list null) - (set! compiler:local-per-load-define-list null) - (set! compiler:local-per-invoke-define-list null)))) + (set! compiler:local-per-load-define-list null)) ;; Temporary structure used in building up case-lambda info (define-struct case-info @@ -429,6 +392,9 @@ (+ size 1) (lambda (size) (bloop size (cdr exprs))))))] + [(zodiac:global-lookup? body) (k size)] + [(zodiac:safe-vector-ref? body) (k size)] + [(zodiac:global-assign? body) (loop (zodiac:global-assign-expr body) env (+ size 1) k)] [else (* 2 (compiler:option:max-inline-size))])))) ;; We copy inlined bodies to generate unique structure values @@ -538,6 +504,25 @@ (make-empty-box) (map (lambda (x) (copy-inlined-body x binding-map)) (zodiac:begin-form-bodies ast)))] + [(zodiac:global-lookup? ast) + (zodiac:make-global-lookup + (zodiac:zodiac-stx ast) + (make-empty-box) + (copy-inlined-body (zodiac:global-lookup-vec ast) binding-map) + (zodiac:global-lookup-pos ast))] + [(zodiac:safe-vector-ref? ast) + (zodiac:make-safe-vector-ref + (zodiac:zodiac-stx ast) + (make-empty-box) + (copy-inlined-body (zodiac:safe-vector-ref-vec ast) binding-map) + (zodiac:safe-vector-ref-pos ast))] + [(zodiac:global-assign? ast) + (zodiac:make-global-assign + (zodiac:zodiac-stx ast) + (make-empty-box) + (copy-inlined-body (zodiac:global-assign-vec ast) binding-map) + (zodiac:global-assign-pos ast) + (copy-inlined-body (zodiac:global-assign-expr ast) binding-map))] [else (compiler:internal-error ast (format "copy-inlined-body: can't copy ~a" @@ -749,9 +734,6 @@ (when (and (zodiac:varref? c) (varref:has-attribute? c varref:per-load-static)) (add-global-var! const:the-per-load-statics-table)) - (when (and (zodiac:varref? c) - (varref:has-attribute? c varref:per-invoke-static)) - (add-global-var! (varref:invoke-module ast))) c)] @@ -793,8 +775,6 @@ (compiler:add-primitive-varref! ast)] [(varref:has-attribute? ast varref:per-load-static) (add-global-var! const:the-per-load-statics-table)] - [(varref:has-attribute? ast varref:per-invoke-static) - (add-global-var! (varref:invoke-module ast))] [(varref:has-attribute? ast varref:static) (void)] [else @@ -834,9 +814,6 @@ (when (and (zodiac:top-level-varref? ret) (varref:has-attribute? ret varref:per-load-static)) (add-global-var! const:the-per-load-statics-table)) - (when (and (zodiac:top-level-varref? ret) - (varref:has-attribute? ret varref:per-invoke-static)) - (add-global-var! (varref:invoke-module ret))) ret))] @@ -1060,7 +1037,6 @@ ;; can't eliminiate if a letrec->let variable (not (binding-letrec-set? binding)) ;; can't eliminate if it is used by a bad application - ;; or by invoke (not (binding-known-but-used? binding))) ;; discard the let: @@ -1248,10 +1224,9 @@ (zodiac:set-define-values-form-vars! ast (map (lambda (v) - (let ([v (if (varref:current-invoke-module) - v - ;; Make sure v is not mapped to an import: - (ensure-top-level v))]) + (let ([v + ;; Make sure v is not mapped to an import: + (ensure-top-level v)]) (analyze-varref! v env #f #t))) (zodiac:define-values-form-vars ast))) @@ -1365,32 +1340,32 @@ (values ast body-multi))] - ;;----------------------------------------------------------------- - ;; QUOTE-SYNTAX - ;; - ;; Construct constant. - ;; - [(zodiac:quote-syntax-form? ast) - (let ([ret (const:make-syntax-constant (zodiac:quote-syntax-form-expr ast))]) - ;; Put a pointer to the constructed constant in the quote-form's backbox - (set-annotation! ast ret) - - ;; This variable is per-load: - (add-global-var! const:the-per-load-statics-table) - - (values ret #f))] - ;;----------------------------------------------------------- - ;; MODULE + ;; GLOBALS ;; - [(zodiac:module-form? ast) - - (zodiac:set-module-form-body! + [(zodiac:global-prepare? ast) + (zodiac:set-global-prepare-vec! ast - (analyze!-ast (zodiac:module-form-body ast) env inlined)) - + (analyze!-ast (zodiac:global-prepare-vec ast) env inlined)) + (values ast #f)] + [(zodiac:global-lookup? ast) + (zodiac:set-global-lookup-vec! + ast + (analyze!-ast (zodiac:global-lookup-vec ast) env inlined)) + (values ast #f)] + [(zodiac:global-assign? ast) + (zodiac:set-global-assign-vec! + ast + (analyze!-ast (zodiac:global-assign-vec ast) env inlined)) + (zodiac:set-global-assign-expr! + ast + (analyze!-ast (zodiac:global-assign-expr ast) env inlined)) + (values ast #f)] + [(zodiac:safe-vector-ref? ast) + (zodiac:set-safe-vector-ref-vec! + ast + (analyze!-ast (zodiac:safe-vector-ref-vec ast) env inlined)) (values ast #f)] - [else (compiler:internal-error ast diff --git a/collects/compiler/private/anorm.ss b/collects/compiler/private/anorm.ss index e3c0b36f9c..4cd6408c08 100644 --- a/collects/compiler/private/anorm.ss +++ b/collects/compiler/private/anorm.ss @@ -268,25 +268,6 @@ (set-annotation! begin0-exp tbound) (k begin0-exp))] - ;;----------------------------------------------------------- - ;; MODULE - ;; - [(zodiac:module-form? ast) - (k (zodiac:make-module-form - (zodiac:zodiac-stx ast) - (zodiac:parsed-back ast) - (zodiac:module-form-name ast) - (zodiac:module-form-requires ast) - (zodiac:module-form-for-syntax-requires ast) - (zodiac:module-form-for-template-requires ast) - (a-normalize (zodiac:module-form-body ast) identity) - #f ; see split-module in driver.ss - (zodiac:module-form-provides ast) - (zodiac:module-form-syntax-provides ast) - (zodiac:module-form-indirect-provides ast) - (zodiac:module-form-kernel-reprovide-hint ast) - (zodiac:module-form-self-path-index ast)))] - ;;--------------------------------------------------------------- ;; SET! EXPRESSIONS / DEFINE EXPRESSIONS ;; @@ -310,6 +291,26 @@ (zodiac:define-values-form-vars ast) (a-normalize (zodiac:define-values-form-val ast) identity)))] + ;;----------------------------------------------------------- + ;; GLOBALS + ;; + [(zodiac:global-prepare? ast) + (k ast)] + [(zodiac:global-lookup? ast) + (k ast)] + [(zodiac:global-assign? ast) + (normalize-name + (zodiac:global-assign-expr ast) + (lambda (norm-expr) + (k (zodiac:make-global-assign + (zodiac:zodiac-stx ast) + (zodiac:parsed-back ast) + (zodiac:global-assign-vec ast) + (zodiac:global-assign-pos ast) + norm-expr))))] + [(zodiac:safe-vector-ref? ast) + (k ast)] + ;;---------------------------------------------------------- ;; DEFINE-SYNTAX ;; diff --git a/collects/compiler/private/closure.ss b/collects/compiler/private/closure.ss index b473c60382..e0a6e070c3 100644 --- a/collects/compiler/private/closure.ss +++ b/collects/compiler/private/closure.ss @@ -64,9 +64,7 @@ ;; Set the closure's liftable field to a new top-level-varref (let* ([code (get-annotation lam)] [var (gensym (if pls? - (if (varref:current-invoke-module) - 'pmilifted - 'pllifted) + 'pllifted 'lifted))] [sv (make-top-level-varref/bind-from-lift (zodiac:zodiac-stx lam) @@ -78,7 +76,7 @@ #f #f lam - (and pls? (or (varref:current-invoke-module) pls?)))] + pls?)] [def (zodiac:make-define-values-form (zodiac:zodiac-stx lam) (make-empty-box) @@ -92,32 +90,11 @@ (set-procedure-code-liftable! code (list sv)) (if pls? - (let ([def (if (varref:current-invoke-module) - (let ([def (zodiac:make-module-form - (zodiac:zodiac-stx def) - (make-empty-box) - #f #f #f #f - def #f - #f #f #f #f #f)]) - (set-annotation! - def - (let ([mi (varref:current-invoke-module)]) - (make-module-info mi - #f - (if (varref:module-invoke-syntax? mi) - 'syntax-body - 'body)))) - def) - def)]) - - (let ([mi (varref:current-invoke-module)]) - (varref:add-attribute! sv (or mi varref:per-load-static)) - ((if mi - (lambda (v) (compiler:add-per-invoke-static-list! v mi)) - compiler:add-per-load-static-list!) - var) - (set! compiler:once-closures-list (cons def compiler:once-closures-list)) - (set! compiler:once-closures-globals-list (cons (code-global-vars code) compiler:once-closures-globals-list)))) + (begin + (varref:add-attribute! sv varref:per-load-static) + (compiler:add-per-load-static-list! var) + (set! compiler:once-closures-list (cons def compiler:once-closures-list)) + (set! compiler:once-closures-globals-list (cons (code-global-vars code) compiler:once-closures-globals-list))) (begin (set! compiler:lifted-lambda-vars (cons sv compiler:lifted-lambda-vars)) (set! compiler:lifted-lambdas (cons def compiler:lifted-lambdas))))))) @@ -272,16 +249,32 @@ (transform! (zodiac:with-continuation-mark-form-body ast))) ast] - + ;;----------------------------------------------------------- - ;; MODULE + ;; GLOBALS ;; - [(zodiac:module-form? ast) - - (zodiac:set-module-form-body! + [(zodiac:global-prepare? ast) + (zodiac:set-global-prepare-vec! ast - (transform! (zodiac:module-form-body ast))) - + (transform! (zodiac:global-prepare-vec ast))) + ast] + [(zodiac:global-lookup? ast) + (zodiac:set-global-lookup-vec! + ast + (transform! (zodiac:global-lookup-vec ast))) + ast] + [(zodiac:global-assign? ast) + (zodiac:set-global-assign-vec! + ast + (transform! (zodiac:global-assign-vec ast))) + (zodiac:set-global-assign-expr! + ast + (transform! (zodiac:global-assign-expr ast))) + ast] + [(zodiac:safe-vector-ref? ast) + (zodiac:set-safe-vector-ref-vec! + ast + (transform! (zodiac:safe-vector-ref-vec ast))) ast] [else (compiler:internal-error diff --git a/collects/compiler/private/const.ss b/collects/compiler/private/const.ss index 69b0a3aa2d..f7c3470555 100644 --- a/collects/compiler/private/const.ss +++ b/collects/compiler/private/const.ss @@ -54,16 +54,12 @@ (define compiler:static-list null) (define compiler:per-load-static-list null) - (define compiler:per-invoke-static-list null) (define (compiler:get-static-list) compiler:static-list) (define (compiler:get-per-load-static-list) compiler:per-load-static-list) - (define (compiler:get-per-invoke-static-list) compiler:per-invoke-static-list) (define new-uninterned-symbols null) ; list of (cons sym pos) - (define syntax-strings null) ; list of syntax-string structs - (define (const:init-tables!) (set! const:symbol-table (make-hash-table)) (set! const:symbol-counter 0) @@ -75,10 +71,8 @@ (set! const:string-counter 0) (set! compiler:static-list null) (set! compiler:per-load-static-list null) - (set! compiler:per-invoke-static-list null) (set! vector-table (make-hash-table)) - (set! new-uninterned-symbols null) - (set! syntax-strings null)) + (set! new-uninterned-symbols null)) (define (const:intern-string s) (let ([table @@ -98,32 +92,12 @@ (set! compiler:per-load-static-list (cons var compiler:per-load-static-list))) - (define (compiler:add-per-invoke-static-list! var mi) - (set! compiler:per-invoke-static-list - (cons (cons var mi) compiler:per-invoke-static-list))) - (define-values (const:the-per-load-statics-table const:per-load-statics-table?) (let-struct const:per-load-statics-table () (values (make-const:per-load-statics-table) const:per-load-statics-table?))) - (define (wrap-module-definition def mi) - (let ([def (zodiac:make-module-form - (zodiac:zodiac-stx def) - (make-empty-box) - #f #f #f #f - def #f - #f #f #f #f #f)]) - (set-annotation! - def - (make-module-info mi - #f - (if (varref:module-invoke-syntax? mi) - 'syntax-body - 'body))) - def)) - ;; we need to make this in a-normalized, analyzed form from the beginning (define compiler:add-const! (lambda (code attr) @@ -149,11 +123,6 @@ (set! compiler:per-load-static-list (cons var compiler:per-load-static-list)) (compiler:add-local-per-load-define-list! def)] - [(varref:module-invoke? attr) - (set! compiler:per-invoke-static-list - (cons (cons var attr) compiler:per-invoke-static-list)) - (let ([def (wrap-module-definition def attr)]) - (compiler:add-local-per-invoke-define-list! def))] [else (set! compiler:static-list (cons var compiler:static-list)) (compiler:add-local-define-list! def)]) @@ -199,17 +168,6 @@ new-uninterned-symbols (set! new-uninterned-symbols null))) - (define-struct syntax-string (str mi uposes ustart id)) - - (define (compiler:add-syntax-string! str mi uninterned-positions uninterned-start) - (let ([naya (make-syntax-string str mi uninterned-positions uninterned-start - (length syntax-strings))]) - (set! syntax-strings (cons naya syntax-strings)) - naya)) - - (define (const:get-syntax-strings) - syntax-strings) - (define compiler:get-inexact-real-const! (lambda (v ast) (let ([sym (string->symbol (number->string v))]) @@ -463,10 +421,9 @@ (compiler:construct-const-code! (wrap base) known-immutable?))) - (or (varref:current-invoke-module) - (if known-immutable? - varref:static - varref:per-load-static)))) + (if known-immutable? + varref:static + varref:per-load-static))) (zodiac:make-special-constant 'self_modidx)))] ;; other atomic constants that must be built @@ -475,151 +432,5 @@ (bytes? (zodiac:zread-object ast))) (const:intern-string (zodiac:zread-object ast))) (compiler:add-const! (compiler:re-quote ast) - varref:static)]))) - - (define syntax-constants null) - - (define (const:reset-syntax-constants!) - (set! syntax-constants null)) - - (define (const:make-syntax-constant stx) - ;; Marhsall to a string constant, and read back out at run-time. - ;; For sharing of syntax info, put all syntax objects for a given - ;; top-level expression into one marshal step. - (let* ([var (gensym 'conststx)] - [sv (zodiac:make-top-level-varref - stx - (make-empty-box) - var - #f - (box '()) - #f - #f - #f)]) - (set! syntax-constants (cons (cons sv stx) - syntax-constants)) - (set-annotation! sv (varref:empty-attributes)) - (varref:add-attribute! sv varref:static) - (varref:add-attribute! sv (or (varref:current-invoke-module) - varref:per-load-static)) - (if (varref:current-invoke-module) - (set! compiler:per-invoke-static-list - (cons (cons var (varref:current-invoke-module)) - compiler:per-invoke-static-list)) - (set! compiler:per-load-static-list - (cons var compiler:per-load-static-list))) - sv)) - - ;; We collect syntax objects together to share the cost of of - ;; the rename tables. More gnerally, to get the expansion-time - ;; info to use-time, we use the bytecode writer built into - ;; MzScheme, putting multiple syntax objects together into a - ;; syntax vector. The scheme_eval_compiled_stx_string() will - ;; unpack it, and perform any necessary phase shifts. To perform - ;; the module mapping associated with the phase shift, - ;; scheme_eval_compiled_stx_string() expects the "syntax" vector - ;; to have a module index path (the "self" path) as its last - ;; element. - ;; Returns a max-arity. - (define (const:finish-syntax-constants!) - (if (null? syntax-constants) - 0 - (let* ([s (open-output-bytes)] - [uninterned-symbol-info (get-new-uninterned-symbols!)] - [c (compile `(quote-syntax ,(list->vector - (let ([l (map cdr syntax-constants)] - [mi (varref:current-invoke-module)]) - (append - l - (map car uninterned-symbol-info) ; car gets the syms - (if mi - (list (varref:module-invoke-context-path-index mi)) - null))))))]) - (display c s) - (let ([syntax-string (get-output-bytes s)]) - (let* ([strvar (compiler:add-syntax-string! - syntax-string - (varref:current-invoke-module) - (map cdr uninterned-symbol-info) ; cdr gets positions - (length syntax-constants))] ; starting place for symbols - [vecvar (gensym 'conststxvec)] - [sv (zodiac:make-top-level-varref - #f - (make-empty-box) - vecvar - #f - (box '()) - #f - #f - #f)]) - - (set-annotation! sv (varref:empty-attributes)) - (varref:add-attribute! sv varref:static) - (varref:add-attribute! sv (or (varref:current-invoke-module) - varref:per-load-static)) - (if (varref:current-invoke-module) - (set! compiler:per-invoke-static-list - (cons (cons vecvar (varref:current-invoke-module)) - compiler:per-invoke-static-list)) - (set! compiler:per-load-static-list - (cons vecvar compiler:per-load-static-list))) - - ((if (varref:current-invoke-module) - compiler:add-local-per-invoke-define-list! - compiler:add-local-per-load-define-list!) - (let ([def - (zodiac:make-define-values-form - #f - (make-empty-box) (list sv) - (compiler:re-quote - (zodiac:make-zread - (datum->syntax-object - #f - strvar ;; <------ HACK! See "HACK!" in vm2c.ss - #f))))]) - (if (varref:current-invoke-module) - (wrap-module-definition def (varref:current-invoke-module)) - def))) - - ;; Create construction code for each - ;; syntax variable: - (let loop ([l syntax-constants] - [pos 0]) - (unless (null? l) - (let ([app (zodiac:make-app - (cdar l) - (make-empty-box) - (zodiac:make-top-level-varref - (cdar l) - (make-empty-box) - 'vector-ref - '#%kernel - (box '()) - #f - #f - #f) - (list - sv - (compiler:re-quote - (zodiac:make-zread - (datum->syntax-object - #f - pos - (cdar l))))))]) - (set-annotation! app (make-app #f #t 'vector-ref)) - ((if (varref:current-invoke-module) - compiler:add-local-per-invoke-define-list! - compiler:add-local-per-load-define-list!) - (let ([def - (zodiac:make-define-values-form - (cdar l) - (make-empty-box) (list (caar l)) - app)]) - (if (varref:current-invoke-module) - (wrap-module-definition def (varref:current-invoke-module)) - def))) - (loop (cdr l) (add1 pos))))))) - (set! syntax-constants null) - ;; We make an application with 2 arguments - 2)))))) + varref:static)])))))) diff --git a/collects/compiler/private/cstructs.ss b/collects/compiler/private/cstructs.ss index 3560328893..40b03d7d0e 100644 --- a/collects/compiler/private/cstructs.ss +++ b/collects/compiler/private/cstructs.ss @@ -25,27 +25,18 @@ ;; VARREF ATTRIBUTES ;; Used as the annotation for zodiac:varref objects - (define-struct va (flags invoke-module)) + (define-struct va (flags i-n-v-oke-module)) (define (varref:empty-attributes) (make-va 0 #f)) (define (varref:add-attribute! ast attr) (let ([va (get-annotation ast)]) - (let ([attr (if (varref:module-invoke? attr) - (begin - (set-va-invoke-module! va attr) - varref:per-invoke-static) - attr)]) - (set-va-flags! va (bitwise-ior attr (va-flags va)))))) + (set-va-flags! va (bitwise-ior attr (va-flags va))))) (define (varref:has-attribute? ast attr) (let ([anno (get-annotation ast)]) (and (va? anno) (positive? (bitwise-and (va-flags anno) attr))))) - (define (varref:invoke-module ast) - (let ([anno (get-annotation ast)]) - (and (va? anno) (va-invoke-module anno)))) (define varref:static 1) (define varref:per-load-static 2) - (define varref:per-invoke-static 4) (define varref:primitive 8) (define varref:symbol 16) (define varref:inexact 32) @@ -53,22 +44,6 @@ (define varref:in-module 128) (define varref:module-stx-string 256) - (define mi-counter -1) - (define-struct varref:module-invoke (id syntax? context-path-index)) - (define (make-module-invokes self-path-index) - (set! mi-counter (add1 mi-counter)) - (values (make-varref:module-invoke mi-counter #f self-path-index) - (make-varref:module-invoke mi-counter #t self-path-index))) - - (define (get-num-module-invokes) - (add1 mi-counter)) - - (define (is-module-invoke? mi num) - (and (varref:module-invoke? mi) - (= num (varref:module-invoke-id mi)))) - - (define (varref:reset-module-id!) (set! mi-counter -1)) - ;;---------------------------------------------------------------------------- ;; AST NODES ;; New AST nodes to augment the zodiac set: @@ -84,7 +59,7 @@ ;; analysis phase (define-struct binding (rec? ; part of a letrec recursive binding set mutable? ; set!ed? (but not for unit or letrec definitions) - unit-i/e? ; is imported/exported (including uses by invoke) + unit-i/e? ; is imported/exported (including uses by in-voke) anchor ; zodiac:binding - anchor binding for this binding letrec-set?; set! to implement a letrec ivar? ; is a class ivar? @@ -182,7 +157,7 @@ max-arity ;; max number of args in applications ;; within the closure (which is unrelated - ;; to the number of arguments used to invoke + ;; to the number of arguments used to call ;; this closure, if it happens to be a ;; lambda) @@ -229,16 +204,6 @@ ;; MzScheme name for the known primitive, or #f )) - (define-struct module-info (invoke - ;; a module-invoke record - syntax-invoke - ;; another module-invoke record - part - ;; 'body, 'syntax-body, or 'constructor - )) - - (define varref:current-invoke-module (make-parameter #f)) - ;;---------------------------------------------------------------------------- ;; ACCESSOR ;; diff --git a/collects/compiler/private/driver.ss b/collects/compiler/private/driver.ss index 3f438a2370..a6d2294963 100644 --- a/collects/compiler/private/driver.ss +++ b/collects/compiler/private/driver.ss @@ -73,8 +73,9 @@ (lib "link-sig.ss" "dynext") (lib "file-sig.ss" "dynext")) - (require "../sig.ss") - (require "sig.ss") + (require "../sig.ss" + "sig.ss" + "to-core.ss") (provide driver@) @@ -223,7 +224,7 @@ expand-top-level-with-compile-time-evals expand) expr)]) - (zodiac:syntax->zodiac + (values ; use to be zodiac:syntax->zodiac here (let ([p (src2src:optimize expanded #t)]) '(with-output-to-file "/tmp/l.ss" (lambda () (pretty-print (syntax-object->datum p))) @@ -249,71 +250,7 @@ (require-for-syntax mzscheme)))))))) ;;---------------------------------------------------------------------- - ;; Misc utils - - ;; see (single) use for info: - (define (split-module m) - (let ([info (get-annotation m)]) - (let ([mk - (lambda (expr mode) - (let ([ast (zodiac:make-module-form - (zodiac:zodiac-stx expr) - (make-empty-box) - (zodiac:module-form-name m) - (zodiac:module-form-requires m) - (zodiac:module-form-for-syntax-requires m) - (zodiac:module-form-for-template-requires m) - expr #f - (zodiac:module-form-provides m) - (zodiac:module-form-syntax-provides m) - (zodiac:module-form-indirect-provides m) - (zodiac:module-form-kernel-reprovide-hint m) - (zodiac:module-form-self-path-index m))]) - (set-annotation! - ast - (make-module-info ((if (eq? mode 'syntax-body) - module-info-syntax-invoke - module-info-invoke) - info) - #f - mode)) - ast))] - [body->list - (lambda (expr) - (if (zodiac:begin-form? expr) - (zodiac:begin-form-bodies expr) - (list expr)))]) - (append - (map (lambda (x) (mk x 'body)) - (body->list - (zodiac:module-form-body m))) - (map (lambda (x) (mk x 'syntax-body)) - (body->list - (zodiac:module-form-syntax-body m))) - (list (mk - ;; Construct constant expression for module construction info: - (let ([q (zodiac:make-quote-form - (zodiac:zodiac-stx m) - (make-empty-box) - (zodiac:make-zread - (datum->syntax-object - #f - (list (zodiac:module-form-name m) - (zodiac:module-form-requires m) - (zodiac:module-form-for-syntax-requires m) - (zodiac:module-form-for-template-requires m) - (filter (if (zodiac:module-form-kernel-reprovide-hint m) - (lambda (x) (or (symbol? x) - (not (eq? '#%kernel (car x))))) - (lambda (x) #t)) - (zodiac:module-form-provides m)) - (zodiac:module-form-syntax-provides m) - (zodiac:module-form-indirect-provides m) - (zodiac:module-form-kernel-reprovide-hint m)) - (zodiac:zodiac-stx m))))]) - (set-annotation! q 'immutable) - q) - 'constructor)))))) + ;; Misc utils ;; takes a list of a-normalized expressions and analyzes them ;; returns the analyzed code, a list of local variable lists, @@ -344,11 +281,6 @@ (reverse! children-acc)) max-arity) (begin - (varref:current-invoke-module - (and (zodiac:module-form? (car sexps)) - (let ([info (get-annotation (car sexps))]) - (and (not (eq? (module-info-part info) 'constructor)) - (module-info-invoke info))))) ;; (printf "~a~n" (syntax-line (zodiac:zodiac-stx (car sexps)))) @@ -357,22 +289,8 @@ (analyze-expression! (car sexps) empty-set null (null? (cdr sexps)))]) - (let ([sc-max-arity - ;; Adds to const, per-load-const, per-invoke-const lists: - (if (or (null? (cdr sexps)) - (not (zodiac:module-form? (car sexps))) - (not (zodiac:module-form? (cadr sexps))) - (let ([a1 (get-annotation (car sexps))] - [a2 (get-annotation (cadr sexps))]) - (not (and (eq? (module-info-part a1) - (module-info-part a2)) - (eq? (module-info-invoke a1) - (module-info-invoke a2)))))) - (compiler:finish-syntax-constants!) - 0)]) + (let ([sc-max-arity 0]) - (varref:current-invoke-module #f) - (loop (cdr sexps) (cons exp source-acc) (cons local-vars locals-acc) @@ -404,13 +322,21 @@ [l l][c c] [pll-acc null][plc-acc null]) (if (zero? n) - (begin + (let ([lifted-lambdas (compiler:get-lifted-lambdas)] + [once-closures (compiler:get-once-closures-list)]) + + (let ([naya (append lifted-lambdas once-closures)]) + (set-block-magics! s:file-block (append (map (lambda (x) #f) naya) + (block-magics s:file-block))) + (set-block-bytecodes! s:file-block (append (map (lambda (x) #f) naya) + (block-bytecodes s:file-block)))) + (set-block-source! s:file-block (append (reverse l-acc) - (compiler:get-lifted-lambdas) + lifted-lambdas (reverse pll-acc) - (compiler:get-once-closures-list) + once-closures (map car l))) (set-block-codes! s:file-block @@ -438,9 +364,7 @@ (list (get-annotation (zodiac:define-values-form-val - (if (zodiac:module-form? ll) - (zodiac:module-form-body ll) - ll)))))) + ll))))) (compiler:get-once-closures-list) (compiler:get-once-closures-globals-list)) (map reset-globals c (map cdr l))))) @@ -457,7 +381,7 @@ (lambda (file-block l) (set-block-codes! file-block - (append! + (append (map (lambda (glob) (make-code empty-set @@ -470,7 +394,15 @@ (block-codes file-block))) (set-block-source! file-block - (append! l (block-source file-block))))) + (append l (block-source file-block))) + (set-block-bytecodes! + file-block + (append (map (lambda (x) #f) l) + (block-bytecodes file-block))) + (set-block-magics! + file-block + (append (map (lambda (x) #f) l) + (block-magics file-block))))) (define (open-input-scheme-file path) (let ([p (let ([open (with-handlers ([exn:fail? (lambda (x) #f)]) @@ -630,7 +562,6 @@ (set! c-lambdas null) (const:init-tables!) (compiler:init-closure-lists!) - (varref:reset-module-id!) ; process the input string - try to open the input file (let-values ([(input-path c-output-path constant-pool-output-path obj-output-path dll-output-path @@ -695,14 +626,73 @@ ;;----------------------------------------------------------------------- ;; record module name, if a single declaration + ;; (set-single-module-mode! #f) - (when (and (= 1 (length (block-source s:file-block))) - (zodiac:module-form? (car (block-source s:file-block)))) - (set-single-module-mode! #t) - (set! compiler:module-decl-name - (syntax-e (zodiac:module-form-name (car (block-source s:file-block)))))) + (when (= 1 (length (block-source s:file-block))) + (syntax-case (car (block-source s:file-block)) (module) + [(module name . _) + (begin + (set-single-module-mode! #t) + (set! compiler:module-decl-name (syntax-e #'name)))] + [_else (void)])) + + ;;----------------------------------------------------------------------- + ;; ensure that no `module' expression is inside a `begin' + ;; + (letrec ([needs-split? + (lambda (stx saw-begin?) + (syntax-case stx (begin module) + [(module . _) saw-begin?] + [(begin . e) + (ormap (lambda (x) (needs-split? x #t)) + (syntax->list #'e))] + [_else #f]))] + [split + (lambda (stx) + (syntax-case stx (begin module) + [(begin . e) + (apply append (map split (syntax->list #'e)))] + [_else (list stx)]))]) + (set-block-source! + s:file-block + (apply + append + (map (lambda (e) + (if (needs-split? e #f) + (split e) + (list e))) + (block-source s:file-block))))) + + ;;----------------------------------------------------------------------- + ;; Extract stateless, phaseless core, leaving the rest of bytecode + ;; + + (when (compiler:option:verbose) (printf " extracting core expressions~n")) + (when (compiler:option:debug) (debug " = CORE =~n")) + + (let ([core-thunk + (lambda () + (let ([sources+bytecodes+magics + (map (lambda (src) + (let-values ([(src bytecode magic-sym) + (top-level-to-core src + #`'#,zodiac:global-lookup-id + #`'#,zodiac:global-assign-id + #`'#,zodiac:safe-vector-ref-id + #`'#,zodiac:global-prepare-id)]) + (list (zodiac:syntax->zodiac src) + bytecode magic-sym))) + (block-source s:file-block))]) + (set-block-source! s:file-block (map car sources+bytecodes+magics)) + (set-block-bytecodes! s:file-block + (parameterize ([current-namespace elaborate-namespace]) + (map compile + (map cadr sources+bytecodes+magics)))) + (set-block-magics! s:file-block (map caddr sources+bytecodes+magics))))]) + (verbose-time core-thunk)) + ;;----------------------------------------------------------------------- ;; Run a preprocessing phase on the input ;; @@ -722,17 +712,7 @@ (if (eq? errors compiler:messages) ;; no errors here - (if (zodiac:module-form? ast) - ;; If it's a module, split it into three parts: - ;; - body - ;; - syntax definitions - ;; - module registration - ;; That way, the global variable sets, etc., are - ;; kept separate. - (append (split-module ast) (loop (cdr source) errors)) - - ;; Normal expr - (cons ast (loop (cdr source) errors))) + (cons ast (loop (cdr source) errors)) ;; error, drop this one (loop (cdr source) compiler:messages)))))))]) @@ -793,7 +773,6 @@ ; analyze top level expressions, cataloguing local variables (compiler:init-define-lists!) - (const:reset-syntax-constants!) (let ([bnorm-thunk (lambda () (let-values ([(new-source new-codes max-arity) @@ -803,20 +782,18 @@ (set-block-codes! s:file-block new-codes) (block:register-max-arity! s:file-block max-arity) (s:register-max-arity! max-arity)) - - ; take constant construction code and place it in front of the - ; previously generated code. True constants first. + + ;; take constant construction code and place it in front of the + ;; previously generated code. True constants first. (set! number-of-true-constants (length (compiler:get-define-list))) - (set! number-of-per-load-constants (+ (length (compiler:get-per-load-define-list)) - (length (compiler:get-per-invoke-define-list)))) + (set! number-of-per-load-constants (+ (length (compiler:get-per-load-define-list)))) (s:append-block-sources! s:file-block (append (compiler:get-define-list) - (compiler:get-per-load-define-list) - (compiler:get-per-invoke-define-list))))]) + (compiler:get-per-load-define-list))))]) (verbose-time bnorm-thunk)) (compiler:report-messages! #t) - + ; (map (lambda (ast) (pretty-print (zodiac->sexp/annotate ast))) (block-source s:file-block)) ;;----------------------------------------------------------------------- @@ -833,7 +810,7 @@ (compiler:report-messages! #t) ; (map (lambda (ast) (pretty-print (zodiac->sexp/annotate ast))) (block-source s:file-block)) - + ;;----------------------------------------------------------------------- ;; Closure conversion and explicit control transformation ;; @@ -847,7 +824,7 @@ s:file-block (map closure-expression! (block-source s:file-block))))]) (verbose-time closure-thunk)) - + ;;----------------------------------------------------------------------- ;; Vehicle assignment ;; @@ -928,7 +905,8 @@ ; top-level. The last expression will be in tail position and should ; return its value (let loop ([s (block-source s:file-block)] - [l (block-codes s:file-block)]) + [l (block-codes s:file-block)] + [m (block-magics s:file-block)]) (unless (null? s) (let-values ([(vm new-locals) (vm-phase (car s) @@ -938,15 +916,18 @@ (lambda (ast) (make-vm:return (zodiac:zodiac-stx ast) - ast)) + ast + (and (car m) #t))) (lambda (ast) (make-vm:void (zodiac:zodiac-stx ast) - ast))) - (null? (cdr s)))]) + ast + (and (car m) #t)))) + (null? (cdr s)) + (and (car m) #t))]) (set-car! s vm) (add-code-local+used-vars! (car l) new-locals)) - (loop (cdr s) (cdr l)))) + (loop (cdr s) (cdr l) (cdr m)))) ; code-bodies (for-each (lambda (L) @@ -954,7 +935,8 @@ [tail-pos (lambda (ast) (make-vm:return (zodiac:zodiac-stx ast) - ast))] + ast + #f))] [new-locals (cond [(zodiac:case-lambda-form? L) @@ -968,7 +950,7 @@ ; empty: already added via case empty-set) (let-values ([(vm new-locals) - (vm-phase (car l) #t #f tail-pos #t)]) + (vm-phase (car l) #t #f tail-pos #t #f)]) (add-code-local+used-vars! (car case-codes) new-locals ) @@ -1083,11 +1065,24 @@ (fprintf c-port "#include \"mzc.h\"~n~n") (vm->c:emit-struct-definitions! (compiler:get-structs) c-port) (vm->c:emit-symbol-declarations! c-port) - (vm->c:emit-syntax-string-declarations! c-port) (vm->c:emit-inexact-declarations! c-port) (vm->c:emit-string-declarations! c-port) (vm->c:emit-prim-ref-declarations! c-port) (vm->c:emit-static-declarations! c-port) + + (let loop ([c 0][l (block-bytecodes s:file-block)][m (block-magics s:file-block)]) + (cond + [(null? l) (void)] + [(not (car l)) (loop c (cdr l) (cdr m))] + [else + (vm->c:emit-bytecode-string-definition! + (format "top_level_bytecode_~a" c) + (car l) + c-port) + (fprintf c-port "#define top_level_magic_sym_~a ~s\n\n" + c + (symbol->string (car m))) + (loop (add1 c) (cdr l) (cdr m))])) (let loop ([n 0]) (unless (= n (compiler:get-total-vehicles)) @@ -1100,10 +1095,6 @@ (vm->c:emit-symbol-definitions! c-port) (fprintf c-port "}~n")) - (fprintf c-port "~nstatic void make_syntax_strings()~n{~n") - (vm->c:emit-syntax-string-definitions! c-port) - (fprintf c-port "}~n") - (unless (zero? (const:get-inexact-counter)) (fprintf c-port "~nstatic void make_inexacts()~n{~n") (vm->c:emit-inexact-definitions! c-port) @@ -1135,31 +1126,6 @@ (block-max-arity s:file-block) #f #f ; no module entries c-port))] - [invoke-counts - (let loop ([i 0]) - (if (= i (get-num-module-invokes)) - null - (cons - (let loop ([syntax? #f]) - (cons - (vm->c:emit-top-levels! (format "module~a_body_~a" - (if syntax? "_syntax" "") - i) - #f #f #f -1 - (block-source s:file-block) - locals - globals - (block-max-arity s:file-block) - i syntax? - c-port) - (if syntax? - null - (loop #t)))) - (loop (add1 i)))))] - [_ (let loop ([i 0][counts invoke-counts]) - (unless (= i (get-num-module-invokes)) - (vm->c:emit-module-glue! c-port i (caar counts) (cadar counts)) - (loop (add1 i) (cdr counts))))] [top-level-count (vm->c:emit-top-levels! "top_level" #t #t #f -1 (list-tail (block-source s:file-block) number-of-true-constants) @@ -1198,8 +1164,6 @@ (unless (compiler:multi-o-constant-pool) (fprintf c-port "~amake_symbols();~n" vm->c:indent-spaces)) - (fprintf c-port "~amake_syntax_strings();~n" - vm->c:indent-spaces) (unless (zero? (const:get-inexact-counter)) (fprintf c-port "~amake_inexacts();~n" vm->c:indent-spaces)) @@ -1296,7 +1260,8 @@ code c-port (* (if suffix? 3 2) vm->c:indent-by) - #f) + #f + -1) (vm->c:emit-case-epilogue L i undefines indent c-port) (when suffix? (fprintf c-port "~a~a} /* end case ~a */~n" diff --git a/collects/compiler/private/known.ss b/collects/compiler/private/known.ss index 29a9c31e87..27d4acfbd8 100644 --- a/collects/compiler/private/known.ss +++ b/collects/compiler/private/known.ss @@ -199,6 +199,11 @@ [(zodiac:case-lambda-form? fun) (simple-case-lambda? fun)] [else #f])))))] + [(zodiac:global-prepare? v) #t] + [(zodiac:global-lookup? v) #f] + [(zodiac:global-assign? v) #f] + [(zodiac:safe-vector-ref? v) #t] + [else #f]))) ;; extract-ast-known-value tries to extract a useful value from a known-value AST @@ -544,14 +549,30 @@ ast] ;;----------------------------------------------------------- - ;; MODULE + ;; GLOBALS ;; - [(zodiac:module-form? ast) - - (zodiac:set-module-form-body! + [(zodiac:global-prepare? ast) + (zodiac:set-global-prepare-vec! ast - (analyze! (zodiac:module-form-body ast))) - + (analyze! (zodiac:global-prepare-vec ast))) + ast] + [(zodiac:global-lookup? ast) + (zodiac:set-global-lookup-vec! + ast + (analyze! (zodiac:global-lookup-vec ast))) + ast] + [(zodiac:global-assign? ast) + (zodiac:set-global-assign-vec! + ast + (analyze! (zodiac:global-assign-vec ast))) + (zodiac:set-global-assign-expr! + ast + (analyze! (zodiac:global-assign-expr ast))) + ast] + [(zodiac:safe-vector-ref? ast) + (zodiac:set-safe-vector-ref-vec! + ast + (analyze! (zodiac:safe-vector-ref-vec ast))) ast] diff --git a/collects/compiler/private/lift.ss b/collects/compiler/private/lift.ss index 1814f5333e..501b577fe0 100644 --- a/collects/compiler/private/lift.ss +++ b/collects/compiler/private/lift.ss @@ -75,7 +75,7 @@ ;; LAMBDA EXPRESSIONS ;; [(zodiac:case-lambda-form? ast) - (set! procedures (cons (cons ast (varref:current-invoke-module )) procedures)) + (set! procedures (cons (cons ast #f) procedures)) (for-each find! (zodiac:case-lambda-form-bodies ast))] ;;-------------------------------------------------------------- @@ -158,12 +158,17 @@ (find! (zodiac:with-continuation-mark-form-body ast))] ;;----------------------------------------------------------- - ;; MODULE + ;; GLOBALS ;; - [(zodiac:module-form? ast) - (parameterize ([varref:current-invoke-module - (module-info-invoke (get-annotation ast))]) - (find! (zodiac:module-form-body ast)))] + [(zodiac:global-prepare? ast) + (find! (zodiac:global-prepare-vec ast))] + [(zodiac:global-lookup? ast) + (find! (zodiac:global-lookup-vec ast))] + [(zodiac:global-assign? ast) + (find! (zodiac:global-assign-vec ast)) + (find! (zodiac:global-assign-expr ast))] + [(zodiac:safe-vector-ref? ast) + (find! (zodiac:safe-vector-ref-vec ast))] [else (compiler:internal-error ast @@ -297,8 +302,7 @@ (remove-code-free-vars! code (make-singleton-set (zodiac:bound-varref-binding ast)))) (when (top-level-varref/bind-from-lift-pls? lifted) - (add-global! (or (varref:current-invoke-module) - const:the-per-load-statics-table))) + (add-global! const:the-per-load-statics-table)) lifted) ;; No change @@ -314,8 +318,6 @@ (void)] [(varref:has-attribute? ast varref:per-load-static) (add-global! const:the-per-load-statics-table)] - [(varref:has-attribute? ast varref:per-invoke-static) - (add-global! (varref:invoke-module ast))] [(varref:has-attribute? ast varref:static) (void)] [else (add-global! (compiler:add-global-varref! ast))]) @@ -365,8 +367,7 @@ (if (top-level-varref/bind-from-lift-pls? lifted) (set! globals (set-union-singleton save-globals - (or (varref:current-invoke-module) - const:the-per-load-statics-table))) + const:the-per-load-statics-table)) (set! globals save-globals)) lifted))))] @@ -552,15 +553,30 @@ ast] ;;----------------------------------------------------------- - ;; MODULE + ;; GLOBALS ;; - [(zodiac:module-form? ast) - - (parameterize ([varref:current-invoke-module (module-info-invoke (get-annotation ast))]) - (zodiac:set-module-form-body! - ast - (lift! (zodiac:module-form-body ast) code))) - + [(zodiac:global-prepare? ast) + (zodiac:set-global-prepare-vec! + ast + (lift! (zodiac:global-prepare-vec ast) code)) + ast] + [(zodiac:global-lookup? ast) + (zodiac:set-global-lookup-vec! + ast + (lift! (zodiac:global-lookup-vec ast) code)) + ast] + [(zodiac:global-assign? ast) + (zodiac:set-global-assign-vec! + ast + (lift! (zodiac:global-assign-vec ast) code)) + (zodiac:set-global-assign-expr! + ast + (lift! (zodiac:global-assign-expr ast) code)) + ast] + [(zodiac:safe-vector-ref? ast) + (zodiac:set-safe-vector-ref-vec! + ast + (lift! (zodiac:safe-vector-ref-vec ast) code)) ast] [else (compiler:internal-error @@ -596,10 +612,8 @@ ;; Set liftable flags (for-each (lambda (l) - (let ([l (car l)] - [mi (cdr l)]) - (parameterize ([varref:current-invoke-module mi]) - (set-liftable! l)))) + (let ([l (car l)]) + (set-liftable! l))) procedures) (set! globals empty-set) diff --git a/collects/compiler/private/prephase.ss b/collects/compiler/private/prephase.ss index 2848c1c7f7..a993a94017 100644 --- a/collects/compiler/private/prephase.ss +++ b/collects/compiler/private/prephase.ss @@ -654,24 +654,31 @@ ast] ;;----------------------------------------------------------- - ;; MODULE + ;; GLOBALS ;; - [(zodiac:module-form? ast) - - (let-values ([(mi smi) (make-module-invokes - (zodiac:module-form-self-path-index ast))]) - (set-annotation! ast (make-module-info mi smi #f))) - - (zodiac:set-module-form-body! + [(zodiac:global-prepare? ast) + (zodiac:set-global-prepare-vec! ast - (prephase! (zodiac:module-form-body ast) - #t #f #f)) - (zodiac:set-module-form-syntax-body! - ast - (prephase! (zodiac:module-form-syntax-body ast) - #t #f #f)) + (prephase! (zodiac:global-prepare-vec ast) in-mod? #t #f)) + ast] + [(zodiac:global-lookup? ast) + (zodiac:set-global-lookup-vec! + ast + (prephase! (zodiac:global-lookup-vec ast) in-mod? #t #f)) + ast] + [(zodiac:global-assign? ast) + (zodiac:set-global-assign-vec! + ast + (prephase! (zodiac:global-assign-vec ast) in-mod? #t #f)) + (zodiac:set-global-assign-expr! + ast + (prephase! (zodiac:global-assign-expr ast) in-mod? #t #f)) + ast] + [(zodiac:safe-vector-ref? ast) + (zodiac:set-safe-vector-ref-vec! + ast + (prephase! (zodiac:safe-vector-ref-vec ast) in-mod? #t #f)) ast] - ;;----------------------------------------------------------- ;; Unsupported forms diff --git a/collects/compiler/private/rep.ss b/collects/compiler/private/rep.ss index 9e92c3724a..42306909c2 100644 --- a/collects/compiler/private/rep.ss +++ b/collects/compiler/private/rep.ss @@ -45,7 +45,6 @@ ;; 'scheme-object ;; 'scheme-bucket ;; 'scheme-per-load-static - ;; 'scheme-per-invoke-static ;; 'label ;; 'prim ;; 'prim-case @@ -55,8 +54,6 @@ (define-struct rep:struct (name orig-name fields)) (define-struct rep:struct-field (name orig-name rep)) - (define-struct (rep:atomic/invoke rep:atomic) (module-invoke)) - (define (rep:same-shape? a b) (let ([al (rep:struct-fields a)] [bl (rep:struct-fields b)]) @@ -67,10 +64,7 @@ (or (and (rep:atomic? ar) (rep:atomic? br) (eq? (rep:atomic-type ar) - (rep:atomic-type br)) - (or (not (rep:atomic/invoke? ar)) - (eq? (rep:atomic/invoke-module-invoke ar) - (rep:atomic/invoke-module-invoke br)))) + (rep:atomic-type br))) (and (rep:struct? ar) (rep:struct? br) (eq? (rep:struct-name ar) @@ -181,21 +175,14 @@ ;; field-name (if (const:per-load-statics-table? global) 'pls - (if (varref:module-invoke? global) - 'pmis - #f)) - (if (or (const:per-load-statics-table? global) - (varref:module-invoke? global)) + #f) + (if (const:per-load-statics-table? global) global (mod-glob-cname global)) ;; field-type (if (const:per-load-statics-table? global) (make-rep:atomic 'scheme-per-load-static) - (if (varref:module-invoke? global) - (make-rep:atomic/invoke - 'scheme-per-invoke-static - global) - (make-rep:atomic 'scheme-bucket))))) + (make-rep:atomic 'scheme-bucket)))) (set->list (code-global-vars code))))]) (if (null? fields) #f ; empty structure - don't use anything diff --git a/collects/compiler/private/sig.ss b/collects/compiler/private/sig.ss index 1810757839..5953111806 100644 --- a/collects/compiler/private/sig.ss +++ b/collects/compiler/private/sig.ss @@ -57,11 +57,9 @@ (varref:empty-attributes varref:add-attribute! varref:has-attribute? - varref:invoke-module varref:static varref:per-load-static - varref:per-invoke-static varref:primitive varref:symbol varref:inexact @@ -69,13 +67,6 @@ varref:in-module varref:module-stx-string - (struct varref:module-invoke (id syntax? context-path-index)) - make-module-invokes - get-num-module-invokes - is-module-invoke? - - varref:reset-module-id! - (struct compiler:make-closure (lambda free-vars args name)) (struct binding (rec? ; part of a letrec recursive binding set @@ -106,10 +97,6 @@ (struct app (tail? prim? prim-name)) - (struct module-info (invoke syntax-invoke part)) - - varref:current-invoke-module - compiler:bound-varref->binding (struct c-lambda (function-name scheme-name body arity)) @@ -191,21 +178,11 @@ compiler:get-static-list compiler:get-per-load-static-list - compiler:get-per-invoke-static-list compiler:add-per-load-static-list! - compiler:add-per-invoke-static-list! compiler:make-const-constructor - const:make-syntax-constant - - const:reset-syntax-constants! - const:finish-syntax-constants! - - (struct syntax-string (str mi uposes ustart id)) - const:get-syntax-strings - (struct compiled-string (id len)))) (provide compiler:rep^) @@ -215,8 +192,6 @@ (struct rep:struct (name orig-name fields)) (struct rep:struct-field (name orig-name rep)) - (struct rep:atomic/invoke (module-invoke)) - compiler:get-structs compiler:init-structs! @@ -239,7 +214,6 @@ compiler:get-define-list compiler:get-per-load-define-list - compiler:get-per-invoke-define-list compiler:init-define-lists! @@ -248,15 +222,12 @@ compiler:add-local-define-list! compiler:add-local-per-load-define-list! - compiler:add-local-per-invoke-define-list! (struct case-info (body case-code global-vars used-vars captured-vars max-arity)) (struct mod-glob (cname modname varname position exp-time? exp-def? in-module?)) compiler:get-module-path-constant - compiler:finish-syntax-constants! - analyze-expression!)) (provide compiler:lift^) @@ -303,29 +274,33 @@ (define-signature compiler:vmstructs^ ((struct vm:sequence (vals)) (struct vm:if (test then else)) - (struct vm:module-body (vals invoke syntax?)) - (struct vm:void (val)) - (struct vm:return (val)) + (struct vm:void (val magic?)) + (struct vm:return (val magic?)) (struct vm:tail-apply (closure argc prim)) (struct vm:tail-call (label closure set-env?)) (struct vm:continue ()) (struct vm:set! (vars val mode)) - (struct vm:generic-args (closure tail? prim vals)) + (struct vm:generic-args (closure tail? magic? prim vals)) (struct vm:register-args (vars vals)) (struct vm:args (type vals)) (struct vm:begin0-mark! (var val)) (struct vm:begin0-setup! (var)) (struct vm:syntax! (vars val in-mod?)) + (struct vm:global-prepare (vec pos)) + (struct vm:global-lookup (vec pos)) + (struct vm:global-assign (vec val pos)) + (struct vm:safe-vector-ref (vec pos)) + (struct vm:alloc (type)) (struct vm:build-constant (text)) (struct vm:make-closure (closure)) (struct vm:make-procedure-closure (vehicle min-arity max-arity name empty? method?)) (struct vm:make-case-procedure-closure (vehicle num-cases case-arities name empty? method?)) (struct vm:apply (closure argc known? multi? prim simple-tail-prim?)) - (struct vm:macro-apply (name primitive args tail? bool?)) + (struct vm:macro-apply (name primitive args tail? magic? bool?)) (struct vm:call (label closure)) (struct vm:begin0-extract (var)) (struct vm:wcm-mark! (key val)) @@ -339,16 +314,13 @@ (struct vm:global-varref (var)) (struct vm:bucket (var)) (struct vm:per-load-statics-table ()) - (struct vm:per-invoke-statics-table ()) (struct vm:cast (val rep)) ; last resort (struct vm:local-varref (var binding)) (struct vm:static-varref (var)) (struct vm:static-varref-from-lift (lambda)) (struct vm:per-load-static-varref ()) - (struct vm:per-invoke-static-varref ()) (struct vm:per-load-static-varref-from-lift (lambda)) - (struct vm:per-invoke-static-varref-from-lift (lambda)) (struct vm:primitive-varref (var)) (struct vm:symbol-varref (var)) (struct vm:inexact-varref (var)) @@ -408,7 +380,7 @@ (provide compiler:top-level^) (define-signature compiler:top-level^ - ((struct block (source codes max-arity)) + ((struct block (source codes bytecodes magics max-arity)) make-empty-block block:register-max-arity! @@ -427,8 +399,7 @@ vm->c:emit-symbol-list! vm->c:emit-symbol-declarations! vm->c:emit-symbol-definitions! - vm->c:emit-syntax-string-declarations! - vm->c:emit-syntax-string-definitions! + vm->c:emit-bytecode-string-definition! vm->c:emit-inexact-declarations! vm->c:emit-inexact-definitions! vm->c:emit-string-declarations! @@ -439,7 +410,6 @@ vm->c:emit-registration! vm->c:emit-case-arities-definitions! vm->c:emit-top-levels! - vm->c:emit-module-glue! vm->c:emit-vehicle-prototype vm->c:emit-vehicle-declaration vm->c:emit-vehicle-header diff --git a/collects/compiler/private/to-core.ss b/collects/compiler/private/to-core.ss new file mode 100644 index 0000000000..98856134eb --- /dev/null +++ b/collects/compiler/private/to-core.ss @@ -0,0 +1,371 @@ +(module to-core mzscheme + (require (lib "kerncase.ss" "syntax") + (lib "stx.ss" "syntax") + (lib "list.ss") + (lib "boundmap.ss" "syntax")) + + (provide top-level-to-core) + + (define (top-level-to-core stx lookup-stx set-stx safe-vector-ref-stx extract-stx) + (syntax-case stx (module begin) + [(module m lang (plain-module-begin decl ...)) + (let-values ([(expr new-decls magic-sym) + (lift-sequence (flatten-decls (syntax->list #'(decl ...))) + lookup-stx set-stx safe-vector-ref-stx extract-stx + #t)]) + (values (expand-syntax expr) + #`(module m lang (#%plain-module-begin #,@new-decls)) + magic-sym))] + [(begin decl ...) + (let-values ([(expr new-decls magic-sym) + (lift-sequence (flatten-decls (syntax->list #'(decl ...))) + lookup-stx set-stx safe-vector-ref-stx extract-stx + #f)]) + (values (expand-syntax expr) + #`(begin #,@new-decls) + magic-sym))] + [else + (top-level-to-core #`(begin #,stx) lookup-stx set-stx safe-vector-ref-stx extract-stx)])) + + (define (flatten-decls l) + (apply append + (map (lambda (stx) + (syntax-case stx (begin) + [(begin . e) + (flatten-decls (syntax->list #'e))] + [else (list stx)])) + l))) + + (define-struct lifted-info (counter id-map slot-map)) + + (define (make-vars) + (make-lifted-info + 0 + (make-module-identifier-mapping) + (make-hash-table 'equal))) + + (define (is-id-ref? v) + (or (identifier? v) + (and (stx-pair? v) + (identifier? (stx-car v)) + (module-identifier=? #'#%top (stx-car v))))) + + (define (vars-sequence li) + (let loop ([i 0]) + (if (= i (lifted-info-counter li)) + null + (cons (let ([v (hash-table-get (lifted-info-slot-map li) i)]) + (if (is-id-ref? v) + #`(#%variable-reference #,v) + v)) + (loop (add1 i)))))) + + (define (extract-vars li vec-id extract-stx) + (let loop ([i 0]) + (if (= i (lifted-info-counter li)) + null + (let ([v (hash-table-get (lifted-info-slot-map li) i)]) + (if (is-id-ref? v) + (cons #`(#,extract-stx #,vec-id #,i) + (loop (add1 i))) + (loop (add1 i))))))) + + (define (is-run-time? stx) + (not (and (stx-pair? stx) + (or (module-identifier=? #'define-syntaxes (stx-car stx)) + (module-identifier=? #'define-values-for-syntax (stx-car stx)))))) + + (define (has-symbol? decl magic-sym table) + (cond + [(hash-table-get table decl (lambda () #f)) + ;; cycle/graph + #f] + [else + (hash-table-put! table decl #t) + (cond + [(eq? magic-sym decl) + #t] + [(pair? decl) + (or (has-symbol? (car decl) magic-sym table) + (has-symbol? (cdr decl) magic-sym table))] + [(vector? decl) + (has-symbol? (vector->list decl) magic-sym table)] + [(box? decl) + (has-symbol? (unbox decl) magic-sym table)] + [else + #f])])) + + (define (generate-magic decls) + (let ([magic-sym (string->symbol (format "magic~a~a" + (current-seconds) + (current-milliseconds)))]) + (if (has-symbol? (map syntax-object->datum decls) magic-sym (make-hash-table)) + (generate-magic decls) + magic-sym))) + + (define (lift-sequence decls lookup-stx set-stx safe-vector-ref-stx extract-stx in-module?) + (let ([ct-vars (make-vars)] + [rt-vars (make-vars)] + [compile-time (datum->syntax-object #f (gensym 'compile-time))] + [run-time (datum->syntax-object #f (gensym 'run-time))] + [magic-sym (generate-magic decls)] + [magic-indirect (gensym)]) + (let ([ct-converted + (map (lambda (stx) + #`(lambda () + #,(syntax-case stx () + [(def ids rhs) + (let ([cvted (convert #'rhs #t + lookup-stx set-stx safe-vector-ref-stx + compile-time ct-vars + in-module?)]) + (if (and (not in-module?) + (module-identifier=? #'def #'define-syntaxes)) + ;; Don't try to name macro procedures, because it + ;; inteferes with the 0-values hack at the top level + cvted + #`(let-values ([ids #,cvted]) + (values . ids))))]))) + (filter (lambda (x) (not (is-run-time? x))) decls))] + [rt-converted + (map (lambda (stx) + #`(lambda () + #,(syntax-case stx (define-values provide require require-for-syntax require-for-template) + [(provide . _) + #'(void)] + [(require . _) + #'(void)] + [(require-for-syntax . _) + #'(void)] + [(require-for-template . _) + #'(void)] + [(define-values ids rhs) + #`(let-values ([ids + #,(convert #'rhs #f + lookup-stx set-stx safe-vector-ref-stx + run-time rt-vars + in-module?)]) + (values . ids))] + [else + (convert stx #f + lookup-stx set-stx safe-vector-ref-stx + run-time rt-vars + in-module?)]))) + (filter is-run-time? decls))] + [ct-rhs #`((let ([magic (car (cons '#,magic-sym 2))]) + (if (symbol? magic) + (lambda (x) (make-vector #,(length decls) void)) + (car magic))) + (vector #,@(vars-sequence ct-vars)))] + [rt-rhs #`((cdr '#,magic-sym) (vector #,@(vars-sequence rt-vars)))] + [just-one-ct? (>= 1 (apply + + (map (lambda (decl) + (syntax-case decl (define-syntaxes define-values-for-syntax) + [(define-values-for-syntax . _) 1] + [(define-syntaxes . _) 1] + [_else 0])) + decls)))] + [just-one-rt? (>= 1 (apply + + (map (lambda (decl) + (syntax-case decl (define-values provide require + require-for-syntax require-for-template + define-syntaxes define-values-for-syntax) + [(provide . _) 0] + [(require . _) 0] + [(require-for-syntax . _) 0] + [(define-values-for-syntax . _) 0] + [(define-syntaxes . _) 0] + [_else 1])) + decls)))]) + (values + #`(cons (lambda (#,compile-time) + #,@(extract-vars ct-vars compile-time extract-stx) + (vector #,@ct-converted)) + (lambda (#,run-time) + #,@(extract-vars rt-vars run-time extract-stx) + (vector #,@rt-converted))) + #`(;; Lift define-for-values binding to front, so they can be referenced + ;; in compile-time definition + #,@(let ([ids (apply + append + (map (lambda (stx) + (syntax-case stx (define-values-for-syntax) + [(define-values-for-syntax ids . _) + (syntax->list #'ids)] + [_else null])) + decls))]) + (if (null? ids) + null + #`((define-values-for-syntax #,ids + (values #,@(map (lambda (x) #'#f) ids)))))) + #,@(if just-one-ct? + null + #`((define-values-for-syntax (#,compile-time) #,ct-rhs))) + #,@(if just-one-rt? + null + #`((define-values (#,run-time) #,rt-rhs))) + #,@(let loop ([decls decls][ct-pos 0][rt-pos 0]) + (cond + [(null? decls) null] + [(is-run-time? (car decls)) + (cons (syntax-case (car decls) (define-values provide require require-for-syntax require-for-template) + [(provide . _) + (car decls)] + [(require . _) + (car decls)] + [(require-for-syntax . _) + (car decls)] + [(require-for-template . _) + (car decls)] + [(define-values (id ...) rhs) + #`(define-values (id ...) + ((vector-ref #,(if just-one-rt? rt-rhs run-time) #,rt-pos)))] + [else + #`((vector-ref #,(if just-one-rt? rt-rhs run-time) #,rt-pos))]) + (loop (cdr decls) ct-pos (add1 rt-pos)))] + [else + (cons (syntax-case (car decls) (define-syntaxes define-values-for-syntax) + [(define-syntaxes (id ...) . rhs) + #`(define-syntaxes (id ...) + ((vector-ref #,(if just-one-ct? ct-rhs compile-time) #,ct-pos)))] + [(define-values-for-syntax (id ...) . rhs) + #`(define-values-for-syntax () + (begin + (set!-values (id ...) ((vector-ref #,(if just-one-ct? ct-rhs compile-time) #,ct-pos))) + (values)))]) + (loop (cdr decls) (add1 ct-pos) rt-pos))]))) + magic-sym)))) + + (define (local-identifier? stx trans?) + (eq? 'lexical ((if trans? + identifier-transformer-binding + identifier-binding) + stx))) + + (define (simple-identifier stx trans?) + (let ([b ((if trans? + identifier-transformer-binding + identifier-binding) + stx)]) + (cond + [(eq? b 'lexical) stx] + [(and (pair? b) + (eq? '#%kernel (car b))) + ;; Generate a syntax object that has the right run-time binding: + (datum->syntax-object #'here (cadr b) stx stx)] + [else #f]))) + + (define (simple-constant? s) + (or (identifier? s) + (number? (syntax-e s)) + (empty? (syntax-e s)) + (memq (syntax-e s) '(#t #f)))) + + (define (add-literal/pos stx li) + (let ([pos (lifted-info-counter li)]) + (hash-table-put! (lifted-info-slot-map li) pos stx) + (set-lifted-info-counter! li (add1 pos)) + pos)) + + (define (add-literal stx li safe-vector-ref-stx id) + #`(#,safe-vector-ref-stx #,id #,(add-literal/pos stx li))) + + (define (add-identifier/pos stx li trans?) + (if (identifier? stx) + ;; id : + (or (module-identifier-mapping-get (lifted-info-id-map li) + stx + (lambda () #f)) + (let ([pos (add-literal/pos (if (not ((if trans? + identifier-transformer-binding + identifier-binding) + stx)) + #`(#%top . #,stx) + stx) + li)]) + (module-identifier-mapping-put! (lifted-info-id-map li) stx pos) + pos)) + ;; (#%top . id) : + (add-literal/pos stx li))) + + (define (add-identifier stx li trans? lookup-stx id) + #`(#,lookup-stx #,id #,(add-identifier/pos stx li trans?))) + + (define (convert stx trans? lookup-stx set-stx safe-vector-ref-stx id li in-module?) + (define ((loop certs) stx) + (let ([loop (loop (apply-certs stx certs))]) + (kernel-syntax-case stx trans? + [_ + (identifier? stx) + (or (simple-identifier stx trans?) + (add-identifier (apply-certs certs stx) li trans? lookup-stx id))] + [(provide . _) + stx] + [(lambda formals e ...) + (quasisyntax/loc stx + (lambda formals #,@(map loop (syntax->list #'(e ...)))))] + [(case-lambda [formals e ...] ...) + (with-syntax ([((e ...) ...) + (map (lambda (l) + (map loop (syntax->list l))) + (syntax->list #'((e ...) ...)))]) + (quasisyntax/loc stx + (case-lambda [formals e ...] ...)))] + [(let-values ([(id ...) rhs] ...) e ...) + (with-syntax ([(rhs ...) + (map loop (syntax->list #'(rhs ...)))]) + (quasisyntax/loc stx + (let-values ([(id ...) rhs] ...) #,@(map loop (syntax->list #'(e ...))))))] + [(letrec-values ([(id ...) rhs] ...) e ...) + (with-syntax ([(rhs ...) + (map loop (syntax->list #'(rhs ...)))]) + (quasisyntax/loc stx + (letrec-values ([(id ...) rhs] ...) #,@(map loop (syntax->list #'(e ...))))))] + [(quote e) + (if (simple-constant? #'e) + #'(quote e) + (add-literal stx li safe-vector-ref-stx id))] + [(quote-syntax e) + (add-literal stx li safe-vector-ref-stx id)] + [(#%top . tid) + (let ([target (let ([b ((if trans? + identifier-transformer-binding + identifier-binding) + #'tid)]) + (if (or (eq? b 'lexical) + (and (not in-module?) + b)) + #`(#%top . tid) + #'tid))]) + (add-identifier (apply-certs certs target) li trans? lookup-stx id))] + [(#%datum . e) + (if (simple-constant? #'e) + #'(#%datum . e) + (add-literal stx li safe-vector-ref-stx id))] + [(set! x e) + (if (local-identifier? #'x trans?) + (quasisyntax/loc stx (set! x #,(loop #'e))) + (quasisyntax/loc stx + (#,set-stx #,id #,(add-identifier/pos (apply-certs certs #'x) li trans?) #,(loop #'e))))] + #; + [(#%variable-reference e) + (add-literal stx li)] + [(if e ...) + (quasisyntax/loc stx + (if #,@(map loop (syntax->list #'(e ...)))))] + [(begin e ...) + (quasisyntax/loc stx + (begin #,@(map loop (syntax->list #'(e ...)))))] + [(begin0 e ...) + (quasisyntax/loc stx + (begin0 #,@(map loop (syntax->list #'(e ...)))))] + [(with-continuation-mark e ...) + (quasisyntax/loc stx + (with-continuation-mark #,@(map loop (syntax->list #'(e ...)))))] + [(#%app e ...) + (quasisyntax/loc stx + (#%app #,@(map loop (syntax->list #'(e ...)))))]))) + ((loop #'certs) stx)) + + (define (apply-certs from to) + (syntax-recertify to from (current-code-inspector) #f))) diff --git a/collects/compiler/private/toplevel.ss b/collects/compiler/private/toplevel.ss index 2c12979c92..ca334ac0c2 100644 --- a/collects/compiler/private/toplevel.ss +++ b/collects/compiler/private/toplevel.ss @@ -21,8 +21,10 @@ ;; (define-struct block (source ; list of top-level ASTs codes ; list of `code' structures (in parallel with source) + bytecodes ; list of S-exps in parallel + magics ; list of symbols in parallel max-arity)) - (define make-empty-block (lambda () (make-block null null 0))) + (define make-empty-block (lambda () (make-block null null null null 0))) (define block:register-max-arity! (lambda (b n) diff --git a/collects/compiler/private/vehicle.ss b/collects/compiler/private/vehicle.ss index 67645b2fb2..2f2f32950f 100644 --- a/collects/compiler/private/vehicle.ss +++ b/collects/compiler/private/vehicle.ss @@ -221,12 +221,6 @@ [(zodiac:with-continuation-mark-form? ast) (relate! current-lambda (zodiac:with-continuation-mark-form-body ast))] - ;;----------------------------------------------------------- - ;; MODULE - ;; - [(zodiac:module-form? ast) - (relate! current-lambda (zodiac:module-form-body ast))] - ;;----------------------------------------------------------------- ;; APPLICATIONS ;; diff --git a/collects/compiler/private/vm2c.ss b/collects/compiler/private/vm2c.ss index e8a3b7e27b..311d284cb8 100644 --- a/collects/compiler/private/vm2c.ss +++ b/collects/compiler/private/vm2c.ss @@ -122,17 +122,13 @@ (vm->c:SYMBOLS-name) (const:get-symbol-counter)))) - (define (vm->c:emit-syntax-string-declarations! port) - (let ([l (const:get-syntax-strings)]) - (unless (null? l) - (fprintf port "static Scheme_Object *SS[~a];~n~n" (length l)) - (for-each - (lambda (ss) - (emit-string port - "char" - (syntax-string-str ss) - (format "SYNTAX_STRING_~a" (syntax-string-id ss)))) - l)))) + (define (vm->c:emit-bytecode-string-definition! name bytecode port) + (emit-string port + "char" + (let ([p (open-output-bytes)]) + (display bytecode p) + (get-output-bytes p)) + name)) (define (vm->c:emit-inexact-list! port comma comment?) (vm->c:emit-list! port comma comment? (const:get-inexact-table) (const:get-inexact-counter) @@ -199,23 +195,6 @@ (fprintf port " SYMBOLS[~a] = scheme_make_exact_symbol(SYMBOL_STRS[~a], SYMBOL_LENS[~a]); /* uninterned */~n" pos pos pos))))))) - (define (vm->c:emit-syntax-string-definitions! port) - (let ([l (const:get-syntax-strings)]) - (unless (null? l) - (for-each - (lambda (ss) - (let ([id (syntax-string-id ss)] - [symbols (vm->c:SYMBOLS-name)]) - (fprintf port " SS[~a] = scheme_load_compiled_stx_string(SYNTAX_STRING_~a, ~a);~n" - id id (bytes-length (syntax-string-str ss))) - ;; Reset uninterned symbols: - (let loop ([uposes (syntax-string-uposes ss)][i (syntax-string-ustart ss)]) - (unless (null? uposes) - (fprintf port " ~a[~a] = scheme_compiled_stx_symbol(SCHEME_VEC_ELS(SS[~a])[~a]);~n" - symbols (car uposes) id i) - (loop (cdr uposes) (add1 i)))))) - l)))) - (define (vm->c:emit-inexact-definitions! port) (unless (zero? (const:get-inexact-counter)) (fprintf port " int i;~n") @@ -309,44 +288,7 @@ (fprintf port " int dummy;~n") (emit-static-variable-fields! port (compiler:get-per-load-static-list))) (fprintf port "} Scheme_Per_Load_Statics;~n") - (newline port) - - (let ([ht (make-hash-table)]) - ;; Gather per-invoke statics with the same invoke id - (let ([l (compiler:get-per-invoke-static-list)]) - (for-each (lambda (p) - (let ([mi (cdr p)] - [var (car p)]) - (hash-table-put! ht (varref:module-invoke-id mi) - (cons (cons var (varref:module-invoke-syntax? mi)) - (hash-table-get - ht - (varref:module-invoke-id mi) - (lambda () null)))))) - l) - ;; Make sure that every module has a struct: - (let loop ([i 0]) - (unless (= i (get-num-module-invokes)) - (hash-table-get ht i (lambda () - (hash-table-put! ht i null))) - (loop (add1 i)))) - (hash-table-for-each - ht - (lambda (id vars) - (fprintf port "/* compiler-written per-invoke variables for module ~a */~n" id) - (let ([vars (map car (filter (lambda (i) (not (cdr i))) vars))] - [syntax-vars (map car (filter (lambda (i) (cdr i)) vars))]) - (fprintf port "typedef struct Scheme_Per_Invoke_Statics_~a {~n" id) - (if (null? vars) - (fprintf port " int dummy;~n") - (emit-static-variable-fields! port vars)) - (fprintf port "} Scheme_Per_Invoke_Statics_~a;~n" id) - (fprintf port "typedef struct Scheme_Per_Invoke_Syntax_Statics_~a {~n" id) - (if (null? syntax-vars) - (fprintf port " int dummy;~n") - (emit-static-variable-fields! port syntax-vars)) - (fprintf port "} Scheme_Per_Invoke_Syntax_Statics_~a;~n" id) - (newline port)))))))) + (newline port))) ;; when statics have binding information, this need only register ;; pointer declarations @@ -365,9 +307,7 @@ (unless (set-empty? (compiler:get-primitive-refs)) (register "P")) (unless (not (compiler:any-statics?)) - (register "S")) - (unless (null? (const:get-syntax-strings)) - (register "SS"))) + (register "S"))) (newline port))) (define (vm->c:emit-case-arities-definitions! port) @@ -397,7 +337,7 @@ (fprintf port "~a}~n" vm->c:indent-spaces)))) (caloop (cdr l) (add1 pos))))) - (define (vm->c:emit-top-levels! kind return? per-load? null-self-modidx? count vm-list locals-list + (define (vm->c:emit-top-levels! kind return? per-load? null-self-modidx? count vm-list locals-list globals-list max-arity module mod-syntax? c-port) ;; count == -1 => go to the end of the list (let tls-loop ([i 0] @@ -406,24 +346,16 @@ [ll locals-list] [bl globals-list]) (fprintf c-port - "static ~a ~a_~a(Scheme_Env * env~a~a)~n{~n" + "static ~a ~a_~a(Scheme_Env * env~a)~n{~n" (if return? "Scheme_Object *" "void") kind i - (if (or per-load? module) ", Scheme_Per_Load_Statics *PLS" "") - (if module - (format - ", long phase_shift, Scheme_Object *self_modidx, Scheme_Per_Invoke_~aStatics_~a *PMIS" - (if mod-syntax? "Syntax_" "") - module) - "")) + (if (or per-load? module) ", Scheme_Per_Load_Statics *PLS" "")) (when null-self-modidx? (fprintf c-port "#define self_modidx NULL~n")) (when (> max-arity 0) (fprintf c-port "~aScheme_Object * arg[~a];~n" vm->c:indent-spaces max-arity) - (fprintf c-port "~aScheme_Thread * pr = scheme_current_thread;~n" - vm->c:indent-spaces) (fprintf c-port "~aScheme_Object ** tail_buf;~n" vm->c:indent-spaces)) (let loop ([c (compiler:option:max-exprs-per-top-level-set)][n n][vml vml][ll ll][bl bl]) @@ -437,12 +369,7 @@ (if (or (null? vml) (= n count)) i (tls-loop (add1 i) n vml ll bl))) - (if (not (or (and (not module) - (not (vm:module-body? (car vml)))) - (and module - (vm:module-body? (car vml)) - (is-module-invoke? (vm:module-body-invoke (car vml)) module) - (eq? (vm:module-body-syntax? (car vml)) mod-syntax?)))) + (if module (loop c n (cdr vml) (cdr ll) (cdr bl)) (begin (let ([start (zodiac:zodiac-start (car vml))]) @@ -463,33 +390,12 @@ (string-append vm->c:indent-spaces vm->c:indent-spaces) c-port) - (vm->c-expression (car vml) #f c-port vm->c:indent-by #t) + (vm->c-expression (car vml) #f c-port vm->c:indent-by #t n) (fprintf c-port "~a}~n" vm->c:indent-spaces) (loop (sub1 c) (add1 n) (cdr vml) (cdr ll) (cdr bl)))))))) - (define (vm->c:emit-module-glue! port id num num-syntax) - (define (out syntax? n) - (fprintf port "static void module_invoke~a_~a(" - (if syntax? "_syntax" "") id) - (fprintf port "Scheme_Env *env, long phase_shift, Scheme_Object *self_modidx, void *pls)~n") - (fprintf port "{~n~aScheme_Per_Invoke_~aStatics_~a *PMIS;~n" - vm->c:indent-spaces (if syntax? "Syntax_" "") id) - (let ([s (format "Scheme_Per_Invoke_~aStatics_~a" - (if syntax? "Syntax_" "") id)]) - (fprintf port "~aPMIS = (~a *)scheme_malloc(sizeof(~a));~n" - vm->c:indent-spaces s s)) - (let loop ([j 0]) - (unless (j . > . n) - (fprintf port "~amodule_~abody_~a_~a(env, (Scheme_Per_Load_Statics *)pls, phase_shift, self_modidx, PMIS);~n" - vm->c:indent-spaces (if syntax? "syntax_" "") id j) - (loop (add1 j)))) - (fprintf port "}~n~n")) - - (out #f num) - (out #t num-syntax)) - (define vm->c:emit-vehicle-prototype (lambda (port number) (let ([v (get-vehicle number)]) @@ -536,8 +442,6 @@ (loop (+ n 1))))) (when (> max-arity 0) ; tail-buffer-setup - (fprintf port "~aScheme_Thread * pr = scheme_current_thread;~n" - vm->c:indent-spaces) (fprintf port "~aScheme_Object ** tail_buf;~n" vm->c:indent-spaces))) @@ -577,13 +481,6 @@ [(scheme-object) "Scheme_Object *"] [(scheme-bucket) "Scheme_Bucket *"] [(scheme-per-load-static) "struct Scheme_Per_Load_Statics *"] - [(scheme-per-invoke-static) - (let ([mi (rep:atomic/invoke-module-invoke rep)]) - (format "struct Scheme_Per_Invoke_~aStatics_~a *" - (if (varref:module-invoke-syntax? mi) - "Syntax_" - "") - (varref:module-invoke-id mi)))] [(label) "int"] [(prim) "Scheme_Closed_Primitive_Proc"] [(prim-case) "Scheme_Closed_Case_Primitive_Proc"] @@ -633,10 +530,6 @@ (unless top-level? (fprintf port "~aScheme_Per_Load_Statics * PLS;~n" indent))] - [(varref:module-invoke? var) - (unless top-level? - (fprintf port "~aScheme_Per_Invoke_Statics_~a * PMIS;~n" - indent (varref:module-invoke-id var)))] [else (fprintf port "~aScheme_Bucket * G~a;~n" indent @@ -647,8 +540,7 @@ (lambda (globals indent port) (for-each (lambda (var) - (unless (or (const:per-load-statics-table? var) - (varref:module-invoke? var)) + (unless (const:per-load-statics-table? var) (let* ([name (vm->c:convert-symbol (mod-glob-cname var))] [et? (mod-glob-exp-time? var)] [ed? (mod-glob-exp-def? var)] @@ -673,7 +565,6 @@ "~a~a" (cond [(varref:has-attribute? modidx varref:per-load-static) "PLS->"] - [(varref:has-attribute? modidx varref:per-invoke-static) "PMIS->"] [else "S."]) (vm->c:convert-symbol (zodiac:varref-var modidx)))) "") @@ -874,17 +765,6 @@ (if (compiler:option:unpack-environments) undefines (cons "PLS" undefines))))] - [(varref:module-invoke? var) - (begin - (fprintf port - (if (compiler:option:unpack-environments) - "~aPMIS = env->pmis;~n" - "#~adefine PMIS env->pmis~n") - indent) - (loop (cdr vars) - (if (compiler:option:unpack-environments) - undefines - (cons "PMIS" undefines))))] [else (let* ([vname (mod-glob-cname var)] [name (vm->c:convert-symbol vname)] @@ -1038,7 +918,7 @@ (define vm->c:block-statement? - (one-of vm:if? vm:sequence? vm:module-body?)) + (one-of vm:if? vm:sequence?)) (define vm->c:extract-inferred-name (let ([nullsym (string->symbol "NULL")]) @@ -1076,7 +956,7 @@ (one-of primitive? primitive-closure?)) (define vm->c-expression - (lambda (ast code port indent-level no-seq-braces?) + (lambda (ast code port indent-level no-seq-braces? top_level_n) (let process ([ast ast] [indent-level indent-level] [own-line? #t] [braces? (not no-seq-braces?)]) (letrec ([emit-indentation (lambda () (display (make-string indent-level #\ ) @@ -1099,9 +979,8 @@ (cond ;; (%sequence V ...) -> { M; ... } - [(or (vm:sequence? ast) - (vm:module-body? ast)) - (let* ([seq ((if (vm:sequence? ast) vm:sequence-vals vm:module-body-vals) ast)]) + [(vm:sequence? ast) + (let* ([seq (vm:sequence-vals ast)]) (when braces? (emit-indentation) (emit "{~n")) (for-each (lambda (v) (process v (indent) #t #t) @@ -1153,6 +1032,8 @@ (emit-indentation) (emit "if (~a.val == SCHEME_MULTIPLE_VALUES) {~n" var) (emit-indentation) + (emit " Scheme_Thread *pr = scheme_current_thread;\n") + (emit-indentation) (emit " ~a.array = pr->ku.multiple.array;~n" var) (emit-indentation) (emit " ~a.count = pr->ku.multiple.count;~n" var) @@ -1163,8 +1044,8 @@ [(vm:begin0-extract? ast) (let ([var (vm->c:convert-symbol (vm:local-varref-var (vm:begin0-extract-var ast)))]) - (emit "(pr->ku.multiple.array = ~a.array," var) - (emit " pr->ku.multiple.count = ~a.count, " var) + (emit "(scheme_current_thread->ku.multiple.array = ~a.array," var) + (emit " scheme_current_thread->ku.multiple.count = ~a.count, " var) (emit " ~a.val)" var))] ;; single value: (set! L R) -> L = R; @@ -1239,82 +1120,36 @@ (emit ";~n") (aloop (cdr vars) (+ n 1)))) ))))] - - - ;; (define-syntax! x R) or (define-for-syntax! x R) - [(vm:syntax!? ast) - (let* ([process-set! - (lambda (target val process-val? return-arity-ok?) - (let ([sym - (vm->c:make-symbol-const-string - (compiler:get-symbol-const! #f (zodiac:varref-var target)))] - [in-module? (varref:has-attribute? target varref:in-module)]) - (when process-val? - (emit "{ Scheme_Object *mcv = ") - (process val indent-level #f #t) - (emit "; ")) - (unless return-arity-ok? - (emit " if (mcv != SCHEME_MULTIPLE_VALUES || scheme_multiple_count) {") - (emit " NO_MULTIPLE_VALUES(mcv); ")) - (let ([for-stx? (zodiac:top-level-varref-expdef? target)]) - (emit "scheme_~a(~ascheme_global_~abucket(~a, ~a), " - (if for-stx? "set_global_bucket" "install_macro") - (if for-stx? "NULL, " "") - (if for-stx? "" "keyword_") - sym - (if in-module? "env" "SCHEME_CURRENT_ENV(pr)")) - (if process-val? - (emit "mcv") - (emit val)) - (when for-stx? - (emit ", 1")) - (emit ")")) - (when (or (not return-arity-ok?) process-val?) - (emit ";")) - (unless return-arity-ok? - (emit " }")) - (when process-val? - (emit " }"))))] - [vars (vm:syntax!-vars ast)] - [val (vm:syntax!-val ast)] - [in-mod? (vm:syntax!-in-mod? ast)] - [num-to-set (length vars)] - [return-arity (if (single-arity? val) - 1 - #f)]) - (emit-indentation) - (let ([return-arity-ok? - (and return-arity - (number? return-arity) - (= return-arity num-to-set))]) - (if (= num-to-set 1) - - (process-set! (car vars) val #t return-arity-ok?) - - (begin - (emit "{ Scheme_Object * res = ") - (process val indent-level #f #t) - (emit "; ") - (unless return-arity-ok? - (unless in-mod? - (emit "if (res != SCHEME_MULTIPLE_VALUES || scheme_multiple_count) ")) - (emit "CHECK_MULTIPLE_VALUES(res, ~a);" num-to-set)) - (emit "}") - (if (not (null? vars)) - (emit "~n")) - (unless in-mod? - (emit-indentation) - (emit "if (scheme_multiple_count) {~n")) - (let aloop ([vars vars] [n 0]) - (unless (null? vars) - (emit-indentation) - (process-set! (car vars) (format "scheme_multiple_array[~a]" n) #f #t) - (emit ";~n") - (aloop (cdr vars) (+ n 1)))) - (unless in-mod? - (emit-indentation) - (emit "}~n")) - ))))] + + [(or (vm:global-prepare? ast) + (vm:global-lookup? ast) + (vm:global-assign? ast) + (vm:safe-vector-ref? ast)) + (let-values ([(get-vec get-pos proc) + (cond + [(vm:global-prepare? ast) + (values vm:global-prepare-vec + vm:global-prepare-pos + "MZC_GLOBAL_PREPARE")] + [(vm:global-lookup? ast) + (values vm:global-lookup-vec + vm:global-lookup-pos + "MZC_GLOBAL_LOOKUP")] + [(vm:global-assign? ast) + (values vm:global-assign-vec + vm:global-assign-pos + "MZC_GLOBAL_ASSIGN")] + [(vm:safe-vector-ref? ast) + (values vm:safe-vector-ref-vec + vm:safe-vector-ref-pos + "MZC_KNOWN_SAFE_VECTOR_REF")])]) + (emit "~a(" proc) + (process (get-vec ast) indent-level #f #t) + (emit ", ~a" (get-pos ast)) + (when (vm:global-assign? ast) + (emit ", ") + (process (vm:global-assign-val ast) indent-level #f #t)) + (emit ")"))] ;; (%args A ...) -> arg[0] = A; ... [(vm:args? ast) @@ -1322,7 +1157,7 @@ (when (and (eq? arg-type:tail-arg (vm:args-type ast)) (not (null? (vm:args-vals ast)))) (emit-indentation) - (emit "tail_buf = scheme_tail_apply_buffer_wp(~a, pr);~n" + (emit "tail_buf = scheme_tail_apply_buffer_wp(~a, scheme_current_thread);~n" (length (vm:args-vals ast)))) (if (null? (vm:args-vals ast)) (emit-indentation) @@ -1421,13 +1256,6 @@ (emit-expr (format "CHECK_GLOBAL_BOUND(G~a)" (vm->c:convert-symbol (mod-glob-cname (vm:check-global-var ast)))))] - - [(vm:module-create? ast) - (emit-expr "scheme_declare_module(") - (process (vm:module-create-shape ast) indent-level #f #f) - (emit ", module_invoke_~a, module_invoke_syntax_~a, PLS, SCHEME_CURRENT_ENV(pr)" - (vm:module-create-id ast) (vm:module-create-id ast)) - (emit ")")] ;; with-continuation-mark [(vm:wcm-mark!? ast) @@ -1474,7 +1302,7 @@ (emit-expr "return _scheme_tail_apply_no_copy_wp(") (process (vm:tail-apply-closure ast) indent-level #f #t) (let ([c (vm:tail-apply-argc ast)]) - (emit ", ~a, ~a, pr)" c (if (zero? c) "NULL" 'tail_buf)))] + (emit ", ~a, ~a, scheme_current_thread)" c (if (zero? c) "NULL" 'tail_buf)))] ;; (tail-call