diff --git a/collects/compiler/decompile.ss b/collects/compiler/decompile.ss index 23a9b70652..819e86569b 100644 --- a/collects/compiler/decompile.ss +++ b/collects/compiler/decompile.ss @@ -90,7 +90,8 @@ (define (decompile-module mod-form stack) (match mod-form - [(struct mod (name self-modidx prefix provides requires body syntax-body max-let-depth)) + [(struct mod (name self-modidx prefix provides requires body syntax-body unexported + max-let-depth dummy lang-info internal-context)) (let-values ([(globs defns) (decompile-prefix prefix)] [(stack) (append '(#%modvars) stack)] [(closed) (make-hasheq)]) @@ -135,6 +136,8 @@ `(begin ,@(map (lambda (form) (decompile-form form globs stack closed)) forms))] + [(struct req (reqs dummy)) + `(#%require . (#%decode-syntax ,reqs))] [else (decompile-expr form globs stack closed)])) diff --git a/collects/compiler/zo-marshal.ss b/collects/compiler/zo-marshal.ss index 7a25602588..1bce9921d8 100644 --- a/collects/compiler/zo-marshal.ss +++ b/collects/compiler/zo-marshal.ss @@ -71,23 +71,26 @@ (define (traverse-prefix a-prefix visit) (match a-prefix [(struct prefix (num-lifts toplevels stxs)) - (for-each (lambda (stx) (traverse-toplevel stx visit)) stxs) + (for-each (lambda (stx) (traverse-toplevel stx visit)) toplevels) (for-each (lambda (stx) (traverse-stx stx visit)) stxs)])) (define (traverse-module mod-form visit) (match mod-form - [(struct mod (name self-modidx prefix provides requires body syntax-body max-let-depth)) - (error "cannot handle modules, yet") + [(struct mod (name self-modidx prefix provides requires body syntax-body unexported + max-let-depth dummy lang-info internal-context)) (traverse-data name visit) (traverse-data self-modidx visit) (traverse-prefix prefix visit) + (for-each (lambda (f) (map (lambda (v) (traverse-data v visit)) (cdr f))) requires) (for-each (lambda (f) (traverse-form f prefix)) body) - (for-each (lambda (f) (traverse-form f prefix)) syntax-body)])) + (for-each (lambda (f) (traverse-form f prefix)) syntax-body) + (traverse-data lang-info visit) + (traverse-data internal-context visit)])) (define (traverse-toplevel tl visit) (match tl [#f (void)] - [(? symbol?) (visit tl)] + [(? symbol?) (traverse-data tl visit)] [(struct global-bucket (name)) (void)] [(struct module-variable (modidx sym pos phase)) @@ -180,9 +183,13 @@ (keyword? expr) (string? expr) (bytes? expr) - (path? expr) - (module-path-index? expr)) + (path? expr)) (visit expr)] + [(module-path-index? expr) + (visit expr) + (let-values ([(name base) (module-path-index-split expr)]) + (traverse-data name visit) + (traverse-data base visit))] [(pair? expr) (traverse-data (car expr) visit) (traverse-data (cdr expr) visit)] @@ -213,6 +220,7 @@ (define top-type-num 87) (define case-lambda-sequence-type-num 96) (define begin0-sequence-type-num 97) +(define module-type-num 100) (define prefix-type-num 103) (define-syntax define-enum @@ -363,10 +371,80 @@ (list->vector stxs))) out)])) +(define-struct module-decl (content)) + (define (out-module mod-form out) (match mod-form - [(struct mod (name self-modidx prefix provides requires body syntax-body max-let-depth)) - (error "cannot write modules, yet")])) + [(struct mod (name self-modidx prefix provides requires body syntax-body unexported + max-let-depth dummy lang-info internal-context)) + (out-syntax MODULE_EXPD + (let* ([lookup-req (lambda (phase) + (let ([a (assq phase requires)]) + (if a + (cdr a) + null)))] + [other-requires (filter (lambda (l) + (not (memq (car l) '(#f -1 0 1)))) + requires)] + [extract-protects + (lambda (phase) + (let ([a (assq phase provides)]) + (and a + (let ([p (map provided-protected? (append (cadr a) + (caddr a)))]) + (if (ormap values p) + (list->vector p) + #f)))))] + [list->vector/#f (lambda (default l) + (if (andmap (lambda (x) (equal? x default)) l) + #f + (list->vector l)))] + [l (map cdr other-requires)] + [l (cons (length other-requires) l)] + [l (cons (lookup-req #f) l)] ; dt-requires + [l (cons (lookup-req -1) l)] ; tt-requires + [l (cons (lookup-req 1) l)] ; et-requires + [l (cons (lookup-req 0) l)] ; requires + [l (cons (list->vector body) l)] + [l (cons (list->vector syntax-body) l)] + [l (append (apply + append + (map (lambda (l) + (let ([phase (car l)] + [all (append (cadr l) (caddr l))]) + (list phase + (list->vector/#f #f (map provided-insp all)) + (list->vector/#f 0 (map (lambda (p) (= 1 (provided-src-phase p))) + all)) + (list->vector/#f #f (map (lambda (p) + (if (eq? (provided-nom-src p) + (provided-src p)) + #f ; #f means "same as src" + (provided-nom-src p))) + all)) + (list->vector (map provided-src-name all)) + (list->vector (map provided-src all)) + (list->vector (map provided-name all)) + (length (cadr l)) + (length all)))) + provides)) + l)] + [l (cons (length provides) l)] ; number of provide sets + [l (cons (extract-protects 0) l)] ; protects + [l (cons (extract-protects 1) l)] ; et protects + [l (list* (list->vector (car unexported)) (length (car unexported)) l)] ; indirect-provides + [l (list* (list->vector (cadr unexported)) (length (cadr unexported)) l)] ; indirect-syntax-provides + [l (list* (list->vector (caddr unexported)) (length (caddr unexported)) l)] ; indirect-et-provides + [l (cons prefix l)] + [l (cons dummy l)] + [l (cons max-let-depth l)] + [l (cons internal-context l)] ; module->namespace syntax + [l (list* #f #f l)] ; obsolete `functional?' info + [l (cons lang-info l)] ; lang-info + [l (cons self-modidx l)] + [l (cons name l)]) + (make-module-decl l)) + out)])) (define (out-toplevel tl out) (match tl @@ -422,6 +500,9 @@ (out-marshaled sequence-type-num (map protect-quote forms) out)] [(struct splice (forms)) (out-syntax SPLICE_EXPD (make-seq forms) out)] + [(struct req (reqs dummy)) + (error "cannot handle top-level `require', yet") + (out-syntax REQUIRE_EXPD (cons dummy reqs) out)] [else (out-expr form out)])) @@ -605,11 +686,12 @@ l) out))])) -(define (out-as-bytes expr ->bytes CPT out) +(define (out-as-bytes expr ->bytes CPT len2 out) (out-shared expr out (lambda () (let ([s (->bytes expr)]) (out-byte CPT out) (out-number (bytes-length s) out) + (when len2 (out-number len2 out)) (out-bytes s out))))) (define (out-data expr out) @@ -625,26 +707,31 @@ (out-as-bytes expr (compose string->bytes/utf-8 symbol->string) CPT_SYMBOL + #f out)] [(keyword? expr) (out-as-bytes expr (compose string->bytes/utf-8 keyword->string) CPT_KEYWORD + #f out)] [(string? expr) (out-as-bytes expr string->bytes/utf-8 CPT_CHAR_STRING + (string-length expr) out)] [(bytes? expr) (out-as-bytes expr values CPT_BYTE_STRING + #f out)] [(path? expr) (out-as-bytes expr path->bytes CPT_PATH + #f out)] [(char? expr) (out-byte CPT_CHAR out) @@ -690,10 +777,16 @@ (for ([n (in-range (sub1 (vector-length vec)) -1 -1)]) (out-number (vector-ref vec n) out)))] [(module-path-index? expr) - (out-byte CPT_MODULE_INDEX out) - (let-values ([(name base) (module-path-index-split expr)]) - (out-data name out) - (out-data base out))] + (out-shared expr out + (lambda () + (out-byte CPT_MODULE_INDEX out) + (let-values ([(name base) (module-path-index-split expr)]) + (out-data name out) + (out-data base out))))] + [(module-decl? expr) + (out-marshaled module-type-num + (module-decl-content expr) + out)] [else (out-byte CPT_QUOTE out) (let ([s (open-output-bytes)]) diff --git a/collects/compiler/zo-parse.ss b/collects/compiler/zo-parse.ss index 6660c45300..1f04af58ec 100644 --- a/collects/compiler/zo-parse.ss +++ b/collects/compiler/zo-parse.ss @@ -34,7 +34,8 @@ (define-form-struct form ()) (define-form-struct (expr form) ()) -(define-form-struct (mod form) (name self-modidx prefix provides requires body syntax-body max-let-depth)) +(define-form-struct (mod form) (name self-modidx prefix provides requires body syntax-body unexported + max-let-depth dummy lang-info internal-context)) (define-form-struct (lam expr) (name flags num-params param-types rest? closure-map max-let-depth body)) ; `lambda' (define-form-struct (closure expr) (code gen-id)) ; a static closure (nothing to close over) @@ -74,6 +75,9 @@ (define-struct indirect ([v #:mutable]) #:prefab) (provide (struct-out indirect)) +;; A provided identifier +(define-form-struct provided (name src src-name nom-src src-phase protected? insp)) + ;; ---------------------------------------- ;; Bytecode unmarshalers for various forms @@ -232,7 +236,37 @@ ,requires ,syntax-requires ,template-requires ,label-requires ,more-requires-count . ,more-requires) (make-mod name self-modidx - prefix phase-data + prefix (let loop ([l phase-data]) + (if (null? l) + null + (let ([num-vars (list-ref l 7)] + [ps (for/list ([name (in-vector (list-ref l 6))] + [src (in-vector (list-ref l 5))] + [src-name (in-vector (list-ref l 4))] + [nom-src (or (list-ref l 3) + (in-cycle (in-value #f)))] + [src-phase (or (list-ref l 2) + (in-cycle (in-value #f)))] + [protected? (or (case (car l) + [(0) protects] + [(1) et-protects] + [else #f]) + (in-cycle (in-value #f)))] + [insp (or (list-ref l 1) + (in-cycle (in-value #f)))]) + (make-provided name src src-name + (or nom-src src) + (if src-phase 1 0) + protected? + insp))]) + (if (null? ps) + (loop (list-tail l 9)) + (cons + (list + (car l) + (take ps num-vars) + (drop ps num-vars)) + (loop (list-tail l 9))))))) (list* (cons 0 requires) (cons 1 syntax-requires) @@ -248,7 +282,13 @@ make-def-syntaxes) ids expr prefix max-let-depth)])) (vector->list syntax-body)) - max-let-depth)]))])) + (list (vector->list indirect-provides) + (vector->list indirect-syntax-provides) + (vector->list indirect-et-provides)) + max-let-depth + dummy + lang-info + rename)]))])) (define (read-module-wrap v) v) diff --git a/collects/scribblings/mzc/decompile.scrbl b/collects/scribblings/mzc/decompile.scrbl index a97c36e69d..787d5cf13e 100644 --- a/collects/scribblings/mzc/decompile.scrbl +++ b/collects/scribblings/mzc/decompile.scrbl @@ -3,7 +3,7 @@ "common.ss" (for-label scheme/base compiler/decompile - (only-in compiler/zo-parse compilation-top?) + (only-in compiler/zo-parse compilation-top? req) compiler/zo-marshal)) @title[#:tag "decompile"]{Decompiling Bytecode} @@ -112,5 +112,6 @@ Consumes the result of parsing bytecode and returns an S-expression @defproc[(zo-marshal [top compilation-top?]) bytes?]{ Consumes a representation of bytecode and generates a byte string for -the marshaled bytecode. Currently, modules and quoted syntax objects -with @scheme[top] are not supported.} +the marshaled bytecode. Currently, syntax objects are not supported, +including in @scheme[req] for a top-level @scheme[#%require].} + diff --git a/collects/scribblings/mzc/zo-parse.scrbl b/collects/scribblings/mzc/zo-parse.scrbl index 60e53074a1..13f8e6f5bc 100644 --- a/collects/scribblings/mzc/zo-parse.scrbl +++ b/collects/scribblings/mzc/zo-parse.scrbl @@ -180,34 +180,13 @@ values. The @scheme[max-let-depth] field indicates the maximum size of the stack that will be created by @scheme[rhs] (not counting @scheme[prefix]).} -@defstruct+[(req form) ([reqs (listof module-path?)] +@defstruct+[(req form) ([reqs syntax?] [dummy toplevel?])]{ -Represents a top-level @scheme[require] form (but not one in a -@scheme[module] form). The @scheme[dummy] variable is used to access -to the top-level namespace.} - - -@defstruct+[(mod form) ([name symbol?] - [self-modidx module-path-index?] - [prefix prefix?] - [provides (listof symbol?)] - [requires (listof (cons/c (or/c exact-integer? #f) - (listof module-path-index?)))] - [body (listof (or/c form? indirect? any/c))] - [syntax-body (listof (or/c def-syntaxes? def-for-syntax?))] - [max-let-depth exact-nonnegative-integer?])]{ - -Represents a @scheme[module] declaration. The @scheme[body] forms use -@scheme[prefix], rather than any prefix in place for the module -declaration itself (and each @scheme[syntax-body] has its own -prefix). The @scheme[body] field contains the module's run-time code, -and @scheme[syntax-body] contains the module's compile-time code. The -@scheme[max-let-depth] field indicates the maximum stack depth created -by @scheme[body] forms (not counting the @scheme[prefix] array). - -After each form in @scheme[body] is evaluated, the stack is restored -to its depth from before evaluating the form.} +Represents a top-level @scheme[#%require] form (but not one in a +@scheme[module] form) with a sequence of specifications +@scheme[reqs]. The @scheme[dummy] variable is used to access to the +top-level namespace.} @defstruct+[(seq form) ([forms (listof (or/c form? indirect? any/c))])]{ @@ -230,6 +209,69 @@ After each form in @scheme[forms] is evaluated, the stack is restored to its depth from before evaluating the form.} +@defstruct+[(mod form) ([name symbol?] + [self-modidx module-path-index?] + [prefix prefix?] + [provides (listof (list/c (or/c exact-integer? #f) + (listof provided?) + (listof provided?)))] + [requires (listof (cons/c (or/c exact-integer? #f) + (listof module-path-index?)))] + [body (listof (or/c form? indirect? any/c))] + [syntax-body (listof (or/c def-syntaxes? def-for-syntax?))] + [unexported (list/c (listof symbol?) (listof symbol?) + (listof symbol?))] + [max-let-depth exact-nonnegative-integer?] + [dummy toplevel?] + [lang-info (or/c #f (vector/c module-path? symbol? any/c))] + [internal-context (or/c #f #t syntax?)])]{ + +Represents a @scheme[module] declaration. The @scheme[body] forms use +@scheme[prefix], rather than any prefix in place for the module +declaration itself (and each @scheme[syntax-body] has its own +prefix). + +The @scheme[provides] and @scheme[requires] lists are each an +association list from phases to exports or imports. In the case of +@scheme[provides], each phase maps to two lists: one for exported +variables, and another for exported syntax. In the case of +@scheme[requires], each phase maps to a list of imported module paths. + +The @scheme[body] field contains the module's run-time code, and +@scheme[syntax-body] contains the module's compile-time code. After +each form in @scheme[body] or @scheme[syntax-body] is evaluated, the +stack is restored to its depth from before evaluating the form. + +The @scheme[unexported] list contains lists of symbols for unexported +definitions that can be accessed through macro expansion. The first +list is phase-0 variables, the second is phase-0 syntax, and the last +is phase-1 variables. + +The @scheme[max-let-depth] field indicates the maximum stack depth +created by @scheme[body] forms (not counting the @scheme[prefix] +array). The @scheme[dummy] variable is used to access to the +top-level namespace. + +The @scheme[lang-info] value specifies an optional module path that +provides information about the module's implementation language. + +The @scheme[internal-module-context] value describes the lexical +context of the body of the module. This value is used by +@scheme[module->namespace]. A @scheme[#f] value means that the context +is unavailable or empty. A @scheme[#t] value means that the context is +computed by re-importing all required modules. A syntax-object value +embeds an arbitrary lexical context.} + +@defstruct+[provided ([name symbol?] + [src (or/c module-path-index? #f)] + [src-name symbol?] + [nom-mod (or/c module-path-index? #f)] + [src-phase (or/c 0 1)] + [protected? boolean?] + [insp (or #t #f (void))])]{ + +Describes an individual provided identifier within a @scheme[mod] instance.} + @; -------------------------------------------------- @section{Expressions}