diff --git a/collects/compiler/decompile.rkt b/collects/compiler/decompile.rkt index 0c9c7049b3..1e84e2cad0 100644 --- a/collects/compiler/decompile.rkt +++ b/collects/compiler/decompile.rkt @@ -2,7 +2,8 @@ (require compiler/zo-parse syntax/modcollapse scheme/port - scheme/match) + scheme/match + racket/set) (provide decompile) @@ -42,6 +43,8 @@ ;; ---------------------------------------- +(define-struct glob-desc (vars num-tls num-stxs num-lifts)) + ;; Main entry: (define (decompile top) (match top @@ -56,30 +59,34 @@ (match a-prefix [(struct prefix (num-lifts toplevels stxs)) (let ([lift-ids (for/list ([i (in-range num-lifts)]) - (gensym 'lift))] + (gensym 'lift))] [stx-ids (map (lambda (i) (gensym 'stx)) stxs)]) - (values (append - (map (lambda (tl) - (match tl - [#f '#%linkage] - [(? symbol?) (string->symbol (format "_~a" tl))] - [(struct global-bucket (name)) - (string->symbol (format "_~a" name))] - [(struct module-variable (modidx sym pos phase)) - (if (and (module-path-index? modidx) - (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) - (if (zero? phase) - "" - (format "/~a" phase)))))] - [else (error 'decompile-prefix "bad toplevel: ~e" tl)])) - toplevels) - stx-ids - (if (null? stx-ids) null '(#%stx-array)) - lift-ids) + (values (glob-desc + (append + (map (lambda (tl) + (match tl + [#f '#%linkage] + [(? symbol?) (string->symbol (format "_~a" tl))] + [(struct global-bucket (name)) + (string->symbol (format "_~a" name))] + [(struct module-variable (modidx sym pos phase)) + (if (and (module-path-index? modidx) + (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) + (if (zero? phase) + "" + (format "/~a" phase)))))] + [else (error 'decompile-prefix "bad toplevel: ~e" tl)])) + toplevels) + stx-ids + (if (null? stx-ids) null '(#%stx-array)) + lift-ids) + (length toplevels) + (length stxs) + num-lifts) (map (lambda (stx id) `(define ,id ,(if stx `(#%decode-syntax ,(stx-encoded stx)) @@ -117,7 +124,7 @@ `(define-values ,(map (lambda (tl) (match tl [(struct toplevel (depth pos const? mutated?)) - (list-ref/protect globs pos 'def-vals)])) + (list-ref/protect (glob-desc-vars globs) pos 'def-vals)])) ids) ,(decompile-expr rhs globs stack closed))] [(struct def-syntaxes (ids rhs prefix max-let-depth)) @@ -154,7 +161,7 @@ (define (extract-id expr) (match expr - [(struct lam (name flags num-params arg-types rest? closure-map closure-types max-let-depth body)) + [(struct lam (name flags num-params arg-types rest? closure-map closure-types tl-map max-let-depth body)) (extract-name name)] [(struct case-lam (name lams)) (extract-name name)] @@ -179,7 +186,7 @@ (define (decompile-tl expr globs stack closed no-check?) (match expr [(struct toplevel (depth pos const? ready?)) - (let ([id (list-ref/protect globs pos 'toplevel)]) + (let ([id (list-ref/protect (glob-desc-vars globs) pos 'toplevel)]) (if (or no-check? const? ready?) id `(#%checked ,id)))])) @@ -191,7 +198,7 @@ [(struct varref (tl)) `(#%variable-reference ,(decompile-tl tl globs stack closed #t))] [(struct topsyntax (depth pos midpt)) - (list-ref/protect globs (+ midpt pos) 'topsyntax)] + (list-ref/protect (glob-desc-vars globs) (+ midpt pos) 'topsyntax)] [(struct primval (id)) (hash-ref primitive-table id)] [(struct assign (id rhs undef-ok?)) @@ -291,7 +298,7 @@ (define (decompile-lam expr globs stack closed) (match expr [(struct closure (lam gen-id)) (decompile-lam lam globs stack closed)] - [(struct lam (name flags num-params arg-types rest? closure-map closure-types max-let-depth body)) + [(struct lam (name flags num-params arg-types rest? closure-map closure-types tl-map max-let-depth body)) (let ([vars (for/list ([i (in-range num-params)] [type (in-list arg-types)]) (gensym (format "~a~a-" @@ -315,7 +322,16 @@ `(flonum ,c) c)) captures - closure-types)))) + closure-types) + ,@(if (not tl-map) + '() + (list + (for/list ([pos (in-set tl-map)]) + (list-ref/protect (glob-desc-vars globs) + (if (pos . < . (glob-desc-num-tls globs)) + pos + (+ pos (glob-desc-num-stxs globs) 1)) + 'lam))))))) ,(decompile-expr body globs (append captures (append vars rest-vars)) diff --git a/collects/compiler/demodularizer/gc-toplevels.rkt b/collects/compiler/demodularizer/gc-toplevels.rkt index 79401002d5..e03ad418a7 100644 --- a/collects/compiler/demodularizer/gc-toplevels.rkt +++ b/collects/compiler/demodularizer/gc-toplevels.rkt @@ -74,7 +74,7 @@ (for-each (lambda (f) (build-graph! lhs f)) forms)] [(struct splice (forms)) (for-each (lambda (f) (build-graph! lhs f)) forms)] - [(and l (struct lam (name flags num-params param-types rest? closure-map closure-types max-let-depth body))) + [(and l (struct lam (name flags num-params param-types rest? closure-map closure-types tl-map max-let-depth body))) (build-graph! lhs body)] [(and c (struct closure (code gen-id))) (build-graph! lhs code)] @@ -206,8 +206,9 @@ (make-seq (filter identity (map update forms)))] [(struct splice (forms)) (make-splice (filter identity (map update forms)))] - [(and l (struct lam (name flags num-params param-types rest? closure-map closure-types max-let-depth body))) + [(and l (struct lam (name flags num-params param-types rest? closure-map closure-types tl-map max-let-depth body))) (struct-copy lam l + [toplevel-map #f] ; consevrative [body (update body)])] [(and c (struct closure (code gen-id))) (struct-copy closure c diff --git a/collects/compiler/demodularizer/update-toplevels.rkt b/collects/compiler/demodularizer/update-toplevels.rkt index c6d1f4d9c6..e3cdda6110 100644 --- a/collects/compiler/demodularizer/update-toplevels.rkt +++ b/collects/compiler/demodularizer/update-toplevels.rkt @@ -20,8 +20,9 @@ (make-seq (map update forms))] [(struct splice (forms)) (make-splice (map update forms))] - [(and l (struct lam (name flags num-params param-types rest? closure-map closure-types max-let-depth body))) + [(and l (struct lam (name flags num-params param-types rest? closure-map closure-types tl-map max-let-depth body))) (struct-copy lam l + [toplevel-map #f] ; conservative [body (update body)])] [(and c (struct closure (code gen-id))) (struct-copy closure c diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index d670f06eea..78559d05d5 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -968,7 +968,7 @@ (define (out-lam expr out) (match expr - [(struct lam (name flags num-params param-types rest? closure-map closure-types max-let-depth body)) + [(struct lam (name flags num-params param-types rest? closure-map closure-types toplevel-map max-let-depth body)) (let* ([l (protect-quote body)] [any-refs? (or (ormap (lambda (t) (memq t '(ref flonum))) param-types) (ormap (lambda (t) (memq t '(flonum))) closure-types))] @@ -1001,7 +1001,9 @@ l)] [l (if any-refs? (cons (vector-length closure-map) l) - l)]) + l)] + [tl-map (for/fold ([v 0]) ([i (in-set toplevel-map)]) + (bitwise-ior v (arithmetic-shift 1 i)))]) (out-marshaled unclosed-procedure-type-num (list* (+ (if rest? CLOS_HAS_REST 0) @@ -1012,6 +1014,13 @@ (if (memq 'single-result flags) CLOS_SINGLE_RESULT 0)) num-all-params max-let-depth + (if (tl-map . < . #x7FFFFFFF) + tl-map + ;; Encode as an even-sized vector of 16-bit integers: + (let ([len (* 2 (quotient (+ (integer-length tl-map) 31) 32))]) + (for/vector ([i (in-range len)]) + (let ([s (* i 16)]) + (bitwise-bit-field tl-map s (+ s 16)))))) name l) out))])) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 2290bc30bc..7f8770ee44 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -5,7 +5,8 @@ scheme/list unstable/struct compiler/zo-structs - racket/dict) + racket/dict + racket/set) (provide zo-parse) (provide (all-from-out compiler/zo-structs)) @@ -86,7 +87,7 @@ (define CLOS_SINGLE_RESULT 32) (define BITS_PER_MZSHORT 32) (match v - [`(,flags ,num-params ,max-let-depth ,name ,v . ,rest) + [`(,flags ,num-params ,max-let-depth ,tl-map ,name ,v . ,rest) (let ([rest? (positive? (bitwise-and flags CLOS_HAS_REST))]) (let*-values ([(closure-size closed-over body) (if (zero? (bitwise-and flags CLOS_HAS_REF_ARGS)) @@ -132,6 +133,20 @@ (vector-copy! v2 0 closed-over 0 closure-size) v2)) closure-types + (and tl-map + (let* ([bits (if (exact-integer? tl-map) + tl-map + (for/fold ([i 0]) ([v (in-list tl-map)] + [s (in-naturals)]) + (bitwise-ior i (arithmetic-shift v 16))))] + [len (integer-length bits)]) + (list->set + (let loop ([bit 0]) + (cond + [(bit . >= . len) null] + [(bitwise-bit-set? bits bit) + (cons bit (loop (add1 bit)))] + [else (loop (add1 bit))]))))) max-let-depth body)))])) diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index b9919e4ff3..2d0e920177 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -2,7 +2,8 @@ (require mzlib/etc scheme/match scheme/contract - scheme/list) + scheme/list + racket/set) #| Unresolved issues @@ -138,6 +139,7 @@ [rest? boolean?] [closure-map (vectorof exact-nonnegative-integer?)] [closure-types (listof (or/c 'val/ref 'flonum))] + [toplevel-map (or/c #f (set/c exact-nonnegative-integer?))] [max-let-depth exact-nonnegative-integer?] [body (or/c expr? seq? any/c)])) ; `lambda' (define-form-struct (closure expr) ([code lam?] [gen-id symbol?])) ; a static closure (nothing to close over)