diff --git a/collects/compiler/decompile.rkt b/collects/compiler/decompile.rkt index 1411e6d50f..2217060f65 100644 --- a/collects/compiler/decompile.rkt +++ b/collects/compiler/decompile.rkt @@ -78,7 +78,20 @@ (let-values ([(n b) (module-path-index-split modidx)]) (and (not n) (not b)))) (string->symbol (format "_~a" sym)) - (string->symbol (format "_~s@~s~a" sym (mpi->string modidx) + (string->symbol (format "_~s~a@~s~a" + sym + (match constantness + ['constant ":c"] + ['fixed ":f"] + [(function-shape a pm?) + (if pm? ":P" ":p")] + [(struct-type-shape c) ":t"] + [(constructor-shape a) ":mk"] + [(predicate-shape) ":?"] + [(accessor-shape c) ":ref"] + [(mutator-shape c) ":set!"] + [else ""]) + (mpi->string modidx) (if (zero? phase) "" (format "/~a" phase)))))] diff --git a/collects/compiler/demodularizer/alpha.rkt b/collects/compiler/demodularizer/alpha.rkt index 9b459b6ca3..2f3c71398d 100644 --- a/collects/compiler/demodularizer/alpha.rkt +++ b/collects/compiler/demodularizer/alpha.rkt @@ -1,5 +1,6 @@ -#lang racket -(require compiler/zo-parse) +#lang racket/base + +(require racket/match racket/contract compiler/zo-parse) (define (alpha-vary-ctop top) (match top diff --git a/collects/compiler/demodularizer/batch.rkt b/collects/compiler/demodularizer/batch.rkt index afb495a473..bd98894ad3 100644 --- a/collects/compiler/demodularizer/batch.rkt +++ b/collects/compiler/demodularizer/batch.rkt @@ -1,4 +1,5 @@ -#lang racket +#lang racket/base + #| Here's the idea: @@ -40,6 +41,7 @@ Here's the idea: (require racket/pretty racket/system + racket/cmdline "mpi.rkt" "util.rkt" "nodep.rkt" diff --git a/collects/compiler/demodularizer/gc-toplevels.rkt b/collects/compiler/demodularizer/gc-toplevels.rkt index aa6b780389..ad8c74faee 100644 --- a/collects/compiler/demodularizer/gc-toplevels.rkt +++ b/collects/compiler/demodularizer/gc-toplevels.rkt @@ -1,5 +1,10 @@ -#lang racket -(require compiler/zo-parse +#lang racket/base + +(require racket/match + racket/list + racket/dict + racket/contract + compiler/zo-parse "util.rkt") ; XXX Use efficient set structure @@ -150,21 +155,20 @@ (match (dict-ref g n) [(struct refs (n-tls n-stxs)) (hash-set! visited? n #t) - (local - [(define-values (new-tls1 new-stxs1) - (for/fold ([new-tls tls] - [new-stxs stxs]) - ([tl (in-list n-tls)]) - (visit-tl tl new-tls new-stxs))) - (define new-stxs2 - (for/fold ([new-stxs new-stxs1]) - ([stx (in-list n-stxs)]) - (define this-stx (visit-stx stx)) - (if this-stx - (list* this-stx new-stxs) - new-stxs)))] - (values (list* n new-tls1) - new-stxs2))]))) + (define-values (new-tls1 new-stxs1) + (for/fold ([new-tls tls] + [new-stxs stxs]) + ([tl (in-list n-tls)]) + (visit-tl tl new-tls new-stxs))) + (define new-stxs2 + (for/fold ([new-stxs new-stxs1]) + ([stx (in-list n-stxs)]) + (define this-stx (visit-stx stx)) + (if this-stx + (list* this-stx new-stxs) + new-stxs))) + (values (list* n new-tls1) + new-stxs2)]))) (define stx-visited? (make-hasheq)) (define (visit-stx n) (if (hash-has-key? stx-visited? n) diff --git a/collects/compiler/demodularizer/merge.rkt b/collects/compiler/demodularizer/merge.rkt index 5b087e257f..f118e6b9e4 100644 --- a/collects/compiler/demodularizer/merge.rkt +++ b/collects/compiler/demodularizer/merge.rkt @@ -1,5 +1,9 @@ -#lang racket -(require compiler/zo-parse +#lang racket/base + +(require racket/list + racket/match + racket/contract + compiler/zo-parse "util.rkt" "mpi.rkt" "nodep.rkt" @@ -156,12 +160,12 @@ (cond [(mod-lift-start . <= . n) ; This is a lift - (local [(define which-lift (- n mod-lift-start)) - (define lift-tl (+ top-lift-start lift-offset which-lift))] - (when (lift-tl . >= . max-toplevel) - (error 'merge-module "[~S] lift error: orig(~a) which(~a) max(~a) lifts(~a) now(~a)" - name n which-lift num-mod-toplevels mod-num-lifts lift-tl)) - lift-tl)] + (define which-lift (- n mod-lift-start)) + (define lift-tl (+ top-lift-start lift-offset which-lift)) + (when (lift-tl . >= . max-toplevel) + (error 'merge-module "[~S] lift error: orig(~a) which(~a) max(~a) lifts(~a) now(~a)" + name n which-lift num-mod-toplevels mod-num-lifts lift-tl)) + lift-tl] [else (list-ref toplevel-remap n)])) (lambda (n) diff --git a/collects/compiler/demodularizer/module.rkt b/collects/compiler/demodularizer/module.rkt index 9c907a5153..dca4498fec 100644 --- a/collects/compiler/demodularizer/module.rkt +++ b/collects/compiler/demodularizer/module.rkt @@ -1,5 +1,9 @@ -#lang racket -(require compiler/zo-parse +#lang racket/base + +(require racket/list + racket/match + racket/contract + compiler/zo-parse "util.rkt") (define (->module-path-index s) diff --git a/collects/compiler/demodularizer/mpi.rkt b/collects/compiler/demodularizer/mpi.rkt index 10f8cd23a5..bb430570dc 100644 --- a/collects/compiler/demodularizer/mpi.rkt +++ b/collects/compiler/demodularizer/mpi.rkt @@ -1,5 +1,7 @@ -#lang racket -(require syntax/modresolve) +#lang racket/base + +(require racket/contract + syntax/modresolve) (define current-module-path (make-parameter #f)) diff --git a/collects/compiler/demodularizer/nodep.rkt b/collects/compiler/demodularizer/nodep.rkt index 60afbaf7ec..4e55b46545 100644 --- a/collects/compiler/demodularizer/nodep.rkt +++ b/collects/compiler/demodularizer/nodep.rkt @@ -1,5 +1,9 @@ -#lang racket -(require compiler/zo-parse +#lang racket/base + +(require racket/list + racket/match + racket/contract + compiler/zo-parse "util.rkt" "mpi.rkt" racket/set) @@ -92,7 +96,8 @@ (define (nodep-form form phase) (if (mod? form) - (local [(define-values (modvar-rewrite lang-info mods) (nodep-module form phase))] + (let-values ([(modvar-rewrite lang-info mods) + (nodep-module form phase)]) (values modvar-rewrite lang-info (make-splice mods))) (error 'nodep-form "Doesn't support non mod forms"))) diff --git a/collects/compiler/demodularizer/replace-modidx.rkt b/collects/compiler/demodularizer/replace-modidx.rkt index 7ad45cbc56..f470e2b8f1 100644 --- a/collects/compiler/demodularizer/replace-modidx.rkt +++ b/collects/compiler/demodularizer/replace-modidx.rkt @@ -1,6 +1,10 @@ -#lang racket -(require unstable/struct +#lang racket/base + +(require racket/match + racket/vector + unstable/struct "util.rkt") + (provide replace-modidx) (define (replace-modidx expr self-modidx) diff --git a/collects/compiler/demodularizer/update-toplevels.rkt b/collects/compiler/demodularizer/update-toplevels.rkt index 3cc4ef9e14..6c1c83704e 100644 --- a/collects/compiler/demodularizer/update-toplevels.rkt +++ b/collects/compiler/demodularizer/update-toplevels.rkt @@ -1,5 +1,8 @@ -#lang racket -(require compiler/zo-structs +#lang racket/base + +(require racket/match + racket/contract + compiler/zo-structs "util.rkt") (define (update-toplevels toplevel-updater topsyntax-updater topsyntax-new-midpt) diff --git a/collects/compiler/demodularizer/util.rkt b/collects/compiler/demodularizer/util.rkt index 1865bc133f..e18966798e 100644 --- a/collects/compiler/demodularizer/util.rkt +++ b/collects/compiler/demodularizer/util.rkt @@ -1,5 +1,7 @@ -#lang racket -(require compiler/zo-parse) +#lang racket/base + +(require racket/contract + compiler/zo-parse) (define (prefix-syntax-start pre) (length (prefix-toplevels pre))) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 9f39c208ad..b9e1333a99 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -604,13 +604,51 @@ [(? void?) (out-byte CPT_VOID out)] [(struct module-variable (modidx sym pos phase constantness)) + (define (to-sym n) (string->symbol (format "struct~a" n))) (out-byte CPT_MODULE_VAR out) (out-anything modidx out) (out-anything sym out) + (out-anything (cond + [(function-shape? constantness) + (let ([a (function-shape-arity constantness)]) + (cond + [(arity-at-least? a) + (bitwise-ior (arithmetic-shift (- (add1 (arity-at-least-value a))) 1) + (if (function-shape-preserves-marks? constantness) 1 0))] + [(list? a) + (string->symbol (apply + string-append + (add-between + (for/list ([a (in-list a)]) + (define n (if (arity-at-least? a) + (- (add1 (arity-at-least-value a))) + a)) + (number->string n)) + ":")))] + [else + (bitwise-ior (arithmetic-shift a 1) + (if (function-shape-preserves-marks? constantness) 1 0))]))] + [(struct-type-shape? constantness) + (to-sym (arithmetic-shift (struct-type-shape-field-count constantness) + 4))] + [(constructor-shape? constantness) + (to-sym (bitwise-ior 1 (arithmetic-shift (constructor-shape-arity constantness) + 4)))] + [(predicate-shape? constantness) (to-sym 2)] + [(accessor-shape? constantness) + (to-sym (bitwise-ior 3 (arithmetic-shift (accessor-shape-field-count constantness) + 4)))] + [(mutator-shape? constantness) + (to-sym (bitwise-ior 4 (arithmetic-shift (mutator-shape-field-count constantness) + 4)))] + [(struct-other-shape? constantness) + (to-sym 5)] + [else #f]) + out) (case constantness - [(constant) (out-number -4 out)] + [(#f) (void)] [(fixed) (out-number -5 out)] - [else (void)]) + [else (out-number -4 out)]) (unless (zero? phase) (out-number -2 out) (out-number phase out)) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 13856e48e0..18e7426b01 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -856,6 +856,7 @@ [(module-var) (let ([mod (read-compact cp)] [var (read-compact cp)] + [shape (read-compact cp)] [pos (read-compact-number cp)]) (let-values ([(flags mod-phase pos) (let loop ([pos pos]) @@ -869,6 +870,33 @@ [else (values 0 0 pos)]))]) (make-module-variable mod var pos mod-phase (cond + [shape + (cond + [(number? shape) + (define n (arithmetic-shift shape -1)) + (make-function-shape (if (negative? n) + (make-arity-at-least (sub1 (- n))) + n) + (odd? shape))] + [(and (symbol? shape) + (regexp-match? #rx"^struct" (symbol->string shape))) + (define n (string->number (substring (symbol->string shape) 6))) + (case (bitwise-and n #x7) + [(0) (make-struct-type-shape (arithmetic-shift n -3))] + [(1) (make-constructor-shape (arithmetic-shift n -3))] + [(2) (make-predicate-shape)] + [(3) (make-accessor-shape (arithmetic-shift n -3))] + [(4) (make-mutator-shape (arithmetic-shift n -3))] + [else (make-struct-other-shape)])] + [else + ;; parse symbol as ":"-separated sequence of arities + (make-function-shape + (for/list ([s (regexp-split #rx":" (symbol->string shape))]) + (define i (string->number s)) + (if (negative? i) + (make-arity-at-least (sub1 (- i))) + i)) + #f)])] [(not (zero? (bitwise-and #x1 flags))) 'constant] [(not (zero? (bitwise-and #x2 flags))) 'fixed] [else #f]))))] diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index 3fc6b2c11d..a2aa9c284b 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -38,13 +38,26 @@ [(_ id . rest) (define-form-struct* id (id zo) . rest)])) +(define-form-struct function-shape ([arity procedure-arity?] + [preserves-marks? boolean?])) + +(define-form-struct struct-shape ()) +(define-form-struct (constructor-shape struct-shape) ([arity exact-nonnegative-integer?])) +(define-form-struct (predicate-shape struct-shape) ()) +(define-form-struct (accessor-shape struct-shape) ([field-count exact-nonnegative-integer?])) +(define-form-struct (mutator-shape struct-shape) ([field-count exact-nonnegative-integer?])) +(define-form-struct (struct-type-shape struct-shape) ([field-count exact-nonnegative-integer?])) +(define-form-struct (struct-other-shape struct-shape) ()) + ;; In toplevels of resove prefix: (define-form-struct global-bucket ([name symbol?])) ; top-level binding (define-form-struct module-variable ([modidx module-path-index?] [sym symbol?] [pos exact-integer?] [phase exact-nonnegative-integer?] - [constantness (or/c #f 'constant 'fixed)])) + [constantness (or/c #f 'constant 'fixed + function-shape? + struct-shape?)])) ;; Syntax object (define ((alist/c k? v?) l) diff --git a/collects/tests/racket/embed-me21.rkt b/collects/tests/racket/embed-me21.rkt new file mode 100644 index 0000000000..dbf09c11cb --- /dev/null +++ b/collects/tests/racket/embed-me21.rkt @@ -0,0 +1,12 @@ +#lang racket/base +(require racket/match) + +;; check using `racket/match', particularly with a pattern +;; that eneds run-time support that may go through a +;; compile-time `lazy-require': + +(match "x" + [(pregexp "x") + (with-output-to-file "stdout" + (lambda () (printf "This is 21.\n")) + #:exists 'append)]) diff --git a/collects/tests/racket/embed.rktl b/collects/tests/racket/embed.rktl index 39da0cdd83..be3027b221 100644 --- a/collects/tests/racket/embed.rktl +++ b/collects/tests/racket/embed.rktl @@ -227,6 +227,7 @@ (one-mz-test "embed-me17.rkt" "This is 17.\n" #f) (one-mz-test "embed-me18.rkt" "This is 18.\n" #f) (one-mz-test "embed-me19.rkt" "This is 19.\n" #f) + (one-mz-test "embed-me21.rkt" "This is 21.\n" #f) ;; Try unicode expr and cmdline: (prepare dest "unicode")