diff --git a/collects/compiler/commands/exe.rkt b/collects/compiler/commands/exe.rkt index 59a956f60f..117e44429b 100644 --- a/collects/compiler/commands/exe.rkt +++ b/collects/compiler/commands/exe.rkt @@ -23,7 +23,7 @@ #:once-each [("-o") file "Write executable as " (exe-output file)] - [("--gui") "Geneate GUI executable" + [("--gui") "Generate GUI executable" (gui #t)] [("--collects-path") path "Set as main collects for executable" (exe-embedded-collects-path path)] diff --git a/collects/compiler/commands/info.rkt b/collects/compiler/commands/info.rkt index 9a3106d696..d97e168309 100644 --- a/collects/compiler/commands/info.rkt +++ b/collects/compiler/commands/info.rkt @@ -7,4 +7,5 @@ ("decompile" compiler/commands/decompile "decompile bytecode" #f) ("expand" compiler/commands/expand "macro-expand source" #f) ("distribute" compiler/commands/exe-dir "prepare executable(s) in a directory for distribution" #f) - ("ctool" compiler/commands/ctool "compile and link C-based extensions" #f))) + ("ctool" compiler/commands/ctool "compile and link C-based extensions" #f) + ("demodularize" compiler/demodularizer/batch "produce a whole program from a single module" #f))) diff --git a/collects/compiler/commands/make.rkt b/collects/compiler/commands/make.rkt index 5cfd96af01..03dd574409 100644 --- a/collects/compiler/commands/make.rkt +++ b/collects/compiler/commands/make.rkt @@ -3,7 +3,9 @@ raco/command-name compiler/cm "../compiler.ss" - dynext/file) + dynext/file + setup/parallel-build + racket/match) (define verbose (make-parameter #f)) (define very-verbose (make-parameter #f)) @@ -12,6 +14,7 @@ (define disable-deps (make-parameter #f)) (define prefixes (make-parameter null)) (define assume-primitives (make-parameter #t)) +(define worker-count (make-parameter 1)) (define source-files (command-line @@ -27,13 +30,15 @@ (assume-primitives #f)] [("-v") "Verbose mode" (verbose #t)] + [("-j") wc "Parallel job count" (worker-count (string->number wc))] [("--vv") "Very verbose mode" (verbose #t) (very-verbose #t)] #:args (file . another-file) (cons file another-file))) -(if (disable-deps) - ;; Just compile one file: +(cond + ;; Just compile one file: + [(disable-deps) (let ([prefix `(begin (require scheme) @@ -45,8 +50,9 @@ (void))]) ((compile-zos prefix #:verbose? (verbose)) source-files - 'auto)) - ;; Normal make: + 'auto))] + ;; Normal make: + [(= (worker-count) 1) (let ([n (make-base-empty-namespace)] [did-one? #f]) (parameterize ([current-namespace n] @@ -76,4 +82,11 @@ (when (verbose) (printf " [~a \"~a\"]\n" (if did-one? "output to" "already up-to-date at") - dest)))))))) + dest)))))))] + ;; Parallel make: + [else (parallel-compile-files source-files #:worker-count (worker-count) + #:handler (lambda (type work msg out err) + (match type + ['done (when (verbose) (printf " Made ~a\n" work))] + ['output (printf " Output from: ~a\n~a~a" work out err)] + [else (printf " Error compiling ~a\n~a\n~a~a" work msg out err)])))]) diff --git a/collects/compiler/commands/pack.rkt b/collects/compiler/commands/pack.rkt index 852ee99d74..8a2fa32a50 100644 --- a/collects/compiler/commands/pack.rkt +++ b/collects/compiler/commands/pack.rkt @@ -23,7 +23,7 @@ (command-line #:program (short-program+command-name) #:once-each - [("--collect") "Pack collections instead of files and directories" + [("--collect") "s specify collections instead of files/dirs" (collection? #t)] [("--plt-name") name "Set the printed describing the archive" (plt-name name)] @@ -45,8 +45,8 @@ #:once-each [("-v") "Verbose mode" (verbose #t)] - #:args (dest-file . file) - (values dest-file file))) + #:args (dest-file . path) + (values dest-file path))) (if (not (collection?)) ;; Files and directories diff --git a/collects/compiler/decompile.rkt b/collects/compiler/decompile.rkt index 6c8c75d4a4..4af6bb5d08 100644 --- a/collects/compiler/decompile.rkt +++ b/collects/compiler/decompile.rkt @@ -16,6 +16,7 @@ (namespace-require ''#%kernel) (namespace-require ''#%unsafe) (namespace-require ''#%flfxnum) + (namespace-require ''#%futures) (for/list ([l (namespace-mapped-symbols)]) (cons l (with-handlers ([exn:fail? (lambda (x) #f)]) (compile l))))))] @@ -159,8 +160,6 @@ (extract-name name)] [(struct closure (lam gen-id)) (extract-id lam)] - [(struct indirect (v)) - (extract-id v)] [else #f])) (define (extract-ids! body ids) @@ -287,15 +286,10 @@ (begin (hash-set! closed gen-id #t) `(#%closed ,gen-id ,(decompile-expr lam globs stack closed))))] - [(struct indirect (val)) - (if (closure? val) - (decompile-expr val globs stack closed) - '???)] [else `(quote ,expr)])) (define (decompile-lam expr globs stack closed) (match expr - [(struct indirect (val)) (decompile-lam val globs stack closed)] [(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)) (let ([vars (for/list ([i (in-range num-params)] diff --git a/collects/compiler/demodularizer/alpha.rkt b/collects/compiler/demodularizer/alpha.rkt new file mode 100644 index 0000000000..7ca1b83e1a --- /dev/null +++ b/collects/compiler/demodularizer/alpha.rkt @@ -0,0 +1,19 @@ +#lang racket +(require compiler/zo-parse) + +(define (alpha-vary-ctop top) + (match top + [(struct compilation-top (max-let-depth prefix form)) + (make-compilation-top max-let-depth (alpha-vary-prefix prefix) form)])) +(define (alpha-vary-prefix p) + (struct-copy prefix p + [toplevels + (map (match-lambda + [(and sym (? symbol?)) + (gensym sym)] + [other + other]) + (prefix-toplevels p))])) + +(provide/contract + [alpha-vary-ctop (compilation-top? . -> . compilation-top?)]) \ No newline at end of file diff --git a/collects/compiler/demodularizer/batch.rkt b/collects/compiler/demodularizer/batch.rkt new file mode 100644 index 0000000000..97ec868b12 --- /dev/null +++ b/collects/compiler/demodularizer/batch.rkt @@ -0,0 +1,113 @@ +#lang racket +#| +Here's the idea: + +- Take a module's bytecode +- Recursively get all the bytecode for modules that the target requires +- After reading it, prune everything that isn't at phase 0 (the runtime phase) + +- Now that we have all the modules, the next step is to merge them into a single + module +-- Although actually we collapse them into the top-level, not a module +- To do that, we iterate through all the modules doing two things as we go: +-- Incrementing all the global variable references by all the references in all + the modules +--- So if A has 5, then B's start at index 5 and so on +-- Replacing module variable references with the actual global variables + corresponding to those variables +--- So if A's variable 'x' is in global slot 4, then if B refers to it, it + directly uses slot 4, rather than a module-variable slot + +- At that point we have all the module code in a single top-level, but many + toplevels won't be used because a library function isn't really used +- So, we do a "garbage collection" on elements of the prefix +- First, we create a dependency graph of all toplevels and the initial scope +- Then, we do a DFS on the initial scope and keep all those toplevels, throwing + away the construction of everything else + [XXX: This may be broken because of side-effects.] + +- Now we have a small amount code, but because we want to go back to source, + we need to fix it up a bit; because different modules may've used the same + names +- So, we do alpha-renaming, but it's easy because names are only used in the + compilation-top prefix structure + +[TODO] + +- Next, we decompile +- Then, it will pay to do dead code elimination and inlining, etc. +|# + +(require racket/pretty + racket/system + "mpi.rkt" + "util.rkt" + "nodep.rkt" + "merge.rkt" + "gc-toplevels.rkt" + "alpha.rkt" + "module.rkt" + "replace-modidx.rkt" + compiler/decompile + compiler/zo-marshal + racket/set) + +(define (main file-to-batch) + (define-values (base name dir?) (split-path file-to-batch)) + (when (or (eq? base #f) dir?) + (error 'batch "Cannot run on directory")) + + ;; Compile + + (log-info "Compiling module") + (void (system* (find-executable-path "raco") "make" file-to-batch)) + + (define merged-zo-path (path-add-suffix file-to-batch #"_merged.zo")) + + ;; Transformations + (define path-cache (make-hash)) + + (log-info "Removing dependencies") + (define-values (batch-nodep top-lang-info top-self-modidx get-modvar-rewrite) + (parameterize ([MODULE-PATHS path-cache]) + (nodep-file file-to-batch))) + + (log-info "Merging modules") + (define batch-merge + (parameterize ([MODULE-PATHS path-cache]) + (merge-compilation-top get-modvar-rewrite batch-nodep))) + + ; Not doing this for now + ;(log-info "GC-ing top-levels") + (define batch-gcd + batch-merge + #;(gc-toplevels batch-merge)) + + (log-info "Alpha-varying top-levels") + (define batch-alpha + (alpha-vary-ctop batch-gcd)) + + (log-info "Replacing self-modidx") + (define batch-replace-modidx + (replace-modidx batch-alpha top-self-modidx)) + + (define batch-modname + (string->symbol (regexp-replace #rx"\\.zo$" (path->string merged-zo-path) ""))) + (log-info (format "Modularizing into ~a" batch-modname)) + (define batch-mod + (wrap-in-kernel-module batch-modname batch-modname top-lang-info top-self-modidx batch-replace-modidx)) + + (log-info "Writing merged zo") + (void + (with-output-to-file + merged-zo-path + (lambda () + (zo-marshal-to batch-mod (current-output-port))) + #:exists 'replace))) + +(command-line #:program "batch" + #:multi + [("-e" "--exclude-modules") mod + "Exclude a module from being batched" + (current-excluded-modules (set-add (current-excluded-modules) mod))] + #:args (filename) (main filename)) \ No newline at end of file diff --git a/collects/compiler/demodularizer/gc-toplevels.rkt b/collects/compiler/demodularizer/gc-toplevels.rkt new file mode 100644 index 0000000000..79401002d5 --- /dev/null +++ b/collects/compiler/demodularizer/gc-toplevels.rkt @@ -0,0 +1,276 @@ +#lang racket +(require compiler/zo-parse + "util.rkt") + +; XXX Use efficient set structure +(define (gc-toplevels top) + (match top + [(struct compilation-top (max-let-depth top-prefix form)) + (define lift-start + (prefix-lift-start top-prefix)) + (define max-depgraph-index + (+ (prefix-num-lifts top-prefix) + lift-start)) + (define top-node max-depgraph-index) + (define DEP-GRAPH (make-vector (add1 top-node) (make-refs empty empty))) + (define build-graph! (make-build-graph! DEP-GRAPH)) + (define _void (build-graph! (list top-node) form)) + (define-values (used-tls stxs) (graph-dfs DEP-GRAPH top-node)) + (define ordered-used-tls (sort (rest used-tls) <=)) ; This rest drops off the top-node + (define ordered-stxs (sort stxs <=)) + (define (lift? i) (lift-start . <= . i)) + (define-values (lifts normal-tls) (partition lift? ordered-used-tls)) + (define new-prefix + (make-prefix + (length lifts) + (for/list ([i normal-tls]) + (list-ref (prefix-toplevels top-prefix) i)) + (for/list ([i ordered-stxs]) + (list-ref (prefix-stxs top-prefix) i)))) + (define new-lift-start + (prefix-lift-start new-prefix)) + ; XXX This probably breaks max-let-depth + (define new-form + ((gc-toplevels-form + (lambda (pos) (index<=? pos ordered-used-tls)) + (lambda (pos) + (if (lift? pos) + (+ new-lift-start (index<=? pos lifts)) + (index<=? pos normal-tls))) + (lambda (stx-pos) + (index<=? stx-pos ordered-stxs)) + (prefix-syntax-start new-prefix)) + form)) + (log-debug (format "Total TLS: ~S" (length normal-tls))) + (log-debug (format "Used TLS: ~S" normal-tls)) + (log-debug (format "Total lifts: ~S" (length lifts))) + (log-debug (format "Used lifts: ~S" lifts)) + (log-debug (format "Total stxs: ~S" (length stxs))) + (log-debug (format "Used stxs: ~S" ordered-stxs)) + (make-compilation-top + max-let-depth + new-prefix + new-form)])) + +(define-struct refs (tl stx) #:transparent) + +(define (make-build-graph! DEP-GRAPH) + (define (build-graph!* form lhs) + (match form + [(struct def-values (ids rhs)) + (define new-lhs (map toplevel-pos ids)) + ; If we require one, we should require all, so make them reference each other + (for-each (lambda (tl) (build-graph! new-lhs tl)) ids) + (build-graph! new-lhs rhs)] + [(? def-syntaxes?) + (error 'build-graph "Doesn't handle syntax")] + [(? def-for-syntax?) + (error 'build-graph "Doesn't handle syntax")] + [(struct req (reqs dummy)) + (build-graph! lhs dummy)] + [(? mod?) + (error 'build-graph "Doesn't handle modules")] + [(struct seq (forms)) + (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))) + (build-graph! lhs body)] + [(and c (struct closure (code gen-id))) + (build-graph! lhs code)] + [(and cl (struct case-lam (name clauses))) + (for-each (lambda (l) (build-graph! lhs l)) + clauses)] + [(struct let-one (rhs body flonum? unused?)) + (build-graph! lhs rhs) + (build-graph! lhs body)] + [(and f (struct let-void (count boxes? body))) + (build-graph! lhs body)] + [(and f (struct install-value (_ _ _ rhs body))) + (build-graph! lhs rhs) + (build-graph! lhs body)] + [(struct let-rec (procs body)) + (for-each (lambda (l) (build-graph! lhs l)) procs) + (build-graph! lhs body)] + [(and f (struct boxenv (_ body))) + (build-graph! lhs body)] + [(and f (struct toplevel (_ pos _ _))) + (for-each (lambda (lhs) + (dict-update! DEP-GRAPH lhs + (match-lambda + [(struct refs (tls stxs)) + (make-refs (list* pos tls) stxs)]))) + lhs)] + [(and f (struct topsyntax (_ pos _))) + (for-each (lambda (lhs) + (dict-update! DEP-GRAPH lhs + (match-lambda + [(struct refs (tls stxs)) + (make-refs tls (list* pos stxs))]))) + lhs)] + [(struct application (rator rands)) + (for-each (lambda (f) (build-graph! lhs f)) + (list* rator rands))] + [(struct branch (test then else)) + (for-each (lambda (f) (build-graph! lhs f)) + (list test then else))] + [(struct with-cont-mark (key val body)) + (for-each (lambda (f) (build-graph! lhs f)) + (list key val body))] + [(struct beg0 (seq)) + (for-each (lambda (f) (build-graph! lhs f)) + seq)] + [(struct varref (tl)) + (build-graph! lhs tl)] + [(and f (struct assign (id rhs undef-ok?))) + (build-graph! lhs id) + (build-graph! lhs rhs)] + [(struct apply-values (proc args-expr)) + (build-graph! lhs proc) + (build-graph! lhs args-expr)] + [(and f (struct primval (id))) + (void)] + [(and f (struct localref (unbox? pos clear? other-clears? flonum?))) + (void)] + [(and v (not (? form?))) + (void)])) + (define-values (first-build-graph!** build-graph!**) + (build-form-memo build-graph!* #:void? #t)) + (define (build-graph! lhs form) (first-build-graph!** form lhs)) + build-graph!) + +(define (graph-dfs g start-node) + (define visited? (make-hasheq)) + (define (visit-tl n tls stxs) + (if (hash-has-key? visited? n) + (values tls stxs) + (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 stx-visited? (make-hasheq)) + (define (visit-stx n) + (if (hash-has-key? stx-visited? n) + #f + (begin (hash-set! stx-visited? n #t) + n))) + (visit-tl start-node empty empty)) + +; index<=? : number? (listof number?) -> (or/c number? false/c) +; returns the index of n in l and assumes that l is sorted by <= +(define (index<=? n l) + (match l + [(list) #f] + [(list-rest f l) + (cond + [(= n f) + 0] + [(< n f) + #f] + [else + (let ([rec (index<=? n l)]) + (if rec (add1 rec) rec))])])) + +(define (identity x) x) +(define (gc-toplevels-form keep? update-tl update-ts new-ts-midpt) + (define (inner-update form) + (match form + [(struct def-values (ids rhs)) + (if (ormap (compose keep? toplevel-pos) ids) + (make-def-values (map update ids) + (update rhs)) + #f)] + [(? def-syntaxes?) + (error 'gc-tls "Doesn't handle syntax")] + [(? def-for-syntax?) + (error 'gc-tls "Doesn't handle syntax")] + [(struct req (reqs dummy)) + (make-req reqs (update dummy))] + [(? mod?) + (error 'gc-tls "Doesn't handle modules")] + [(struct seq (forms)) + (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))) + (struct-copy lam l + [body (update body)])] + [(and c (struct closure (code gen-id))) + (struct-copy closure c + [code (update code)])] + [(and cl (struct case-lam (name clauses))) + (struct-copy case-lam cl + [clauses (map update clauses)])] + [(struct let-one (rhs body flonum? unused?)) + (make-let-one (update rhs) (update body) flonum? unused?)] ; Q: is flonum? okay here? + [(and f (struct let-void (count boxes? body))) + (struct-copy let-void f + [body (update body)])] + [(and f (struct install-value (_ _ _ rhs body))) + (struct-copy install-value f + [rhs (update rhs)] + [body (update body)])] + [(struct let-rec (procs body)) + (make-let-rec (map update procs) (update body))] + [(and f (struct boxenv (_ body))) + (struct-copy boxenv f [body (update body)])] + [(and f (struct toplevel (_ pos _ _))) + (struct-copy toplevel f + [pos (update-tl pos)])] + [(and f (struct topsyntax (_ pos _))) + (struct-copy topsyntax f + [pos (update-ts pos)] + [midpt new-ts-midpt])] + [(struct application (rator rands)) + (make-application + (update rator) + (map update rands))] + [(struct branch (test then else)) + (make-branch + (update test) + (update then) + (update else))] + [(struct with-cont-mark (key val body)) + (make-with-cont-mark + (update key) + (update val) + (update body))] + [(struct beg0 (seq)) + (make-beg0 (map update seq))] + [(struct varref (tl)) + (make-varref (update tl))] + [(and f (struct assign (id rhs undef-ok?))) + (struct-copy assign f + [id (update id)] + [rhs (update rhs)])] + [(struct apply-values (proc args-expr)) + (make-apply-values + (update proc) + (update args-expr))] + [(and f (struct primval (id))) + f] + [(and f (struct localref (unbox? pos clear? other-clears? flonum?))) + f] + [(and v (not (? form?))) + v] + )) + (define-values (first-update update) + (build-form-memo inner-update)) + first-update) + +(provide/contract + [gc-toplevels (compilation-top? . -> . compilation-top?)]) \ No newline at end of file diff --git a/collects/compiler/demodularizer/merge.rkt b/collects/compiler/demodularizer/merge.rkt new file mode 100644 index 0000000000..f25dd63166 --- /dev/null +++ b/collects/compiler/demodularizer/merge.rkt @@ -0,0 +1,173 @@ +#lang racket +(require compiler/zo-parse + "util.rkt" + "mpi.rkt" + "nodep.rkt" + "update-toplevels.rkt") + +(define MODULE-TOPLEVEL-OFFSETS (make-hash)) + +(define current-get-modvar-rewrite (make-parameter #f)) +(define (merge-compilation-top get-modvar-rewrite top) + (parameterize ([current-get-modvar-rewrite get-modvar-rewrite]) + (match top + [(struct compilation-top (max-let-depth prefix form)) + (define-values (new-max-let-depth new-prefix gen-new-forms) + (merge-form max-let-depth prefix form)) + (define total-tls (length (prefix-toplevels new-prefix))) + (define total-stxs (length (prefix-stxs new-prefix))) + (define total-lifts (prefix-num-lifts new-prefix)) + (log-debug (format "max-let-depth ~S to ~S" max-let-depth new-max-let-depth)) + (log-debug (format "total toplevels ~S" total-tls)) + (log-debug (format "total stxs ~S" total-stxs)) + (log-debug (format "num-lifts ~S" total-lifts)) + (make-compilation-top + new-max-let-depth new-prefix + (make-splice (gen-new-forms new-prefix)))] + [else (error 'merge "unrecognized: ~e" top)]))) + +(define (merge-forms max-let-depth prefix forms) + (if (empty? forms) + (values max-let-depth prefix (lambda _ empty)) + (let*-values ([(fmax-let-depth fprefix gen-fform) (merge-form max-let-depth prefix (first forms))] + [(rmax-let-depth rprefix gen-rforms) (merge-forms fmax-let-depth fprefix (rest forms))]) + (values rmax-let-depth + rprefix + (lambda args + (append (apply gen-fform args) + (apply gen-rforms args))))))) + +(define (merge-form max-let-depth prefix form) + (match form + [(? mod?) + (merge-module max-let-depth prefix form)] + [(struct seq (forms)) + (merge-forms max-let-depth prefix forms)] + [(struct splice (forms)) + (merge-forms max-let-depth prefix forms)] + [else + (values max-let-depth prefix (lambda _ (list form)))])) + +(define (merge-prefix root-prefix mod-prefix) + (match root-prefix + [(struct prefix (root-num-lifts root-toplevels root-stxs)) + (match mod-prefix + [(struct prefix (mod-num-lifts mod-toplevels mod-stxs)) + (make-prefix (+ root-num-lifts mod-num-lifts) + (append root-toplevels mod-toplevels) + (append root-stxs mod-stxs))])])) + +(define (compute-new-modvar mv rw) + (match mv + [(struct module-variable (modidx sym pos phase)) + (match rw + [(struct modvar-rewrite (self-modidx provide->toplevel)) + (log-debug (format "Rewriting ~a of ~S" pos (mpi->path* modidx))) + ((hash-ref MODULE-TOPLEVEL-OFFSETS self-modidx + (lambda () + (error 'compute-new-modvar "toplevel offset not yet computed: ~S" self-modidx))) + (provide->toplevel sym pos))])])) + +(define (filter-rewritable-module-variable? toplevel-offset mod-toplevels) + (define-values + (i new-toplevels remap) + (for/fold ([i 0] + [new-toplevels empty] + [remap empty]) + ([tl (in-list mod-toplevels)]) + (match tl + [(and mv (struct module-variable (modidx sym pos phase))) + (define rw ((current-get-modvar-rewrite) modidx)) + ; XXX We probably don't need to deal with #f phase + (unless (or (not phase) (zero? phase)) + (error 'eliminate-module-variables "Non-zero phases not supported: ~S" mv)) + (cond + ; Primitive module like #%paramz + [(symbol? rw) + (log-debug (format "~S from ~S" sym rw)) + (values (add1 i) + (list* tl new-toplevels) + (list* (+ i toplevel-offset) remap))] + [(module-path-index? rw) + (values (add1 i) + (list* tl new-toplevels) + (list* (+ i toplevel-offset) remap))] + [(modvar-rewrite? rw) + (values i + new-toplevels + (list* (compute-new-modvar mv rw) remap))] + [else + (error 'filter-rewritable-module-variable? "Unsupported module-rewrite: ~S" rw)])] + [tl + (values (add1 i) + (list* tl new-toplevels) + (list* (+ i toplevel-offset) remap))]))) + ; XXX This would be more efficient as a vector + (values (reverse new-toplevels) + (reverse remap))) + +(define (merge-module max-let-depth top-prefix mod-form) + (match mod-form + [(struct mod (name srcname self-modidx mod-prefix provides requires body syntax-body unexported mod-max-let-depth dummy lang-info internal-context)) + (define toplevel-offset (length (prefix-toplevels top-prefix))) + (define topsyntax-offset (length (prefix-stxs top-prefix))) + (define lift-offset (prefix-num-lifts top-prefix)) + (define mod-toplevels (prefix-toplevels mod-prefix)) + (define-values (new-mod-toplevels toplevel-remap) (filter-rewritable-module-variable? toplevel-offset mod-toplevels)) + (define num-mod-toplevels + (length toplevel-remap)) + (define mod-stxs + (length (prefix-stxs mod-prefix))) + (define mod-num-lifts + (prefix-num-lifts mod-prefix)) + (define new-mod-prefix + (struct-copy prefix mod-prefix + [toplevels new-mod-toplevels])) + (hash-set! MODULE-TOPLEVEL-OFFSETS self-modidx + (lambda (n) + (list-ref toplevel-remap n))) + (unless (= (length toplevel-remap) + (length mod-toplevels)) + (error 'merge-module "Not remapping everything: ~S ~S" + mod-toplevels toplevel-remap)) + (log-debug (format "[~S] Incrementing toplevels by ~a" + name + toplevel-offset)) + (log-debug (format "[~S] Incrementing lifts by ~a" + name + lift-offset)) + (log-debug (format "[~S] Filtered mod-vars from ~a to ~a" + name + (length mod-toplevels) + (length new-mod-toplevels))) + (values (max max-let-depth mod-max-let-depth) + (merge-prefix top-prefix new-mod-prefix) + (lambda (top-prefix) + (log-debug (format "[~S] Updating top-levels" name)) + (define top-lift-start (prefix-lift-start top-prefix)) + (define mod-lift-start (prefix-lift-start mod-prefix)) + (define total-lifts (prefix-num-lifts top-prefix)) + (define max-toplevel (+ top-lift-start total-lifts)) + (define update + (update-toplevels + (lambda (n) + (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)] + [else + (list-ref toplevel-remap n)])) + (lambda (n) + (+ n topsyntax-offset)) + (prefix-syntax-start top-prefix))) + (map update body)))])) + +(provide/contract + [merge-compilation-top (-> get-modvar-rewrite/c + compilation-top? + compilation-top?)]) \ No newline at end of file diff --git a/collects/compiler/demodularizer/module.rkt b/collects/compiler/demodularizer/module.rkt new file mode 100644 index 0000000000..faa47c49e7 --- /dev/null +++ b/collects/compiler/demodularizer/module.rkt @@ -0,0 +1,34 @@ +#lang racket +(require compiler/zo-parse + "util.rkt") + +(define (->module-path-index s) + (if (module-path-index? s) + s + (module-path-index-join `(quote ,s) #f))) + +(define (wrap-in-kernel-module name srcname lang-info self-modidx top) + (match top + [(struct compilation-top (max-let-depth prefix form)) + (define-values (reqs new-forms) + (partition req? (splice-forms form))) + (define requires + (map (compose ->module-path-index wrapped-datum stx-encoded req-reqs) reqs)) + (make-compilation-top + 0 + (make-prefix 0 (list #f) empty) + (make-mod name srcname + self-modidx + prefix + empty ; provides + (list (cons 0 requires)) + new-forms + empty ; syntax-body + (list empty empty empty) ; unexported + max-let-depth + (make-toplevel 0 0 #f #f) ; dummy + lang-info + #t))])) + +(provide/contract + [wrap-in-kernel-module (symbol? symbol? lang-info/c module-path-index? compilation-top? . -> . compilation-top?)]) \ No newline at end of file diff --git a/collects/compiler/demodularizer/mpi.rkt b/collects/compiler/demodularizer/mpi.rkt new file mode 100644 index 0000000000..3c86837115 --- /dev/null +++ b/collects/compiler/demodularizer/mpi.rkt @@ -0,0 +1,31 @@ +#lang racket +(require syntax/modresolve) + +(define current-module-path (make-parameter #f)) + +(define (mpi->string modidx) + (cond + [(symbol? modidx) modidx] + [else + (mpi->path! modidx)])) + +(define MODULE-PATHS (make-parameter #f)) +(define (mpi->path! mpi) + (hash-ref! + (MODULE-PATHS) mpi + (lambda () + (define _pth + (resolve-module-path-index mpi (current-module-path))) + (if (path? _pth) + (simplify-path _pth #t) + _pth)))) +(define (mpi->path* mpi) + (hash-ref (MODULE-PATHS) mpi + (lambda () + (error 'mpi->path* "Cannot locate cache of path for ~S" mpi)))) + +(provide/contract + [MODULE-PATHS (parameter/c (or/c false/c hash?))] + [current-module-path (parameter/c path-string?)] + [mpi->path! (module-path-index? . -> . (or/c symbol? path?))] + [mpi->path* (module-path-index? . -> . (or/c symbol? path?))]) \ No newline at end of file diff --git a/collects/compiler/demodularizer/nodep.rkt b/collects/compiler/demodularizer/nodep.rkt new file mode 100644 index 0000000000..0d8c01642d --- /dev/null +++ b/collects/compiler/demodularizer/nodep.rkt @@ -0,0 +1,189 @@ +#lang racket +(require compiler/zo-parse + "util.rkt" + "mpi.rkt" + racket/set) + +(define current-excluded-modules (make-parameter (set))) + +(define ZOS (make-parameter #f)) +(define MODULE-IDX-MAP (make-parameter #f)) +(define PHASE*MODULE-CACHE (make-parameter #f)) + +(define (nodep-file file-to-batch) + (define idx-map (make-hash)) + (parameterize ([ZOS (make-hash)] + [MODULE-IDX-MAP idx-map] + [PHASE*MODULE-CACHE (make-hash)]) + (define (get-modvar-rewrite modidx) + (define pth (mpi->path* modidx)) + (hash-ref idx-map pth + (lambda () + (error 'get-modvar-rewrite "Cannot locate modvar rewrite for ~S" pth)))) + (match (get-nodep-module-code/path file-to-batch 0) + [(struct @phase (_ (struct module-code (modvar-rewrite lang-info ctop)))) + (values ctop lang-info (modvar-rewrite-modidx modvar-rewrite) get-modvar-rewrite)]))) + +(define (path->comp-top pth) + (hash-ref! (ZOS) pth + (λ () + (call-with-input-file pth zo-parse)))) + +(define (excluded? pth) + (set-member? (current-excluded-modules) (path->string pth))) + +(define (get-nodep-module-code/index mpi phase) + (define pth (mpi->path! mpi)) + (cond + [(symbol? pth) + (hash-set! (MODULE-IDX-MAP) pth pth) + pth] + [(excluded? pth) + (hash-set! (MODULE-IDX-MAP) pth mpi) + mpi] + [else + (get-nodep-module-code/path pth phase)])) + +(define-struct @phase (phase code)) +(define-struct modvar-rewrite (modidx provide->toplevel)) +(define-struct module-code (modvar-rewrite lang-info ctop)) +(define @phase-ctop (compose module-code-ctop @phase-code)) + +(define (get-nodep-module-code/path pth phase) + (define MODULE-CACHE + (hash-ref! (PHASE*MODULE-CACHE) phase make-hash)) + (if (hash-ref MODULE-CACHE pth #f) + #f + (hash-ref! + MODULE-CACHE pth + (lambda () + (define-values (base file dir?) (split-path pth)) + (define base-directory + (if (path? base) + (path->complete-path base (current-directory)) + (current-directory))) + (define-values (modvar-rewrite lang-info ctop) + (begin + (log-debug (format "Load ~S @ ~S" pth phase)) + (nodep/dir + (parameterize ([current-load-relative-directory base-directory]) + (path->comp-top + (build-compiled-path + base + (path-add-suffix file #".zo")))) + pth + phase))) + (when (and phase (zero? phase)) + (hash-set! (MODULE-IDX-MAP) pth modvar-rewrite)) + (make-@phase + phase + (make-module-code modvar-rewrite lang-info ctop)))))) + +(define (nodep/dir top pth phase) + (parameterize ([current-module-path pth]) + (nodep top phase))) + +(define (nodep top phase) + (match top + [(struct compilation-top (max-let-depth prefix form)) + (define-values (modvar-rewrite lang-info new-form) (nodep-form form phase)) + (values modvar-rewrite lang-info (make-compilation-top max-let-depth prefix new-form))] + [else (error 'nodep "unrecognized: ~e" top)])) + +(define (nodep-form form phase) + (if (mod? form) + (local [(define-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"))) + +; XXX interning is hack to fix test/add04.ss and provide/contract renaming +(define (intern s) (string->symbol (symbol->string s))) +(define (construct-provide->toplevel prefix provides) + (define provide-ht (make-hasheq)) + (for ([tl (prefix-toplevels prefix)] + [i (in-naturals)]) + (when (symbol? tl) + (hash-set! provide-ht (intern tl) i))) + (lambda (sym pos) + (log-debug (format "Looking up ~S@~a" sym pos)) + (hash-ref provide-ht (intern sym) + (lambda () + (error 'provide->toplevel "Cannot find ~S in ~S" sym prefix))))) + +(define (nodep-module mod-form phase) + (match mod-form + [(struct mod (name srcname self-modidx prefix provides requires body syntax-body unexported max-let-depth dummy lang-info internal-context)) + (define new-prefix prefix) + ; Cache all the mpi paths + (for-each (match-lambda + [(and mv (struct module-variable (modidx sym pos phase))) + (mpi->path! modidx)] + [tl + (void)]) + (prefix-toplevels new-prefix)) + (log-debug (format "[~S] module-variables: ~S" name (length (filter module-variable? (prefix-toplevels new-prefix))))) + (values (make-modvar-rewrite self-modidx (construct-provide->toplevel new-prefix provides)) + lang-info + (append (requires->modlist requires phase) + (if (and phase (zero? phase)) + (begin (log-debug (format "[~S] lang-info : ~S" name lang-info)) ; XXX Seems to always be #f now + (list (make-mod name srcname self-modidx new-prefix provides requires body empty + unexported max-let-depth dummy lang-info internal-context))) + (begin (log-debug (format "[~S] Dropping module @ ~S" name phase)) + empty))))] + [else (error 'nodep-module "huh?: ~e" mod-form)])) + +(define (+* l r) + (if (and l r) (+ l r) #f)) + +(define (requires->modlist requires current-phase) + (apply append + (map + (match-lambda + [(list-rest req-phase mpis) + (define phase (+* current-phase req-phase)) + (apply append + (map (compose extract-modules (lambda (mpi) (get-nodep-module-code/index mpi phase))) mpis))]) + requires))) + +(define (all-but-last l) + (reverse (rest (reverse l)))) + +(define REQUIRED (make-hasheq)) +(define (extract-modules ct) + (cond + [(compilation-top? ct) + (match (compilation-top-code ct) + [(and m (? mod?)) + (list m)] + [(struct splice (mods)) + mods])] + [(symbol? ct) + (if (hash-has-key? REQUIRED ct) + empty + (begin + (hash-set! REQUIRED ct #t) + (list (make-req (make-stx (make-wrapped ct empty #f)) (make-toplevel 0 0 #f #f)))))] + [(module-path-index? ct) + (if (hash-has-key? REQUIRED ct) + empty + (begin + (hash-set! REQUIRED ct #t) + (list (make-req (make-stx (make-wrapped ct empty #f)) (make-toplevel 0 0 #f #f)))))] + [(not ct) + empty] + [(@phase? ct) + (extract-modules (@phase-ctop ct))] + [else + (error 'extract-modules "Unknown extraction: ~S" ct)])) + +(define get-modvar-rewrite/c + (module-path-index? . -> . (or/c symbol? modvar-rewrite? module-path-index?))) +(provide/contract + [struct modvar-rewrite + ([modidx module-path-index?] + [provide->toplevel (symbol? exact-nonnegative-integer? . -> . exact-nonnegative-integer?)])] + [get-modvar-rewrite/c contract?] + [current-excluded-modules (parameter/c set?)] + [nodep-file (-> path-string? + (values compilation-top? lang-info/c module-path-index? get-modvar-rewrite/c))]) \ No newline at end of file diff --git a/collects/compiler/demodularizer/replace-modidx.rkt b/collects/compiler/demodularizer/replace-modidx.rkt new file mode 100644 index 0000000000..7ad45cbc56 --- /dev/null +++ b/collects/compiler/demodularizer/replace-modidx.rkt @@ -0,0 +1,25 @@ +#lang racket +(require unstable/struct + "util.rkt") +(provide replace-modidx) + +(define (replace-modidx expr self-modidx) + (define (inner-update e) + (match e + [(app prefab-struct-key (and key (not #f))) + (apply make-prefab-struct key + (map update + (struct->list e)))] + [(? module-path-index?) + (define-values (path mpi) (module-path-index-split e)) + (if (not path) + self-modidx + (module-path-index-join path (update mpi)))] + [(cons a b) + (cons (update a) (update b))] + [(? vector?) + (vector-map update e)] + [else e])) + (define-values (first-update update) + (build-form-memo inner-update)) + (first-update expr)) diff --git a/collects/compiler/demodularizer/update-toplevels.rkt b/collects/compiler/demodularizer/update-toplevels.rkt new file mode 100644 index 0000000000..c6d1f4d9c6 --- /dev/null +++ b/collects/compiler/demodularizer/update-toplevels.rkt @@ -0,0 +1,97 @@ +#lang racket +(require compiler/zo-structs + "util.rkt") + +(define (update-toplevels toplevel-updater topsyntax-updater topsyntax-new-midpt) + (define (inner-update form) + (match form + [(struct def-values (ids rhs)) + (make-def-values (map update ids) + (update rhs))] + [(? def-syntaxes?) + (error 'increment "Doesn't handle syntax")] + [(? def-for-syntax?) + (error 'increment "Doesn't handle syntax")] + [(struct req (reqs dummy)) + (make-req reqs (update dummy))] + [(? mod?) + (error 'increment "Doesn't handle modules")] + [(struct seq (forms)) + (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))) + (struct-copy lam l + [body (update body)])] + [(and c (struct closure (code gen-id))) + (struct-copy closure c + [code (update code)])] + [(and cl (struct case-lam (name clauses))) + (define new-clauses + (map update clauses)) + (struct-copy case-lam cl + [clauses new-clauses])] + [(struct let-one (rhs body flonum? unused?)) + (make-let-one (update rhs) (update body) flonum? unused?)] ; Q: is it okay to just pass in the old value for flonum? + [(and f (struct let-void (count boxes? body))) + (struct-copy let-void f + [body (update body)])] + [(and f (struct install-value (_ _ _ rhs body))) + (struct-copy install-value f + [rhs (update rhs)] + [body (update body)])] + [(struct let-rec (procs body)) + (make-let-rec (map update procs) (update body))] + [(and f (struct boxenv (_ body))) + (struct-copy boxenv f [body (update body)])] + [(and f (struct toplevel (_ pos _ _))) + (struct-copy toplevel f + [pos (toplevel-updater pos)])] + [(and f (struct topsyntax (_ pos _))) + (struct-copy topsyntax f + [pos (topsyntax-updater pos)] + [midpt topsyntax-new-midpt])] + [(struct application (rator rands)) + (make-application + (update rator) + (map update rands))] + [(struct branch (test then else)) + (make-branch + (update test) + (update then) + (update else))] + [(struct with-cont-mark (key val body)) + (make-with-cont-mark + (update key) + (update val) + (update body))] + [(struct beg0 (seq)) + (make-beg0 (map update seq))] + [(struct varref (tl)) + (make-varref (update tl))] + [(and f (struct assign (id rhs undef-ok?))) + (struct-copy assign f + [id (update id)] + [rhs (update rhs)])] + [(struct apply-values (proc args-expr)) + (make-apply-values + (update proc) + (update args-expr))] + [(and f (struct primval (id))) + f] + [(and f (struct localref (unbox? pos clear? other-clears? flonum?))) + f] + [(and f (not (? form?))) + f] + )) + (define-values (first-update update) + (build-form-memo inner-update)) + first-update) + +(provide/contract + [update-toplevels + ((exact-nonnegative-integer? . -> . exact-nonnegative-integer?) + (exact-nonnegative-integer? . -> . exact-nonnegative-integer?) + exact-nonnegative-integer? + . -> . + (form? . -> . form?))]) diff --git a/collects/compiler/demodularizer/util.rkt b/collects/compiler/demodularizer/util.rkt new file mode 100644 index 0000000000..1334e2911b --- /dev/null +++ b/collects/compiler/demodularizer/util.rkt @@ -0,0 +1,80 @@ +#lang racket +(require compiler/zo-parse) + +(define (prefix-syntax-start pre) + (length (prefix-toplevels pre))) + +(define (prefix-lift-start pre) + (define syntax-start (prefix-syntax-start pre)) + (define total-stxs (length (prefix-stxs pre))) + (+ syntax-start total-stxs (if (zero? total-stxs) 0 1))) + +(define (eprintf . args) + (apply fprintf (current-error-port) args)) + +(struct nothing ()) + +(define-syntax-rule (eprintf* . args) (void)) + +(define (build-form-memo inner-update #:void? [void? #f]) + (define memo (make-hasheq)) + (define (update form . args) + (eprintf* "Updating on ~a\n" form) + (define fin + (cond + [(hash-ref memo form #f) + => (λ (x) + (eprintf* "Found in memo table\n") + x)] + [else + (eprintf* "Not in memo table\n") + (let () + (define ph (make-placeholder (nothing))) + (hash-set! memo form ph) + (define nv (nothing)) + (dynamic-wind void + (λ () + (set! nv (apply inner-update form args))) + (λ () + (if (nothing? nv) + (eprintf* "inner-update returned nothing (or there was an escape) on ~a\n" form) + (begin + (placeholder-set! ph nv) + (hash-set! memo form nv))))) + nv)])) + (eprintf* "Updating on ~a ---->\n ~a\n" form fin) + fin) + (define (first-update form . args) + (eprintf* "Top level update on ~a\n" form) + (define final (apply update form args)) + (eprintf* "Top level update on ~a ---->\n ~a\n" form final) + (define fin (make-reader-graph final)) + (eprintf* "Top level update on ~a ---->\n ~a [after reader-graph]\n" form fin) + fin) + (values first-update update)) + +(define lang-info/c + (or/c #f (vector/c module-path? symbol? any/c))) + + +(define (build-compiled-path base name) + (build-path + (cond [(path? base) base] + [(eq? base 'relative) 'same] + [(eq? base #f) (error 'batch "Impossible")]) + "compiled" + name)) + + +(provide/contract + [prefix-syntax-start (prefix? . -> . exact-nonnegative-integer?)] + [prefix-lift-start (prefix? . -> . exact-nonnegative-integer?)] + [eprintf ((string?) () #:rest (listof any/c) . ->* . void)] + [build-form-memo + (((unconstrained-domain-> any/c)) + (#:void? boolean?) + . ->* . + (values (unconstrained-domain-> any/c) + (unconstrained-domain-> any/c)))] + [lang-info/c contract?] + [build-compiled-path ((or/c path-string? (symbols 'relative) false/c) path-string? . -> . (or/c path-string? (symbols 'same 'up)))]) \ No newline at end of file diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 8333ef8c23..5629f4a917 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -1,250 +1,148 @@ -#lang scheme/base +#lang racket/base (require compiler/zo-structs - scheme/port - scheme/match - scheme/contract - scheme/local - scheme/list - scheme/dict) + unstable/struct + racket/port + racket/vector + racket/match + racket/contract + racket/local + racket/list + racket/dict + racket/function + racket/pretty + racket/path + racket/set) (provide/contract [zo-marshal (compilation-top? . -> . bytes?)] [zo-marshal-to (compilation-top? output-port? . -> . void?)]) -#| Unresolved Issues - - Less sharing occurs than in the C implementation, creating much larger files +(struct not-ready ()) - protect-quote caused some things to be sent to write. But there are some things (like paths) that can be read and passed to protect-quote that cannot be 'read' in after 'write', so we turned it off -|# - -(define current-wrapped-ht (make-parameter #f)) (define (zo-marshal top) (define bs (open-output-bytes)) (zo-marshal-to top bs) (get-output-bytes bs)) -(define (zo-marshal-to top outp) - (match top - [(struct compilation-top (max-let-depth prefix form)) - (define encountered (make-hasheq)) - (define shared (make-hasheq)) - (define wrapped (make-hasheq)) - (define (visit v) - (if (hash-ref shared v #f) - #f - (if (hash-ref encountered v #f) - (begin - (hash-set! shared v (add1 (hash-count shared))) - #f) - (begin - (hash-set! encountered v #t) - (when (closure? v) - (hash-set! shared v (add1 (hash-count shared)))) - #t)))) - (define (v-skipping v) - (define skip? #t) - (lambda (v2) - (if (and skip? (eq? v v2)) - (begin - (set! skip? #f) - #f) - (hash-ref shared v2 #f)))) - (parameterize ([current-wrapped-ht wrapped]) - (traverse-prefix prefix visit) - (traverse-form form visit)) - (local [(define in-order-shareds - (sort (hash-map shared (lambda (k v) (cons v k))) - < - #:key car)) - (define (write-all outp) - (define offsets - (for/list ([k*v (in-list in-order-shareds)]) - (define v (cdr k*v)) - (begin0 - (file-position outp) - (out-anything v (make-out outp (v-skipping v) wrapped))))) - (define post-shared (file-position outp)) - (out-data (list* max-let-depth prefix (protect-quote form)) - (make-out outp (lambda (v) (hash-ref shared v #f)) wrapped)) - (values offsets post-shared (file-position outp))) - (define counting-p (open-output-nowhere)) - (define-values (offsets post-shared all-forms-length) - (write-all counting-p)) - (define all-short? (post-shared . < . #xFFFF)) - (define version-bs (string->bytes/latin-1 (version)))] - (write-bytes #"#~" outp) - (write-bytes (bytes (bytes-length version-bs)) outp) - (write-bytes version-bs outp) - (write-bytes (int->bytes (add1 (hash-count shared))) outp) - (write-bytes (bytes (if all-short? 1 0)) outp) - (for ([o (in-list offsets)]) - (write-bytes (integer->integer-bytes o (if all-short? 2 4) #f #f) outp)) - (write-bytes (int->bytes post-shared) outp) - (write-bytes (int->bytes all-forms-length) outp) - (write-all outp) - (void))])) +(define (zo-marshal-to top outp) + + ; XXX: wraps were encoded in traverse, now needs to be handled when writing + (define wrapped (make-hash)) + + ; (obj -> (or pos #f)) output-port -> number + ; writes top to outp using shared-obj-pos to determine symref + ; returns the file position at the end of the compilation top + (define (out-compilation-top shared-obj-pos shared-obj-unsee outp) + (define ct + (match top + [(compilation-top max-let-depth prefix form) + (list* max-let-depth prefix (protect-quote form))])) + (out-anything ct (make-out outp shared-obj-pos shared-obj-unsee wrapped)) + (file-position outp)) + + ; -> vector + ; calculates what values show up in the compilation top more than once + ; closures are always included even if they only show up once + (define (create-symbol-table) + (define encountered (make-hasheq)) + (define shared (make-hasheq)) + (define (encountered? v) + ((hash-ref encountered v 0) . > . 0)) + (define (encounter! v) + (hash-update! encountered v add1 0) + #f) + (define (unencounter! v) + (define how-many-encounters (hash-ref encountered v)) + (when (= how-many-encounters 1) + (hash-set! encountered v 0))) + (define (shared-obj-pos v #:error? [error? #f]) + (hash-ref shared v + (if error? + (λ () (error 'symref "~e not in symbol table" v)) + #f))) + (define (share! v) ; XXX this doesn't always set something, probably should be refactored + (or (shared-obj-pos v) + (let ([pos (add1 (hash-count shared))]) + (hash-set! shared v pos) + pos))) + + (out-compilation-top + (λ (v #:error? [error? #f]) + (cond + [(hash? v) (error 'create-symbol-table "current type trace: ~a" (current-type-trace))] + [(closure? v) + (let ([pos (share! v)]) + (if (encountered? v) + pos + (encounter! v)))] + [error? ; If we would error if this were not present, then we must share it + (encounter! v) + (share! v)] + [(encountered? v) + (share! v)] + [else + (encounter! v)])) + (λ (v) + (unencounter! v)) + (open-output-nowhere)) + + (define symbol-table (make-vector (hash-count shared) (not-ready))) + (hash-map shared (λ (k v) (vector-set! symbol-table (sub1 v) k))) + (values symbol-table shared-obj-pos)) + + (define-values (symbol-table shared-obj-pos) + (create-symbol-table)) + + ; vector output-port -> (listof number) number + ; writes symbol-table to outp + ; returns the file positions of each value in the symbol table and the end of the symbol table + (define (out-symbol-table symbol-table outp) + (define (shared-obj-pos/modulo-v v) + (define skip? #t) + (λ (v2 #:error? [error? #f]) + (if (and skip? (eq? v v2)) + (begin + (set! skip? #f) + #f) + (shared-obj-pos v2 + #:error? error?)))) + (values + (for/list ([v (in-vector symbol-table)] + [i (in-naturals)]) + (begin0 + (file-position outp) + (out-anything v (make-out outp (shared-obj-pos/modulo-v v) void wrapped)))) + (file-position outp))) + + ; Calculate file positions + (define counting-port (open-output-nowhere)) + (define-values (offsets post-shared) (out-symbol-table symbol-table counting-port)) + (define all-forms-length (out-compilation-top shared-obj-pos void counting-port)) + + ; Write the compiled form header + (write-bytes #"#~" outp) + + ; Write the version (notice that it isn't the same as out-string) + (define version-bs (string->bytes/latin-1 (version))) + (write-bytes (bytes (bytes-length version-bs)) outp) + (write-bytes version-bs outp) -;; ---------------------------------------- - -(define (traverse-prefix a-prefix visit) - (match a-prefix - [(struct prefix (num-lifts toplevels 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 srcname self-modidx prefix provides requires body syntax-body unexported - max-let-depth dummy lang-info internal-context)) - (traverse-data name visit) - (traverse-data srcname 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 visit)) body) - (for-each (lambda (f) (traverse-form f visit)) syntax-body) - (traverse-data lang-info visit) - (traverse-data internal-context visit)])) - -(define (traverse-toplevel tl visit) - (match tl - [#f (void)] - [(? symbol?) (traverse-data tl visit)] - [(struct global-bucket (name)) - (void)] - [(struct module-variable (modidx sym pos phase)) - (visit tl) - (let-values ([(p b) (module-path-index-split modidx)]) - (if (symbol? p) - (traverse-data p visit) - (traverse-data modidx visit))) - (traverse-data sym visit)])) - -(define (traverse-wrapped w visit) - (define ew (hash-ref! (current-wrapped-ht) w (lambda () (encode-wrapped w)))) - (traverse-data ew visit)) - -(define (traverse-stx s visit) - (when s - (traverse-wrapped (stx-encoded s) visit))) - - -(define (traverse-form form visit) - (match form - [(? mod?) - (traverse-module form visit)] - [(struct def-values (ids rhs)) - (traverse-expr rhs visit)] - [(struct def-syntaxes (ids rhs prefix max-let-depth)) - (traverse-prefix prefix visit) - (traverse-expr rhs visit)] - [(struct def-for-syntax (ids rhs prefix max-let-depth)) - (traverse-prefix prefix visit) - (traverse-expr rhs visit)] - [(struct seq (forms)) - (for-each (lambda (f) (traverse-form f visit)) forms)] - [(struct splice (forms)) - (for-each (lambda (f) (traverse-form f visit)) forms)] - [else - (traverse-expr form visit)])) - -(define (traverse-expr expr visit) - (match expr - [(struct toplevel (depth pos const? ready?)) - (void)] - [(struct topsyntax (depth pos midpt)) - (void)] - [(struct primval (id)) - (void)] - [(struct assign (id rhs undef-ok?)) - (traverse-expr rhs visit)] - [(struct localref (unbox? offset clear? other-clears? flonum?)) - (void)] - [(? lam?) - (traverse-lam expr visit)] - [(struct case-lam (name lams)) - (traverse-data name visit) - (for-each (lambda (lam) (traverse-lam lam visit)) lams)] - [(struct let-one (rhs body flonum? unused?)) - (traverse-expr rhs visit) - (traverse-expr body visit)] - [(struct let-void (count boxes? body)) - (traverse-expr body visit)] - [(struct let-rec (procs body)) - (for-each (lambda (lam) (traverse-lam lam visit)) procs) - (traverse-expr body visit)] - [(struct install-value (count pos boxes? rhs body)) - (traverse-expr rhs visit) - (traverse-expr body visit)] - [(struct boxenv (pos body)) - (traverse-expr body visit)] - [(struct branch (test then else)) - (traverse-expr test visit) - (traverse-expr then visit) - (traverse-expr else visit)] - [(struct application (rator rands)) - (traverse-expr rator visit) - (for-each (lambda (rand) (traverse-expr rand visit)) rands)] - [(struct apply-values (proc args-expr)) - (traverse-expr proc visit) - (traverse-expr args-expr visit)] - [(struct seq (exprs)) - (for-each (lambda (expr) (traverse-form expr visit)) exprs)] - [(struct beg0 (exprs)) - (for-each (lambda (expr) (traverse-expr expr visit)) exprs)] - [(struct with-cont-mark (key val body)) - (traverse-expr key visit) - (traverse-expr val visit) - (traverse-expr body visit)] - [(struct closure (lam gen-id)) - (traverse-lam expr visit)] - [(struct indirect (val)) - (traverse-expr val visit)] - [else (traverse-data expr visit)])) - -(define (traverse-data expr visit) - (cond - [(or (symbol? expr) - (keyword? expr) - (string? expr) - (bytes? 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)] - [(vector? expr) - (for ([e (in-vector expr)]) - (traverse-data e visit))] - [(box? expr) - (traverse-data (unbox expr) visit)] - [(stx? expr) - (traverse-stx expr visit)] - [(wrapped? expr) - (traverse-wrapped expr visit)] - [(hash? expr) - (when (visit expr) - (for ([(k v) (in-hash expr)]) - (traverse-data k visit) - (traverse-data v visit)))] - [else - (void)])) - -(define (traverse-lam expr visit) - (match expr - [(struct indirect (val)) (traverse-lam val visit)] - [(struct closure (lam gen-id)) - (when (visit expr) - (traverse-lam lam visit))] - [(struct lam (name flags num-params param-types rest? closure-map closure-types max-let-depth body)) - (traverse-data name visit) - (traverse-expr body visit)])) + + ; Write the symbol table information (size, offsets) + (define symtabsize (add1 (vector-length symbol-table))) + (write-bytes (int->bytes symtabsize) outp) + (define all-short? (post-shared . < . #xFFFF)) + (write-bytes (bytes (if all-short? 1 0)) outp) + (for ([o (in-list offsets)]) + (write-bytes (integer->integer-bytes o (if all-short? 2 4) #f #f) outp)) + ; Post-shared is where the ctop actually starts + (write-bytes (int->bytes post-shared) outp) + ; This is where the file should end + (write-bytes (int->bytes all-forms-length) outp) + ; Actually write the zo + (out-symbol-table symbol-table outp) + (out-compilation-top shared-obj-pos void outp) + (void)) ;; ---------------------------------------- @@ -263,6 +161,7 @@ (define begin0-sequence-type-num 100) (define module-type-num 103) (define prefix-type-num 105) +(define free-id-info-type-num 154) (define-syntax define-enum (syntax-rules () @@ -307,7 +206,7 @@ CPT_MODULE_VAR CPT_PATH CPT_CLOSURE - CPT_DELAY_REF + CPT_DELAY_REF ; XXX unused, but appears to be same as CPT_SYMREF CPT_PREFAB CPT_LET_ONE_UNUSED) @@ -372,18 +271,148 @@ (define-struct case-seq (name lams)) (define-struct (seq0 seq) ()) -(define-struct out (s shared-index encoded-wraps)) + +(define (encode-module-bindings module-bindings) + (define encode-nominal-path + (match-lambda + [(struct simple-nominal-path (value)) + value] + [(struct imported-nominal-path (value import-phase)) + (cons value import-phase)] + [(struct phased-nominal-path (value import-phase phase)) + (cons value (cons import-phase phase))])) + (define encoded-bindings (make-vector (* (length module-bindings) 2))) + (for ([i (in-naturals)] + [(k v) (in-dict module-bindings)]) + (vector-set! encoded-bindings (* i 2) k) + (vector-set! encoded-bindings (add1 (* i 2)) + (match v + [(struct simple-module-binding (path)) + path] + [(struct exported-module-binding (path export-name)) + (cons path export-name)] + [(struct nominal-module-binding (path nominal-path)) + (cons path (encode-nominal-path nominal-path))] + [(struct exported-nominal-module-binding (path export-name nominal-path nominal-export-name)) + (list* path export-name (encode-nominal-path nominal-path) nominal-export-name)] + [(struct phased-module-binding (path phase export-name nominal-path nominal-export-name)) + (list* path phase export-name (encode-nominal-path nominal-path) nominal-export-name)]))) + encoded-bindings) + +(define (encode-all-from-module afm) + (match afm + [(struct all-from-module (path phase src-phase #f #f)) + (list* path phase src-phase)] + [(struct all-from-module (path phase src-phase exns #f)) + (list* path phase exns src-phase)] + [(struct all-from-module (path phase src-phase exns (vector prefix))) + (list* path phase src-phase exns prefix)])) + +(define (encode-wraps wraps) + (for/list ([wrap (in-list wraps)]) + (match wrap + [(struct phase-shift (amt src dest)) + (box (vector amt src dest #f))] + [(struct module-rename (phase kind set-id unmarshals renames mark-renames plus-kern?)) + (define encoded-kind (eq? kind 'marked)) + (define encoded-unmarshals (map encode-all-from-module unmarshals)) + (define encoded-renames (encode-module-bindings renames)) + (define-values (maybe-unmarshals maybe-renames) (if (null? encoded-unmarshals) + (values encoded-renames mark-renames) + (values encoded-unmarshals (cons encoded-renames mark-renames)))) + (define mod-rename (list* phase encoded-kind set-id maybe-unmarshals maybe-renames)) + (if plus-kern? + (cons #t mod-rename) + mod-rename)] + [(struct lexical-rename (bool1 bool2 alist)) + (define len (length alist)) + (define vec (make-vector (+ (* 2 len) 2))) ; + 2 for booleans at the beginning + (vector-set! vec 0 bool1) + (vector-set! vec 1 bool2) + (for ([(k v) (in-dict alist)] + [i (in-naturals)]) + (vector-set! vec (+ 2 i) k) + (vector-set! vec (+ 2 i len) v)) + vec] + [(struct top-level-rename (flag)) + flag] + [(struct mark-barrier (value)) + value] + [(struct prune (syms)) + (box syms)] + [(struct wrap-mark (val)) + (list val)]))) + +(define (encode-mark-map mm) + mm + #;(for/fold ([l empty]) + ([(k v) (in-hash ht)]) + (list* k v l))) + +(define-struct protected-symref (val)) + +(define encode-certs + (match-lambda + [(struct certificate:nest (m1 m2)) + (list* (encode-mark-map m1) (encode-mark-map m2))] + [(struct certificate:ref (val m)) + (list* #f (make-protected-symref val) (encode-mark-map m))] + [(struct certificate:plain (m)) + (encode-mark-map m)])) + +(define (encode-wrapped w) + (match w + [(struct wrapped (datum wraps certs)) + (let* ([enc-datum + (match datum + [(cons a b) + (let ([p (cons (encode-wrapped a) + (let bloop ([b b]) + (match b + ['() null] + [(cons b1 b2) + (cons (encode-wrapped b1) + (bloop b2))] + [else + (encode-wrapped b)])))] + ; XXX Cylic list error possible + [len (let loop ([datum datum][len 0]) + (cond + [(null? datum) #f] + [(pair? datum) (loop (cdr datum) (add1 len))] + [else len]))]) + ;; for improper lists, we need to include the length so the + ;; parser knows where the end of the improper list is + (if len + (cons len p) + p))] + [(box x) + (box (encode-wrapped x))] + [(? vector? v) + (vector-map encode-wrapped v)] + [(? prefab-struct-key) + (define l (vector->list (struct->vector datum))) + (apply + make-prefab-struct + (car l) + (map encode-wrapped (cdr l)))] + [_ datum])] + [p (cons enc-datum + (encode-wraps wraps))]) + (if certs + (vector p (encode-certs certs)) + p))])) + +(define-struct out (s shared-index shared-unsee encoded-wraps)) (define (out-shared v out k) - (let ([v ((out-shared-index out) v)]) - (if v - (begin - (out-byte CPT_SYMREF out) - (out-number v out)) - (k)))) -(define (display-byte b) - (if (b . <= . #xf) - (printf "0~x" b) - (printf "~x" b))) + (if (shareable? v) + (let ([v ((out-shared-index out) v)]) + (if v + (begin + (out-byte CPT_SYMREF out) + (out-number v out)) + (k))) + (k))) (define (out-byte v out) (write-byte v (out-s out))) @@ -417,26 +446,422 @@ (begin (out-byte CPT_MARSHALLED out) (out-number type-num out))) - (out-data val out)) + (out-anything val out)) + +(define (or-pred? v . ps) + (ormap (lambda (?) (? v)) ps)) + +(define quoting? (make-parameter #f)) + +(define (shareable? v) + (define never-share-this? + (or-pred? v char? maybe-same-as-fixnum? empty? boolean? void? hash?)) + (define always-share-this? + (or-pred? v closure?)) + (or always-share-this? + (if (quoting?) + #f + (not never-share-this?)))) + +(define (maybe-same-as-fixnum? v) + (and (exact-integer? v) + (and (v . >= . -1073741824) (v . <= . 1073741823)))) + +(define (current-type-trace) + (reverse (continuation-mark-set->list (current-continuation-marks) 'zo))) + +(define (typeof v) + (cond + [(pair? v) 'cons] + [(hash? v) 'hash] + [(prefab-struct-key v) => (λ (key) key)] + [(vector? v) 'vector] + [else v])) + +(define-syntax with-type-trace + (syntax-rules () + [(_ v body ...) + #;(begin body ...) + (with-continuation-mark 'zo (typeof v) + (begin0 (begin body ...) (void)))])) (define (out-anything v out) - (cond - [(module-variable? v) - (out-toplevel v out)] - [(closure? v) - (out-expr v out)] - [else - (out-data v out)])) - -(define (out-prefix a-prefix out) - (match a-prefix - [(struct prefix (num-lifts toplevels stxs)) - (out-marshaled - prefix-type-num - (cons num-lifts - (cons (list->vector toplevels) - (list->vector stxs))) - out)])) + (with-type-trace v + (out-shared + v out + (λ () + (match v + [(? char?) + (out-byte CPT_CHAR out) + (out-number (char->integer v) out)] + [(? maybe-same-as-fixnum?) ;XXX not sure if it's okay to use fixnum? instead of exact range check + (if (and (v . >= . 0) + (v . < . (- CPT_SMALL_NUMBER_END CPT_SMALL_NUMBER_START))) + (out-byte (+ CPT_SMALL_NUMBER_START v) out) + (begin + (out-byte CPT_INT out) + (out-number v out)))] + [(list) + (out-byte CPT_NULL out)] + [#t + (out-byte CPT_TRUE out)] + [#f + (out-byte CPT_FALSE out)] + [(? void?) + (out-byte CPT_VOID out)] + [(struct module-variable (modidx sym pos phase)) + (out-byte CPT_MODULE_VAR out) + (out-anything modidx out) + (out-anything sym out) + (unless (zero? phase) + (out-number -2 out)) + (out-number pos out)] + [(struct closure (lam gen-id)) + (out-byte CPT_CLOSURE out) + (let ([pos ((out-shared-index out) v #:error? #t)]) + (out-number pos out) + (out-anything lam out))] + [(struct prefix (num-lifts toplevels stxs)) + (out-marshaled + prefix-type-num + (cons num-lifts + (cons (list->vector toplevels) + (list->vector stxs))) + out)] + [(struct global-bucket (name)) + (out-marshaled variable-type-num name out)] + [(struct free-id-info (mpi0 s0 mpi1 s1 p0 p1 p2 insp?)) + (out-marshaled + free-id-info-type-num + (vector mpi0 s0 mpi1 s1 p0 p1 p2 insp?) + out)] + [(? mod?) + (out-module v out)] + [(struct def-values (ids rhs)) + (out-syntax DEFINE_VALUES_EXPD + (list->vector (cons (protect-quote rhs) ids)) + out)] + [(struct def-syntaxes (ids rhs prefix max-let-depth)) + (out-syntax DEFINE_SYNTAX_EXPD + (list->vector (list* (protect-quote rhs) + prefix + max-let-depth + *dummy* + ids)) + out)] + [(struct def-for-syntax (ids rhs prefix max-let-depth)) + (out-syntax DEFINE_FOR_SYNTAX_EXPD + (list->vector (list* (protect-quote rhs) + prefix + max-let-depth + *dummy* + ids)) + out)] + [(struct seq0 (forms)) + (out-marshaled begin0-sequence-type-num (map protect-quote forms) out)] + [(struct seq (forms)) + (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)] + [(struct toplevel (depth pos const? ready?)) + (out-marshaled toplevel-type-num + (cons + depth + (if (or const? ready?) + (cons pos + (bitwise-ior + (if const? #x1 0) + (if ready? #x2 0))) + pos)) + out)] + [(struct topsyntax (depth pos midpt)) + (out-marshaled quote-syntax-type-num + (cons depth + (cons pos midpt)) + out)] + [(struct primval (id)) + (out-byte CPT_REFERENCE out) + (out-number id out)] + [(struct assign (id rhs undef-ok?)) + (out-syntax SET_EXPD + (cons undef-ok? (cons id rhs)) + out)] + [(struct localref (unbox? offset clear? other-clears? flonum?)) + (if (and (not clear?) (not other-clears?) (not flonum?) + (offset . < . (- CPT_SMALL_LOCAL_END CPT_SMALL_LOCAL_START))) + (out-byte (+ (if unbox? + CPT_SMALL_LOCAL_UNBOX_START + CPT_SMALL_LOCAL_START) + offset) + out) + (begin + (out-byte (if unbox? CPT_LOCAL_UNBOX CPT_LOCAL) out) + (if (not (or clear? other-clears? flonum?)) + (out-number offset out) + (begin + (out-number (- (add1 offset)) out) + (out-number (if clear? + #x1 + (if other-clears? + #x2 + (if flonum? + #x3 + 0))) + out)))))] + [(? lam?) + (out-lam v out)] + [(struct case-lam (name lams)) + (let ([seq (make-case-seq name lams)]) + ;; XXX: This seems like an optimization, which should probably happen somewhere else + ;; If all closures are empty, generate a case sequence directly + (if (andmap (lambda (lam) + (or (closure? lam) + (and (lam? lam) + (equal? (lam-closure-map lam) #())))) + lams) + (out-anything seq out) + (out-syntax CASE_LAMBDA_EXPD + seq + out)))] + [(struct case-seq (name lams)) + (out-marshaled case-lambda-sequence-type-num + (cons (or name null) + lams) + out)] + [(struct let-one (rhs body flonum? unused?)) + (out-byte (cond + [flonum? CPT_LET_ONE_FLONUM] + [unused? CPT_LET_ONE_UNUSED] + [else CPT_LET_ONE]) + out) + (out-anything (protect-quote rhs) out) + (out-anything (protect-quote body) out)] + [(struct let-void (count boxes? body)) + (out-marshaled let-void-type-num + (list* + count + boxes? + (protect-quote body)) + out)] + [(struct let-rec (procs body)) + (out-marshaled letrec-type-num + (list* + (length procs) + (protect-quote body) + procs) + out)] + [(struct install-value (count pos boxes? rhs body)) + (out-marshaled let-value-type-num + (list* + count + pos + boxes? + (protect-quote rhs) + (protect-quote body)) + out)] + [(struct boxenv (pos body)) + (out-syntax BOXENV_EXPD + (cons + pos + (protect-quote body)) + out)] + [(struct branch (test then else)) + (out-byte CPT_BRANCH out) + (out-anything (protect-quote test) out) + (out-anything (protect-quote then) out) + (out-anything (protect-quote else) out)] + [(struct application (rator rands)) + (let ([len (length rands)]) + (if (len . < . (- CPT_SMALL_APPLICATION_END CPT_SMALL_APPLICATION_START)) + (out-byte (+ CPT_SMALL_APPLICATION_START (length rands)) out) + (begin + (out-byte CPT_APPLICATION out) + (out-number len out))) + (for-each (lambda (e) + (out-anything (protect-quote e) out)) + (cons rator rands)))] + [(struct apply-values (proc args-expr)) + (out-syntax APPVALS_EXPD + (cons (protect-quote proc) + (protect-quote args-expr)) + out)] + [(struct beg0 (exprs)) + (out-syntax BEGIN0_EXPD + (make-seq0 exprs) + out)] + [(struct with-cont-mark (key val body)) + (out-marshaled wcm-type-num + (list* + (protect-quote key) + (protect-quote val) + (protect-quote body)) + out)] + [(struct varref (expr)) + (out-syntax REF_EXPD + expr + out)] + [(protected-symref v) + (out-anything ((out-shared-index out) v #:error? #t) out)] + [(and (? symbol?) (not (? symbol-interned?))) + (out-as-bytes v + #:before-length (if (symbol-unreadable? v) 0 1) + (compose string->bytes/utf-8 symbol->string) + CPT_WEIRD_SYMBOL + #f + out)] + [(? symbol?) + (define bs (string->bytes/utf-8 (symbol->string v))) + (define len (bytes-length bs)) + (if (len . < . (- CPT_SMALL_SYMBOL_END CPT_SMALL_SYMBOL_START)) + (out-byte (+ CPT_SMALL_SYMBOL_START len) out) + (begin (out-byte CPT_SYMBOL out) + (out-number len out))) + (out-bytes bs out)] + [(? keyword?) + (out-as-bytes v + (compose string->bytes/utf-8 keyword->string) + CPT_KEYWORD + #f + out)] + [(? string?) + (out-as-bytes v + string->bytes/utf-8 + CPT_CHAR_STRING + (string-length v) + out)] + [(? bytes?) + (out-as-bytes v + values + CPT_BYTE_STRING + #f + out)] + [(? box?) + (out-byte CPT_BOX out) + (out-anything (unbox v) out)] + [(? pair?) + ; This code will not turn two different lists that share a common tail + ; e.g. (list* 1 l) and (list* 2 l) + ; into a form that puts l into the symbol table + ; (when that is possible) + + ; In contrast, if we always use CPT_PAIR, then it would + + ; Unfortunately, detecting this situation during the traversal + ; phase, without introducing false sharing, is difficult. + ; We had an implementation (see the history), but it was buggy. + (define (list-length-before-cycle/improper-end l) + (let loop ([len 0] [l l] [seen (set)]) + (cond + [(set-member? seen l) + (values len #f)] + [(null? l) + (values len #t)] + [(pair? l) + (loop (add1 len) (cdr l) (set-add seen l))] + [else + (values len #f)]))) + (define-values (len proper?) (list-length-before-cycle/improper-end v)) + + (define (print-contents-as-proper) + (for ([e (in-list v)]) + (out-anything e out))) + (define (print-contents-as-improper) + (let loop ([l v] [i len]) + (cond + [(zero? i) + (out-anything l out)] + [else + (out-anything (car l) out) + (loop (cdr l) (sub1 i))]))) + (if proper? + (if (len . < . (- CPT_SMALL_PROPER_LIST_END CPT_SMALL_PROPER_LIST_START)) + (begin (out-byte (+ CPT_SMALL_PROPER_LIST_START len) out) + (print-contents-as-proper)) + (begin (out-byte CPT_LIST out) + (out-number len out) + (print-contents-as-proper) + (out-anything null out))) + (if (len . < . (- CPT_SMALL_LIST_END CPT_SMALL_LIST_START)) + ; XXX If len = 1 (or maybe = 2?) then this could by CPT_PAIR + (begin (out-byte (+ CPT_SMALL_LIST_START len) out) + (print-contents-as-improper)) + (begin (out-byte CPT_LIST out) + (out-number len out) + (print-contents-as-improper))))] + [(? vector?) + (out-byte CPT_VECTOR out) + (out-number (vector-length v) out) + (for ([v (in-vector v)]) + (out-anything v out))] + [(? hash?) + (out-byte CPT_HASH_TABLE out) + (out-number (cond + [(hash-eqv? v) 2] + [(hash-eq? v) 0] + [(hash-equal? v) 1]) + out) + (out-number (hash-count v) out) + (for ([(k v) (in-hash v)]) + (out-anything k out) + (out-anything v out))] + [(svector vec) + (let* ([len (vector-length vec)]) + (if (len . < . (- CPT_SMALL_SVECTOR_END CPT_SMALL_SVECTOR_START)) + (out-byte (+ CPT_SMALL_SVECTOR_START len) out) + (begin (out-byte CPT_SVECTOR out) + (out-number len out))) + (for ([n (in-range (sub1 len) -1 -1)]) + (out-number (vector-ref vec n) out)))] + [(? module-path-index?) + (out-byte CPT_MODULE_INDEX out) + (let-values ([(name base) (module-path-index-split v)]) + (out-anything name out) + (out-anything base out))] + [(module-decl content) + (out-marshaled module-type-num + content + out)] + [(stx encoded) + (out-byte CPT_STX out) + (out-anything encoded out)] + [(? wrapped?) + (out-anything (lookup-encoded-wrapped v out) out)] + [(? prefab-struct-key) + (define pre-v (struct->vector v)) + (vector-set! pre-v 0 (prefab-struct-key v)) + (out-byte CPT_PREFAB out) + (out-anything pre-v out)] + [(quoted qv) + (out-byte CPT_QUOTE out) + (parameterize ([quoting? #t]) + (out-anything qv out))] + [(or (? path?) ; XXX Why not use CPT_PATH? + (? regexp?) + (? byte-regexp?) + (? number?)) + (out-byte CPT_QUOTE out) + (define s (open-output-bytes)) + (parameterize + ([pretty-print-size-hook + (lambda (v mode port) + (and (path? v) + (let ([v (make-relative v)]) + (+ 2 (let ([p (open-output-bytes)]) + (write (path->bytes v) p) + (bytes-length (get-output-bytes p)))))))] + [pretty-print-print-hook + (lambda (v mode port) + (display "#^" port) + (write (path->bytes (make-relative v)) port))]) + (pretty-write v s)) + (out-byte CPT_ESCAPE out) + (define bstr (get-output-bytes s)) + (out-number (bytes-length bstr) out) + (out-bytes bstr out)] + [else (error 'out-anything "~s" (current-type-trace))]))))) (define-struct module-decl (content)) @@ -531,313 +956,22 @@ (make-module-decl l)) out)])) -(define (out-toplevel tl out) - (match tl - [#f (out-data tl out)] - [(? symbol?) (out-data tl out)] - [(struct global-bucket (name)) - (out-marshaled variable-type-num name out)] - [(struct module-variable (modidx sym pos phase)) - (out-shared - tl - out - (lambda () - (out-byte CPT_MODULE_VAR out) - (out-data modidx out) - (out-data sym out) - (unless (zero? phase) - (out-number -2 out)) - (out-number pos out)))])) - -(define (encode-module-bindings module-bindings) - (define encode-nominal-path - (match-lambda - [(struct simple-nominal-path (value)) - value] - [(struct imported-nominal-path (value import-phase)) - (cons value import-phase)] - [(struct phased-nominal-path (value import-phase phase)) - (cons value (cons import-phase phase))])) - (define encoded-bindings (make-vector (* (length module-bindings) 2))) - (for ([i (in-naturals)] - [(k v) (in-dict module-bindings)]) - (vector-set! encoded-bindings (* i 2) k) - (vector-set! encoded-bindings (add1 (* i 2)) - (match v - [(struct simple-module-binding (path)) - path] - [(struct exported-module-binding (path export-name)) - (cons path export-name)] - [(struct nominal-module-binding (path nominal-path)) - (cons path (encode-nominal-path nominal-path))] - [(struct exported-nominal-module-binding (path export-name nominal-path nominal-export-name)) - (list* path export-name (encode-nominal-path nominal-path) nominal-export-name)] - [(struct phased-module-binding (path phase export-name nominal-path nominal-export-name)) - (list* path phase export-name (encode-nominal-path nominal-path) nominal-export-name)]))) - encoded-bindings) - -(define (encode-all-from-module all) - (match all - [(struct all-from-module (path phase src-phase exceptions prefix)) - (if (and (empty? exceptions) (not prefix)) - (list* path phase src-phase) - (list* path phase src-phase (append exceptions prefix)))])) - -(define (encode-wraps wraps) - (for/list ([wrap (in-list wraps)]) - (match wrap - [(struct phase-shift (amt src dest)) - (box (vector amt src dest #f))] - [(struct module-rename (phase kind set-id unmarshals renames mark-renames plus-kern?)) - (define encoded-kind (eq? kind 'marked)) - (define encoded-unmarshals (map encode-all-from-module unmarshals)) - (define encoded-renames (encode-module-bindings renames)) - (define-values (maybe-unmarshals maybe-renames) (if (null? encoded-unmarshals) - (values encoded-renames mark-renames) - (values encoded-unmarshals (cons encoded-renames mark-renames)))) - (define mod-rename (list* phase encoded-kind set-id maybe-unmarshals maybe-renames)) - (if plus-kern? - (cons #t mod-rename) - mod-rename)] - [(struct lexical-rename (bool1 bool2 alist)) - (define len (length alist)) - (define vec (make-vector (+ (* 2 len) 2))) ; + 2 for booleans at the beginning - (vector-set! vec 0 bool1) - (vector-set! vec 1 bool2) - (for ([(k v) (in-dict alist)] - [i (in-naturals)]) - (vector-set! vec (+ 2 i) k) - (vector-set! vec (+ 2 i len) v)) - vec] - [(struct top-level-rename (flag)) - flag] - [(struct mark-barrier (value)) - value] - [(struct prune (syms)) - (box syms)] - [(struct wrap-mark (val)) - (list val)]))) - -(define (encode-wrapped w) - (match w - [(struct wrapped (datum wraps certs)) - (vector - (cons - datum - (encode-wraps wraps)) - certs)])) (define (lookup-encoded-wrapped w out) - (hash-ref (out-encoded-wraps out) w)) + (hash-ref! (out-encoded-wraps out) w + (λ () + (encode-wrapped w)))) -(define (out-wrapped w out) - (out-data (lookup-encoded-wrapped w out) out)) - -(define (out-stx s out) - (out-shared s out - (lambda () - (match s - [(struct stx (encoded)) - (out-byte CPT_STX out) - (out-wrapped encoded out)])))) - -(define (out-form form out) - (match form - [(? mod?) - (out-module form out)] - [(struct def-values (ids rhs)) - (out-syntax DEFINE_VALUES_EXPD - (list->vector (cons rhs ids)) - out)] - [(struct def-syntaxes (ids rhs prefix max-let-depth)) - (out-syntax DEFINE_SYNTAX_EXPD - (list->vector (list* rhs - prefix - max-let-depth - *dummy* - ids)) - out)] - [(struct def-for-syntax (ids rhs prefix max-let-depth)) - (out-syntax DEFINE_FOR_SYNTAX_EXPD - (list->vector (list* rhs - prefix - max-let-depth - *dummy* - ids)) - out)] - [(struct seq0 (forms)) - (out-marshaled begin0-sequence-type-num (map protect-quote forms) out)] - [(struct seq (forms)) - (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)])) - -(define (out-expr expr out) - (match expr - [(struct toplevel (depth pos const? ready?)) - (out-marshaled toplevel-type-num - (cons - depth - (if (or const? ready?) - (cons pos - (bitwise-ior - (if const? #x1 0) - (if ready? #x2 0))) - pos)) - out)] - [(struct topsyntax (depth pos midpt)) - (out-marshaled quote-syntax-type-num - (cons depth - (cons pos midpt)) - out)] - [(struct primval (id)) - (out-byte CPT_REFERENCE out) - (out-number id out)] - [(struct assign (id rhs undef-ok?)) - (out-syntax SET_EXPD - (cons undef-ok? (cons id rhs)) - out)] - [(struct localref (unbox? offset clear? other-clears? flonum?)) - (if (and (not clear?) (not other-clears?) (not flonum?) - (offset . < . (- CPT_SMALL_LOCAL_END CPT_SMALL_LOCAL_START))) - (out-byte (+ (if unbox? - CPT_SMALL_LOCAL_UNBOX_START - CPT_SMALL_LOCAL_START) - offset) - out) - (begin - (out-byte (if unbox? CPT_LOCAL_UNBOX CPT_LOCAL) out) - (if (not (or clear? other-clears? flonum?)) - (out-number offset out) - (begin - (out-number (- (add1 offset)) out) - (out-number (if clear? - #x1 - (if other-clears? - #x2 - (if flonum? - #x3 - 0))) - out)))))] - [(? lam?) - (out-lam expr out)] - [(struct case-lam (name lams)) - (let ([seq (make-case-seq name lams)]) - ;; If all closures are empy, generate a case sequence directly - (if (andmap (lambda (lam) - (or (closure? lam) - (and (lam? lam) - (equal? (lam-closure-map lam) #())))) - lams) - (out-data seq out) - (out-syntax CASE_LAMBDA_EXPD - seq - out)))] - [(struct case-seq (name lams)) - (out-marshaled case-lambda-sequence-type-num - (cons (or name null) - lams) - out)] - [(struct let-one (rhs body flonum? unused?)) - (out-byte (cond - [flonum? CPT_LET_ONE_FLONUM] - [unused? CPT_LET_ONE_UNUSED] - [else CPT_LET_ONE]) - out) - (out-expr (protect-quote rhs) out) - (out-expr (protect-quote body) out)] - [(struct let-void (count boxes? body)) - (out-marshaled let-void-type-num - (list* - count - boxes? - (protect-quote body)) - out)] - [(struct let-rec (procs body)) - (out-marshaled letrec-type-num - (list* - (length procs) - (protect-quote body) - procs) - out)] - [(struct install-value (count pos boxes? rhs body)) - (out-marshaled let-value-type-num - (list* - count - pos - boxes? - (protect-quote rhs) - (protect-quote body)) - out)] - [(struct boxenv (pos body)) - (out-syntax BOXENV_EXPD - (cons - pos - (protect-quote body)) - out)] - [(struct branch (test then else)) - (out-byte CPT_BRANCH out) - (out-expr (protect-quote test) out) - (out-expr (protect-quote then) out) - (out-expr (protect-quote else) out)] - [(struct application (rator rands)) - (let ([len (length rands)]) - (if (len . < . (- CPT_SMALL_APPLICATION_END CPT_SMALL_APPLICATION_START)) - (out-byte (+ CPT_SMALL_APPLICATION_START (length rands)) out) - (begin - (out-byte CPT_APPLICATION out) - (out-number len out))) - (for-each (lambda (e) (out-expr (protect-quote e) out)) - (cons rator rands)))] - [(struct apply-values (proc args-expr)) - (out-syntax APPVALS_EXPD - (cons (protect-quote proc) - (protect-quote args-expr)) - out)] - [(struct seq (exprs)) - (out-form expr out)] - [(struct beg0 (exprs)) - (out-syntax BEGIN0_EXPD - (make-seq0 exprs) - out)] - [(struct with-cont-mark (key val body)) - (out-marshaled wcm-type-num - (list* - (protect-quote key) - (protect-quote val) - (protect-quote body)) - out)] - [(struct closure (lam gen-id)) - (out-lam expr out)] - [(struct indirect (val)) - (out-expr val out)] - [(struct varref (expr)) - (out-syntax REF_EXPD - expr - out)] - [else (out-value expr out)])) (define (out-lam expr out) (match expr - [(struct indirect (val)) (out-lam val out)] - [(struct closure (lam gen-id)) - (out-shared - expr - out - (lambda () - (out-byte CPT_CLOSURE out) - (out-number ((out-shared-index out) expr) out) - (out-lam lam out)))] [(struct lam (name flags num-params param-types rest? closure-map closure-types 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))] - [num-all-params ((if rest? add1 values) num-params)] + [num-all-params (if (and rest? (not (memq 'only-rest-arg-not-used flags))) + (add1 num-params) + num-params)] [l (cons (make-svector (if any-refs? (list->vector (append @@ -879,192 +1013,29 @@ out))])) (define (out-as-bytes expr ->bytes CPT len2 out #:before-length [before-length #f]) - (out-shared expr out (lambda () - (let ([s (->bytes expr)]) - (out-byte CPT out) - (when before-length - (out-number before-length out)) - (out-number (bytes-length s) out) - (when len2 (out-number len2 out)) - (out-bytes s out))))) + (define s (->bytes expr)) + (out-byte CPT out) + (when before-length + (out-number before-length out)) + (out-number (bytes-length s) out) + (when len2 (out-number len2 out)) + (out-bytes s out)) -(define (out-data expr out) - (cond - [(prefix? expr) (out-prefix expr out)] - [(global-bucket? expr) (out-toplevel expr out)] - [(module-variable? expr) (out-toplevel expr out)] - [else (out-form expr out)])) - -(define (out-value expr out) - (cond - [(and (symbol? expr) (not (symbol-interned? expr))) - (out-as-bytes expr - #:before-length (if (symbol-unreadable? expr) 0 1) - (compose string->bytes/utf-8 symbol->string) - CPT_WEIRD_SYMBOL - #f - out)] - [(symbol? expr) - (out-shared expr out - (lambda () - (define bs (string->bytes/utf-8 (symbol->string expr))) - (define len (bytes-length bs)) - (if (len . < . (- CPT_SMALL_SYMBOL_END CPT_SMALL_SYMBOL_START)) - (out-byte (+ CPT_SMALL_SYMBOL_START len) out) - (begin (out-byte CPT_SYMBOL out) - (out-number len out))) - (out-bytes bs 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) - (out-number (char->integer expr) out)] - [(and (exact-integer? expr) - (and (expr . >= . -1073741824) (expr . <= . 1073741823))) - (if (and (expr . >= . 0) - (expr . < . (- CPT_SMALL_NUMBER_END CPT_SMALL_NUMBER_START))) - (out-byte (+ CPT_SMALL_NUMBER_START expr) out) - (begin - (out-byte CPT_INT out) - (out-number expr out)))] - [(null? expr) - (out-byte CPT_NULL out)] - [(eq? expr #t) - (out-byte CPT_TRUE out)] - [(eq? expr #f) - (out-byte CPT_FALSE out)] - [(void? expr) - (out-byte CPT_VOID out)] - [(box? expr) - (out-byte CPT_BOX out) - (out-data (unbox expr) out)] - [(pair? expr) - (local [(define seen? (make-hasheq)) ; XXX Maybe this should be global? - (define (list-length-before-cycle/improper-end l) - (if (hash-has-key? seen? l) - (begin (values 0 #f)) - (begin (hash-set! seen? l #t) - (cond - [(null? l) - (values 0 #t)] - [(pair? l) - (let-values ([(len proper?) - (list-length-before-cycle/improper-end (cdr l))]) - (values (add1 len) proper?))] - [else - (values 0 #f)])))) - (define-values (len proper?) (list-length-before-cycle/improper-end expr)) - (define (print-contents-as-proper) - (for ([e (in-list expr)]) - (out-data e out))) - (define (print-contents-as-improper) - (let loop ([l expr] [i len]) - (cond - [(zero? i) - (out-data l out)] - [else - (out-data (car l) out) - (loop (cdr l) (sub1 i))])))] - (if proper? - (if (len . < . (- CPT_SMALL_PROPER_LIST_END CPT_SMALL_PROPER_LIST_START)) - (begin (out-byte (+ CPT_SMALL_PROPER_LIST_START len) out) - (print-contents-as-proper)) - (begin (out-byte CPT_LIST out) - (out-number len out) - (print-contents-as-proper) - (out-data null out))) - (if (len . < . (- CPT_SMALL_LIST_END CPT_SMALL_LIST_START)) - (begin (out-byte (+ CPT_SMALL_LIST_START len) out) - (print-contents-as-improper)) - (begin (out-byte CPT_LIST out) - (out-number len out) - (print-contents-as-improper)))))] - [(vector? expr) - (out-byte CPT_VECTOR out) - (out-number (vector-length expr) out) - (for ([v (in-vector expr)]) - (out-data v out))] - [(hash? expr) - (out-shared expr out - (lambda () - (out-byte CPT_HASH_TABLE out) - (out-number (cond - [(hash-eqv? expr) 2] - [(hash-eq? expr) 0] - [else 1]) - out) - (out-number (hash-count expr) out) - (for ([(k v) (in-hash expr)]) - (out-data k out) - (out-data v out))))] - [(svector? expr) - (let* ([vec (svector-vec expr)] - [len (vector-length vec)]) - (if (len . < . (- CPT_SMALL_SVECTOR_END CPT_SMALL_SVECTOR_START)) - (out-byte (+ CPT_SMALL_SVECTOR_START len) out) - (begin (out-byte CPT_SVECTOR out) - (out-number len out))) - (for ([n (in-range (sub1 len) -1 -1)]) - (out-number (vector-ref vec n) out)))] - [(module-path-index? expr) - (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)] - [(stx? expr) - (out-stx expr out)] - [(wrapped? expr) - (out-wrapped expr out)] - [else - (out-byte CPT_QUOTE out) - (let ([s (open-output-bytes)]) - (write (if (quoted? expr) - (quoted-v expr) - expr) s) - (out-byte CPT_ESCAPE out) - (let ([bstr (get-output-bytes s)]) - (out-number (bytes-length bstr) out) - (out-bytes bstr out)))])) - - -(define-struct quoted (v) #:prefab) +(define-struct quoted (v)) (define (protect-quote v) - v - #;(if (or (list? v) (vector? v) (box? v) (hash? v)) - (make-quoted v) - v)) - + (if (or (pair? v) (vector? v) (and (not (zo? v)) (prefab-struct-key v)) (box? v) (hash? v) (svector? v)) + (make-quoted v) + v)) (define-struct svector (vec)) +(define (make-relative v) + (let ([r (current-write-relative-directory)]) + (if r + (find-relative-path r v) + v))) + + ;; ---------------------------------------- diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 7c1186ed64..a4e11f586b 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -1,9 +1,11 @@ #lang scheme/base -(require mzlib/etc +(require mzlib/etc + racket/function scheme/match scheme/list unstable/struct - compiler/zo-structs) + compiler/zo-structs + racket/dict) (provide zo-parse) (provide (all-from-out compiler/zo-structs)) @@ -26,8 +28,6 @@ I think parse-module-path-index was only used for debugging, so it is short-circuited now - collects/browser/compiled/browser_scrbl.zo (eg) contains a all-from-module that looks like: (# 0 (1363072) . #f) --- that doesn't seem to match the spec - |# ;; ---------------------------------------- ;; Bytecode unmarshalers for various forms @@ -72,6 +72,11 @@ ; XXX Why not leave them as vectors and change the contract? (make-prefix i (vector->list tv) (vector->list sv))]))) +(define read-free-id-info + (match-lambda + [(vector mpi0 symbol0 mpi1 symbol1 num0 num1 num2 bool0) ; I have no idea what these mean + (make-free-id-info mpi0 symbol0 mpi1 symbol1 num0 num1 num2 bool0)])) + (define (read-unclosed-procedure v) (define CLOS_HAS_REST 1) (define CLOS_HAS_REF_ARGS 2) @@ -112,8 +117,11 @@ (append (if (zero? (bitwise-and flags flags CLOS_PRESERVES_MARKS)) null '(preserves-marks)) (if (zero? (bitwise-and flags flags CLOS_IS_METHOD)) null '(is-method)) - (if (zero? (bitwise-and flags flags CLOS_SINGLE_RESULT)) null '(single-result))) - ((if rest? sub1 values) num-params) + (if (zero? (bitwise-and flags flags CLOS_SINGLE_RESULT)) null '(single-result)) + (if (and rest? (zero? num-params)) '(only-rest-arg-not-used) null)) + (if (and rest? (num-params . > . 0)) + (sub1 num-params) + num-params) arg-types rest? (if (= closure-size (vector-length closed-over)) @@ -315,6 +323,7 @@ [(100) 'begin0-sequence-type] [(103) 'module-type] [(105) 'resolve-prefix-type] + [(154) 'free-id-info-type] [else (error 'int->type "unknown type: ~e" i)])) (define type-readers @@ -335,12 +344,13 @@ (cons 'case-lambda-sequence-type read-case-lambda) (cons 'begin0-sequence-type read-sequence) (cons 'module-type read-module) - (cons 'resolve-prefix-type read-resolve-prefix)))) + (cons 'resolve-prefix-type read-resolve-prefix) + (cons 'free-id-info-type read-free-id-info)))) (define (get-reader type) - (or (hash-ref type-readers type #f) - (lambda (v) - (error 'read-marshalled "reader for ~a not implemented" type)))) + (hash-ref type-readers type + (λ () + (error 'read-marshalled "reader for ~a not implemented" type)))) ;; ---------------------------------------- ;; Lowest layer of bytecode parsing @@ -498,145 +508,174 @@ ;; ---------------------------------------- ;; Syntax unmarshaling +(define (make-memo) (make-weak-hash)) +(define (with-memo* mt arg thnk) + (hash-ref! mt arg thnk)) +(define-syntax-rule (with-memo mt arg body ...) + (with-memo* mt arg (λ () body ...))) + +(define (decode-mark-map alist) + alist) + +(define marks-memo (make-memo)) +(define (decode-marks cp ms) + (with-memo marks-memo ms + (match ms + [#f #f] + [(list* #f (? number? symref) alist) + (make-certificate:ref + (symtab-lookup cp symref) + (decode-mark-map alist))] + [(list* (? list? nested) alist) + (make-certificate:nest (decode-mark-map nested) (decode-mark-map alist))] + [alist + (make-certificate:plain (decode-mark-map alist))]))) + +(define stx-memo (make-memo)) +; XXX More memo use (define (decode-stx cp v) - (if (integer? v) - (unmarshal-stx-get/decode cp v decode-stx) - (let loop ([v v]) - (let-values ([(cert-marks v encoded-wraps) - (match v - [`#((,datum . ,wraps) ,cert-marks) (values cert-marks datum wraps)] - [`(,datum . ,wraps) (values #f datum wraps)] - [else (error 'decode-wraps "bad datum+wrap: ~e" v)])]) - (let* ([wraps (decode-wraps cp encoded-wraps)] - [add-wrap (lambda (v) (make-wrapped v wraps cert-marks))]) - (cond - [(pair? v) - (if (eq? #t (car v)) - ;; Share decoded wraps with all nested parts. - (let loop ([v (cdr v)]) - (cond - [(pair? v) - (let ploop ([v v]) + (with-memo stx-memo v + (if (integer? v) + (unmarshal-stx-get/decode cp v decode-stx) + (let loop ([v v]) + (let-values ([(cert-marks v encoded-wraps) + (match v + [`#((,datum . ,wraps) ,cert-marks) (values cert-marks datum wraps)] + [`(,datum . ,wraps) (values #f datum wraps)] + [else (error 'decode-wraps "bad datum+wrap: ~.s" v)])]) + (let* ([wraps (decode-wraps cp encoded-wraps)] + [marks (decode-marks cp cert-marks)] + [wrapped-memo (make-memo)] + [add-wrap (lambda (v) (with-memo wrapped-memo v (make-wrapped v wraps marks)))]) + (cond + [(pair? v) + (if (eq? #t (car v)) + ;; Share decoded wraps with all nested parts. + (let loop ([v (cdr v)]) + (cond + [(pair? v) + (let ploop ([v v]) + (cond + [(null? v) null] + [(pair? v) (add-wrap (cons (loop (car v)) (ploop (cdr v))))] + [else (loop v)]))] + [(box? v) (add-wrap (box (loop (unbox v))))] + [(vector? v) + (add-wrap (list->vector (map loop (vector->list v))))] + [(prefab-struct-key v) + => (lambda (k) + (add-wrap + (apply + make-prefab-struct + k + (map loop (struct->list v)))))] + [else (add-wrap v)])) + ;; Decode sub-elements that have their own wraps: + (let-values ([(v counter) (if (exact-integer? (car v)) + (values (cdr v) (car v)) + (values v -1))]) + (add-wrap + (let ploop ([v v][counter counter]) (cond [(null? v) null] - [(pair? v) (add-wrap (cons (loop (car v)) (ploop (cdr v))))] - [else (loop v)]))] - [(box? v) (add-wrap (box (loop (unbox v))))] - [(vector? v) - (add-wrap (list->vector (map loop (vector->list v))))] - [(prefab-struct-key v) - => (lambda (k) - (add-wrap - (apply - make-prefab-struct - k - (map loop (struct->list v)))))] - [else (add-wrap v)])) - ;; Decode sub-elements that have their own wraps: - (let-values ([(v counter) (if (exact-integer? (car v)) - (values (cdr v) (car v)) - (values v -1))]) - (add-wrap - (let ploop ([v v][counter counter]) - (cond - [(null? v) null] - [(or (not (pair? v)) (zero? counter)) (loop v)] - [(pair? v) (cons (loop (car v)) - (ploop (cdr v) (sub1 counter)))])))))] - [(box? v) (add-wrap (box (loop (unbox v))))] - [(vector? v) - (add-wrap (list->vector (map loop (vector->list v))))] - [(prefab-struct-key v) - => (lambda (k) - (add-wrap - (apply - make-prefab-struct - k - (map loop (struct->list v)))))] - [else (add-wrap v)])))))) + [(or (not (pair? v)) (zero? counter)) (loop v)] + [(pair? v) (cons (loop (car v)) + (ploop (cdr v) (sub1 counter)))])))))] + [(box? v) (add-wrap (box (loop (unbox v))))] + [(vector? v) + (add-wrap (list->vector (map loop (vector->list v))))] + [(prefab-struct-key v) + => (lambda (k) + (add-wrap + (apply + make-prefab-struct + k + (map loop (struct->list v)))))] + [else (add-wrap v)]))))))) +(define wrape-memo (make-memo)) +(define (decode-wrape cp a) + (define (aloop a) (decode-wrape cp a)) + (with-memo wrape-memo a + ; A wrap-elem is either + (cond + ; A reference + [(integer? a) + (unmarshal-stx-get/decode cp a (lambda (cp v) (aloop v)))] + ; A mark (not actually a number as the C says, but a (list ) + [(and (pair? a) (number? (car a))) + (make-wrap-mark (car a))] + + [(vector? a) + (make-lexical-rename (vector-ref a 0) (vector-ref a 1) + (let ([top (+ (/ (- (vector-length a) 2) 2) 2)]) + (let loop ([i 2]) + (if (= i top) + null + (cons (cons (vector-ref a i) + (vector-ref a (+ (- top 2) i))) + (loop (+ i 1)))))))] + [(pair? a) + (let-values ([(plus-kern? a) (if (eq? (car a) #t) + (values #t (cdr a)) + (values #f a))]) + (match a + [`(,phase ,kind ,set-id ,maybe-unmarshals . ,renames) + (let-values ([(unmarshals renames mark-renames) + (if (vector? maybe-unmarshals) + (values null maybe-unmarshals renames) + (values maybe-unmarshals + (car renames) + (cdr renames)))]) + (make-module-rename phase + (if kind 'marked 'normal) + set-id + (map (curry decode-all-from-module cp) unmarshals) + (decode-renames renames) + mark-renames + (and plus-kern? 'plus-kern)))] + [else (error "bad module rename: ~e" a)]))] + [(boolean? a) + (make-top-level-rename a)] + [(symbol? a) + (make-mark-barrier a)] + [(box? a) + (match (unbox a) + [(list (? symbol?) ...) (make-prune (unbox a))] + [`#(,amt ,src ,dest #f) + (make-phase-shift amt + (parse-module-path-index cp src) + (parse-module-path-index cp dest))] + [else (error 'parse "bad phase shift: ~e" a)])] + [else (error 'decode-wraps "bad wrap element: ~e" a)]))) + +(define all-from-module-memo (make-memo)) +(define (decode-all-from-module cp afm) + (define (phase? v) + (or (number? v) (not v))) + (with-memo all-from-module-memo afm + (match afm + [(list* path (? phase? phase) (? phase? src-phase) + (list exn ...) prefix) + (make-all-from-module + (parse-module-path-index cp path) + phase src-phase exn (vector prefix))] + [(list* path (? phase? phase) (list exn ...) (? phase? src-phase)) + (make-all-from-module + (parse-module-path-index cp path) + phase src-phase exn #f)] + [(list* path (? phase? phase) (? phase? src-phase)) + (make-all-from-module + (parse-module-path-index cp path) + phase src-phase #f #f)]))) + +(define wraps-memo (make-memo)) (define (decode-wraps cp w) - ; A wraps is either a indirect reference or a list of wrap-elems (from stxobj.c:252) - (if (integer? w) - (unmarshal-stx-get/decode cp w decode-wraps) - (map (lambda (a) - (let aloop ([a a]) - ; A wrap-elem is either - (cond - ; A reference - [(integer? a) - (unmarshal-stx-get/decode cp a (lambda (cp v) (aloop v)))] - ; A mark (not actually a number as the C says, but a (list ) - [(and (pair? a) (null? (cdr a)) (number? (car a))) - (make-wrap-mark (car a))] - - [(vector? a) - (make-lexical-rename (vector-ref a 0) (vector-ref a 1) - (let ([top (+ (/ (- (vector-length a) 2) 2) 2)]) - (let loop ([i 2]) - (if (= i top) - null - (cons (cons (vector-ref a i) - (vector-ref a (+ (- top 2) i))) - (loop (+ i 1)))))))] - [(pair? a) - (let-values ([(plus-kern? a) (if (eq? (car a) #t) - (values #t (cdr a)) - (values #f a))]) - (match a - [`(,phase ,kind ,set-id ,maybe-unmarshals . ,renames) - (let-values ([(unmarshals renames mark-renames) - (if (vector? maybe-unmarshals) - (values null maybe-unmarshals renames) - (values maybe-unmarshals - (car renames) - (cdr renames)))]) - (make-module-rename phase - (if kind 'marked 'normal) - set-id - (let ([results (map (lambda (u) - ; u = (list path phase . src-phase) - ; or u = (list path phase src-phase exn ... . prefix) - (let ([just-phase? (let ([v (cddr u)]) - (or (number? v) (not v)))]) - (let-values ([(exns prefix) - (if just-phase? - (values null #f) - (let loop ([u (if just-phase? null (cdddr u))] - [a null]) - (if (pair? u) - (loop (cdr u) (cons (car u) a)) - (values (reverse a) u))))]) - (make-all-from-module - (parse-module-path-index cp (car u)) - (cadr u) - (if just-phase? - (cddr u) - (caddr u)) - exns - prefix)))) - unmarshals)]) - #;(printf "~nunmarshals: ~S~n" unmarshals) - #;(printf "~nunmarshal results: ~S~n" results) - results) - (decode-renames renames) - mark-renames - (and plus-kern? 'plus-kern)))] - [else (error "bad module rename: ~e" a)]))] - [(boolean? a) - (make-top-level-rename a)] - [(symbol? a) - (make-mark-barrier a)] - [(box? a) - (match (unbox a) - [(list (? symbol?) ...) (make-prune (unbox a))] - [`#(,amt ,src ,dest #f) - (make-phase-shift amt - (parse-module-path-index cp src) - (parse-module-path-index cp dest))] - [else (error 'parse "bad phase shift: ~e" a)])] - [else (error 'decode-wraps "bad wrap element: ~e" a)]))) - w))) + (with-memo wraps-memo w + ; A wraps is either a indirect reference or a list of wrap-elems (from stxobj.c:252) + (if (integer? w) + (unmarshal-stx-get/decode cp w decode-wraps) + (map (curry decode-wrape cp) w)))) (define (in-vector* v n) (make-do-sequence @@ -648,43 +687,52 @@ (λ _ #t) (λ _ #t))))) -(define (decode-renames renames) - (define decode-nominal-path - (match-lambda +(define nominal-path-memo (make-memo)) +(define (decode-nominal-path np) + (with-memo nominal-path-memo np + (match np [(cons nominal-path (cons import-phase nominal-phase)) (make-phased-nominal-path nominal-path import-phase nominal-phase)] [(cons nominal-path import-phase) (make-imported-nominal-path nominal-path import-phase)] [nominal-path - (make-simple-nominal-path nominal-path)])) - - ; XXX Weird test copied from C code. Matthew? - (define (nom_mod_p p) - (and (pair? p) (not (pair? (cdr p))) (not (symbol? (cdr p))))) - - (for/list ([(k v) (in-vector* renames 2)]) - (cons k - (match v - [(list-rest path phase export-name nominal-path nominal-export-name) - (make-phased-module-binding path - phase - export-name - (decode-nominal-path nominal-path) - nominal-export-name)] - [(list-rest path export-name nominal-path nominal-export-name) - (make-exported-nominal-module-binding path - export-name - (decode-nominal-path nominal-path) - nominal-export-name)] - [(cons module-path-index (? nom_mod_p nominal-path)) - (make-nominal-module-binding module-path-index (decode-nominal-path nominal-path))] - [(cons module-path-index export-name) - (make-exported-module-binding module-path-index export-name)] - [module-path-index - (make-simple-module-binding module-path-index)])))) + (make-simple-nominal-path nominal-path)]))) + +; XXX Weird test copied from C code. Matthew? +(define (nom_mod_p p) + (and (pair? p) (not (pair? (cdr p))) (not (symbol? (cdr p))))) + +(define rename-v-memo (make-memo)) +(define (decode-rename-v v) + (with-memo rename-v-memo v + (match v + [(list-rest path phase export-name nominal-path nominal-export-name) + (make-phased-module-binding path + phase + export-name + (decode-nominal-path nominal-path) + nominal-export-name)] + [(list-rest path export-name nominal-path nominal-export-name) + (make-exported-nominal-module-binding path + export-name + (decode-nominal-path nominal-path) + nominal-export-name)] + [(cons module-path-index (? nom_mod_p nominal-path)) + (make-nominal-module-binding module-path-index (decode-nominal-path nominal-path))] + [(cons module-path-index export-name) + (make-exported-module-binding module-path-index export-name)] + [module-path-index + (make-simple-module-binding module-path-index)]))) + +(define renames-memo (make-memo)) +(define (decode-renames renames) + (with-memo renames-memo renames + (for/list ([(k v) (in-vector* renames 2)]) + (cons k (decode-rename-v v))))) (define (parse-module-path-index cp s) s) + ;; ---------------------------------------- ;; Main parsing loop @@ -692,10 +740,11 @@ (let loop ([need-car 0] [proper #f]) (begin-with-definitions (define ch (cp-getc cp)) - (define-values (cpt-start cpt-tag) (let ([x (cpt-table-lookup ch)]) - (unless x - (error 'read-compact "unknown code : ~a" ch)) - (values (car x) (cdr x)))) + (define-values (cpt-start cpt-tag) + (let ([x (cpt-table-lookup ch)]) + (unless x + (error 'read-compact "unknown code : ~a" ch)) + (values (car x) (cdr x)))) (define v (case cpt-tag [(delayed) @@ -715,7 +764,22 @@ [read-decimal-as-inexact #t] [read-accept-dot #t] [read-accept-infix-dot #t] - [read-accept-quasiquote #t]) + [read-accept-quasiquote #t] + [current-readtable + (make-readtable + #f + #\^ + 'dispatch-macro + (lambda (char port src line col pos) + (let ([b (read port)]) + (unless (bytes? b) + (error 'read-escaped-path + "expected a byte string after #^")) + (let ([p (bytes->path b)]) + (if (and (relative-path? p) + (current-load-relative-directory)) + (build-path (current-load-relative-directory) p) + p)))))]) (read/recursive (open-input-bytes s))))] [(reference) (make-primval (read-compact-number cp))] @@ -777,6 +841,10 @@ [lst (for/list ([i (in-range n)]) (read-compact cp))]) (vector->immutable-vector (list->vector lst)))] + [(pair) + (let* ([a (read-compact cp)] + [d (read-compact cp)]) + (cons a d))] [(list) (let ([len (read-compact-number cp)]) (let loop ([i len]) @@ -877,18 +945,16 @@ (for/list ([i (in-range c)]) (read-compact cp))))] [(closure) - (let* ([l (read-compact-number cp)] - [ind (make-indirect #f)]) - (placeholder-set! (vector-ref (cport-symtab cp) l) ind) - (let* ([v (read-compact cp)] - [cl (make-closure v (gensym - (let ([s (lam-name v)]) - (cond - [(symbol? s) s] - [(vector? s) (vector-ref s 0)] - [else 'closure]))))]) - (set-indirect-v! ind cl) - ind))] + (read-compact-number cp) ; symbol table pos. our marshaler will generate this + (let ([v (read-compact cp)]) + (make-closure + v + (gensym + (let ([s (lam-name v)]) + (cond + [(symbol? s) s] + [(vector? s) (vector-ref s 0)] + [else 'closure])))))] [(svector) (read-compact-svector cp (read-compact-number cp))] [(small-svector) @@ -907,15 +973,20 @@ (if decoded? v2 (let ([dv2 (decode-stx cp v2)]) - (placeholder-set! (vector-ref (cport-symtab cp) pos) dv2) + (symtab-write! cp pos dv2) (vector-set! (cport-decoded cp) pos #t) dv2))) +(define (symtab-write! cp i v) + (placeholder-set! (vector-ref (cport-symtab cp) i) v)) + +(define (symtab-lookup cp i) + (vector-ref (cport-symtab cp) i)) + (require unstable/markparam) (define read-sym-mark (mark-parameter)) (define (read-sym cp i) - (define symtab (cport-symtab cp)) - (define ph (vector-ref symtab i)) + (define ph (symtab-lookup cp i)) ; We are reading this already, so return the placeholder (if (memq i (mark-parameter-all read-sym-mark)) ph @@ -933,7 +1004,7 @@ ;; path -> bytes ;; implementes read.c:read_compiled -(define (zo-parse port) +(define (zo-parse [port (current-input-port)]) (begin-with-definitions ;; skip the "#~" (unless (equal? #"#~" (read-bytes 2 port)) @@ -971,8 +1042,12 @@ (define cp (make-cport 0 shared-size port size* rst-start symtab so* (make-vector symtabsize #f) (make-hash) (make-hash))) - (for/list ([i (in-range 1 symtabsize)]) + (for ([i (in-range 1 symtabsize)]) (read-sym cp i)) + + #;(printf "Parsed table:\n") + #;(for ([(i v) (in-dict (cport-symtab cp))]) + (printf "~a = ~a\n" i (placeholder-get v)) ) (set-cport-pos! cp shared-size) (make-reader-graph (read-marshalled 'compilation-top-type cp)))) diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index daba19df57..d3933aa349 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -27,12 +27,15 @@ (provide/contract [struct id ([field-id field-contract] ...)]))) +(define-struct zo () #:prefab) +(provide zo?) + (define-syntax define-form-struct (syntax-rules () [(_ (id sup) . rest) (define-form-struct* id (id sup) . rest)] [(_ id . rest) - (define-form-struct* id id . rest)])) + (define-form-struct* id (id zo) . rest)])) ;; In toplevels of resove prefix: (define-form-struct global-bucket ([name symbol?])) ; top-level binding @@ -42,10 +45,32 @@ [phase (or/c 0 1)])) ; direct access to exported id ;; Syntax object +(define ((alist/c k? v?) l) + (let loop ([l l]) + (match l + [(list) #t] + [(list* (? k?) (? v?) l) + (loop l)] + [_ #f]))) + +(define mark-map? + (alist/c number? module-path-index?) + #;(hash/c number? module-path-index?)) +(define-form-struct certificate ()) +(define-form-struct (certificate:nest certificate) + ([nested mark-map?] + [map mark-map?])) +(define-form-struct (certificate:ref certificate) + ([val any/c] + [map mark-map?])) +(define-form-struct (certificate:plain certificate) + ([map mark-map?])) + + (define-form-struct wrap ()) (define-form-struct wrapped ([datum any/c] [wraps (listof wrap?)] - [certs (or/c list? #f)])) + [certs (or/c certificate? #f)])) ;; In stxs of prefix: (define-form-struct stx ([encoded wrapped?])) @@ -57,10 +82,7 @@ (define-form-struct form ()) (define-form-struct (expr form) ()) -;; A static closure can refer directly to itself, creating a cycle -(define-struct indirect ([v #:mutable]) #:prefab) - -(define-form-struct compilation-top ([max-let-depth exact-nonnegative-integer?] [prefix prefix?] [code (or/c form? indirect? any/c)])) ; compiled code always wrapped with this +(define-form-struct compilation-top ([max-let-depth exact-nonnegative-integer?] [prefix prefix?] [code (or/c form? any/c)])) ; compiled code always wrapped with this ;; A provided identifier (define-form-struct provided ([name symbol?] @@ -76,17 +98,17 @@ [const? boolean?] [ready? boolean?])) ; access binding via prefix array (which is on stack) -(define-form-struct (seq form) ([forms (listof (or/c form? indirect? any/c))])) ; `begin' +(define-form-struct (seq form) ([forms (listof (or/c form? any/c))])) ; `begin' ;; Definitions (top level or within module): (define-form-struct (def-values form) ([ids (listof (or/c toplevel? symbol?))] ; added symbol? - [rhs (or/c expr? seq? indirect? any/c)])) + [rhs (or/c expr? seq? any/c)])) (define-form-struct (def-syntaxes form) ([ids (listof (or/c toplevel? symbol?))] ; added symbol? - [rhs (or/c expr? seq? indirect? any/c)] + [rhs (or/c expr? seq? any/c)] [prefix prefix?] [max-let-depth exact-nonnegative-integer?])) (define-form-struct (def-for-syntax form) ([ids (listof (or/c toplevel? symbol?))] ; added symbol? - [rhs (or/c expr? seq? indirect? any/c)] + [rhs (or/c expr? seq? any/c)] [prefix prefix?] [max-let-depth exact-nonnegative-integer?])) @@ -99,7 +121,7 @@ (listof provided?)))] [requires (listof (cons/c (or/c exact-integer? #f) (listof module-path-index?)))] - [body (listof (or/c form? indirect? any/c))] + [body (listof (or/c form? any/c))] [syntax-body (listof (or/c def-syntaxes? def-for-syntax?))] [unexported (list/c (listof symbol?) (listof symbol?) (listof symbol?))] @@ -109,50 +131,68 @@ [internal-context (or/c #f #t stx?)])) (define-form-struct (lam expr) ([name (or/c symbol? vector? empty?)] - [flags (listof (or/c 'preserves-marks 'is-method 'single-result))] - [num-params integer?] ; should be exact-nonnegative-integer? + [flags (listof (or/c 'preserves-marks 'is-method 'single-result 'only-rest-arg-not-used))] + [num-params exact-nonnegative-integer?] [param-types (listof (or/c 'val 'ref 'flonum))] [rest? boolean?] [closure-map (vectorof exact-nonnegative-integer?)] [closure-types (listof (or/c 'val/ref 'flonum))] [max-let-depth exact-nonnegative-integer?] - [body (or/c expr? seq? indirect? any/c)])) ; `lambda' + [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) -(define-form-struct (case-lam expr) ([name (or/c symbol? vector? empty?)] [clauses (listof (or/c lam? indirect?))])) ; each clause is a lam (added indirect) +(define-form-struct (case-lam expr) ([name (or/c symbol? vector? empty?)] [clauses (listof (or/c lam? closure?))])) -(define-form-struct (let-one expr) ([rhs (or/c expr? seq? indirect? any/c)] [body (or/c expr? seq? indirect? any/c)] [flonum? boolean?] [unused? boolean?])) ; pushes one value onto stack -(define-form-struct (let-void expr) ([count exact-nonnegative-integer?] [boxes? boolean?] [body (or/c expr? seq? indirect? any/c)])) ; create new stack slots +(define-form-struct (let-one expr) ([rhs (or/c expr? seq? any/c)] [body (or/c expr? seq? any/c)] [flonum? boolean?] [unused? boolean?])) ; pushes one value onto stack +(define-form-struct (let-void expr) ([count exact-nonnegative-integer?] [boxes? boolean?] [body (or/c expr? seq? any/c)])) ; create new stack slots (define-form-struct (install-value expr) ([count exact-nonnegative-integer?] [pos exact-nonnegative-integer?] [boxes? boolean?] - [rhs (or/c expr? seq? indirect? any/c)] - [body (or/c expr? seq? indirect? any/c)])) ; set existing stack slot(s) -(define-form-struct (let-rec expr) ([procs (listof lam?)] [body (or/c expr? seq? indirect? any/c)])) ; put `letrec'-bound closures into existing stack slots -(define-form-struct (boxenv expr) ([pos exact-nonnegative-integer?] [body (or/c expr? seq? indirect? any/c)])) ; box existing stack element + [rhs (or/c expr? seq? any/c)] + [body (or/c expr? seq? any/c)])) ; set existing stack slot(s) +(define-form-struct (let-rec expr) ([procs (listof lam?)] [body (or/c expr? seq? any/c)])) ; put `letrec'-bound closures into existing stack slots +(define-form-struct (boxenv expr) ([pos exact-nonnegative-integer?] [body (or/c expr? seq? any/c)])) ; box existing stack element (define-form-struct (localref expr) ([unbox? boolean?] [pos exact-nonnegative-integer?] [clear? boolean?] [other-clears? boolean?] [flonum? boolean?])) ; access local via stack (define-form-struct (topsyntax expr) ([depth exact-nonnegative-integer?] [pos exact-nonnegative-integer?] [midpt exact-nonnegative-integer?])) ; access syntax object via prefix array (which is on stack) -(define-form-struct (application expr) ([rator (or/c expr? seq? indirect? any/c)] [rands (listof (or/c expr? seq? indirect? any/c))])) ; function call -(define-form-struct (branch expr) ([test (or/c expr? seq? indirect? any/c)] [then (or/c expr? seq? indirect? any/c)] [else (or/c expr? seq? indirect? any/c)])) ; `if' -(define-form-struct (with-cont-mark expr) ([key (or/c expr? seq? indirect? any/c)] - [val (or/c expr? seq? indirect? any/c)] - [body (or/c expr? seq? indirect? any/c)])) ; `with-continuation-mark' -(define-form-struct (beg0 expr) ([seq (listof (or/c expr? seq? indirect? any/c))])) ; `begin0' -(define-form-struct (splice form) ([forms (listof (or/c form? indirect? any/c))])) ; top-level `begin' +(define-form-struct (application expr) ([rator (or/c expr? seq? any/c)] [rands (listof (or/c expr? seq? any/c))])) ; function call +(define-form-struct (branch expr) ([test (or/c expr? seq? any/c)] [then (or/c expr? seq? any/c)] [else (or/c expr? seq? any/c)])) ; `if' +(define-form-struct (with-cont-mark expr) ([key (or/c expr? seq? any/c)] + [val (or/c expr? seq? any/c)] + [body (or/c expr? seq? any/c)])) ; `with-continuation-mark' +(define-form-struct (beg0 expr) ([seq (listof (or/c expr? seq? any/c))])) ; `begin0' +(define-form-struct (splice form) ([forms (listof (or/c form? any/c))])) ; top-level `begin' (define-form-struct (varref expr) ([toplevel toplevel?])) ; `#%variable-reference' -(define-form-struct (assign expr) ([id toplevel?] [rhs (or/c expr? seq? indirect? any/c)] [undef-ok? boolean?])) ; top-level or module-level set! -(define-form-struct (apply-values expr) ([proc (or/c expr? seq? indirect? any/c)] [args-expr (or/c expr? seq? indirect? any/c)])) ; `(call-with-values (lambda () ,args-expr) ,proc) +(define-form-struct (assign expr) ([id toplevel?] [rhs (or/c expr? seq? any/c)] [undef-ok? boolean?])) ; top-level or module-level set! +(define-form-struct (apply-values expr) ([proc (or/c expr? seq? any/c)] [args-expr (or/c expr? seq? any/c)])) ; `(call-with-values (lambda () ,args-expr) ,proc) (define-form-struct (primval expr) ([id exact-nonnegative-integer?])) ; direct preference to a kernel primitive ;; Top-level `require' (define-form-struct (req form) ([reqs stx?] [dummy toplevel?])) -(define-form-struct (lexical-rename wrap) ([bool1 boolean?] ; this needs a name + +(define-form-struct free-id-info ([path0 module-path-index?] + [symbol0 symbol?] + [path1 module-path-index?] + [symbol1 symbol?] + [phase0 (or/c exact-integer? #f)] + [phase1 (or/c exact-integer? #f)] + [phase2 (or/c exact-integer? #f)] + [use-current-inspector? boolean?])) + +(define-form-struct (lexical-rename wrap) ([has-free-id-renames? boolean?] [bool2 boolean?] ; this needs a name - [alist any/c])) ; should be (listof (cons/c symbol? symbol?)) + [alist (listof + (cons/c symbol? + (or/c + symbol? + (cons/c + symbol? + (or/c + (cons/c symbol? (or/c symbol? #f)) + free-id-info?)))))])) (define-form-struct (phase-shift wrap) ([amt exact-integer?] [src (or/c module-path-index? #f)] [dest (or/c module-path-index? #f)])) (define-form-struct (wrap-mark wrap) ([val exact-integer?])) (define-form-struct (prune wrap) ([sym any/c])) @@ -160,8 +200,8 @@ (define-form-struct all-from-module ([path module-path-index?] [phase (or/c exact-integer? #f)] [src-phase any/c] ; should be (or/c exact-integer? #f) - [exceptions list?] ; should be (listof symbol?) - [prefix any/c])) ; should be (or/c symbol? #f) + [exceptions (or/c (listof (or/c symbol? number?)) #f)] ; should be (listof symbol?) + [prefix (or/c (vector/c (or/c symbol? #f)) #f)])) ; should be (or/c symbol? #f) (define-form-struct nominal-path ()) (define-form-struct (simple-nominal-path nominal-path) ([value module-path-index?])) @@ -201,7 +241,7 @@ ; XXX better name for 'value' (define-form-struct (mark-barrier wrap) ([value symbol?])) -(provide/contract (struct indirect ([v (or/c closure? #f)]))) + diff --git a/collects/meta/drdr2/analyzer/analyzer.rkt b/collects/meta/drdr2/analyzer/analyzer.rkt new file mode 100644 index 0000000000..6f1f7b4de3 --- /dev/null +++ b/collects/meta/drdr2/analyzer/analyzer.rkt @@ -0,0 +1 @@ +#lang racket diff --git a/collects/meta/drdr2/master/master.rkt b/collects/meta/drdr2/master/master.rkt new file mode 100644 index 0000000000..6f1f7b4de3 --- /dev/null +++ b/collects/meta/drdr2/master/master.rkt @@ -0,0 +1 @@ +#lang racket diff --git a/collects/tests/compiler/demodularizer/demod-test.rkt b/collects/tests/compiler/demodularizer/demod-test.rkt new file mode 100644 index 0000000000..dec2f03a96 --- /dev/null +++ b/collects/tests/compiler/demodularizer/demod-test.rkt @@ -0,0 +1,49 @@ +#lang racket +(require tests/eli-tester + racket/runtime-path) + +(define (capture-output command . args) + (define o (open-output-string)) + (define e (open-output-string)) + (parameterize ([current-input-port (open-input-string "")] + [current-output-port o] + [current-error-port e]) + (apply system* command args)) + (values (get-output-string o) (get-output-string e))) + +(define (test-on-program filename) + ; run modular program, capture output + (define-values (modular-output modular-error) + (capture-output (find-executable-path "racket") filename)) + + ; demodularize + (parameterize ([current-input-port (open-input-string "")]) + (system* (find-executable-path "raco") "demod" filename)) + + (define demod-filename + (path->string + (path-add-suffix filename #"_merged.zo"))) + + ; run whole program + (define-values (whole-output whole-error) + (capture-output (find-executable-path "racket") demod-filename)) + + ; compare output + (test + #:failure-prefix (format "~a stdout" filename) + whole-output => modular-output + #:failure-prefix (format "~a stderr" filename) + whole-error => modular-error)) + +(define-runtime-path tests "tests") + +(define (modular-program? filename) + (and (not (regexp-match #rx"merged" filename)) + (regexp-match #rx"rkt$" filename))) + +(test + (for ([i (in-list (directory-list tests))]) + (define ip (build-path tests i)) + (when (modular-program? ip) + (printf "Checking ~a\n" ip) + (test-on-program (path->string ip))))) \ No newline at end of file diff --git a/collects/tests/compiler/demodularizer/tests/kernel-5.rkt b/collects/tests/compiler/demodularizer/tests/kernel-5.rkt new file mode 100644 index 0000000000..2cee709c7f --- /dev/null +++ b/collects/tests/compiler/demodularizer/tests/kernel-5.rkt @@ -0,0 +1,5 @@ +(module kernel-5 '#%kernel + (#%require racket/private/map) + (define-values (id) (λ (x) x)) + (define-values (xs) (list 1 2 3 4 5)) + (map id (map id xs))) \ No newline at end of file diff --git a/collects/tests/compiler/demodularizer/tests/racket-5.rkt b/collects/tests/compiler/demodularizer/tests/racket-5.rkt new file mode 100644 index 0000000000..a48b41da12 --- /dev/null +++ b/collects/tests/compiler/demodularizer/tests/racket-5.rkt @@ -0,0 +1,2 @@ +#lang racket +5 \ No newline at end of file diff --git a/collects/tests/compiler/zo-exs.rkt b/collects/tests/compiler/zo-exs.rkt index b8ab07e067..2abdaab4ff 100644 --- a/collects/tests/compiler/zo-exs.rkt +++ b/collects/tests/compiler/zo-exs.rkt @@ -3,20 +3,105 @@ compiler/zo-marshal tests/eli-tester) +(define (read-compiled-bytes bs) + (parameterize ([read-accept-compiled #t]) + (read (open-input-bytes bs)))) + +(define (run-compiled-bytes bs [delayed? #t]) + (system "touch test.rkt") + (system "touch compiled/test_rkt.zo") + (system (format "racket ~a -t test.rkt" (if delayed? "" "-d")))) + (define (roundtrip ct) (define bs (zo-marshal ct)) - (test bs - (zo-parse (open-input-bytes bs)) => ct)) + (test #:failure-prefix (format "~S" ct) + (test bs + (zo-parse (open-input-bytes bs)) => ct + (read-compiled-bytes bs) + #;(with-output-to-file "compiled/test_rkt.zo" (λ () (write-bytes bs)) #:exists 'replace) + #;(run-compiled-bytes bs #t) + #;(run-compiled-bytes bs #f)))) + +(define mpi (module-path-index-join #f #f)) + (test - (local [(define (hash-test make-hash-placeholder) - (roundtrip - (compilation-top 0 - (prefix 0 empty empty) - (local [(define ht-ph (make-placeholder #f)) - (define ht (make-hash-placeholder (list (cons 'g ht-ph))))] - (placeholder-set! ht-ph ht) - (make-reader-graph ht)))))] - (hash-test make-hash-placeholder) - (hash-test make-hasheq-placeholder) - (hash-test make-hasheqv-placeholder))) + (roundtrip + (compilation-top 0 + (prefix 0 empty empty) + (list 1 (list 2 3) (list 2 3) 4 5))) + + #;(roundtrip + (compilation-top 0 + (prefix 0 empty empty) + (let* ([ph (make-placeholder #f)] + [x (closure + (lam 'name + empty + 0 + empty + #f + #() + empty + 0 + ph) + 'name)]) + (placeholder-set! ph x) + (make-reader-graph x)))) + + ; This should work, but module-path-index-join doesn't create equal? module-path-index's + #;(roundtrip + (compilation-top + 0 + (prefix 0 (list #f) (list)) + (mod + 'simple + 'simple + (module-path-index-join #f #f) + (prefix + 0 + (list (module-variable + (module-path-index-join + "modbeg.rkt" + (module-path-index-join + "pre-base.rkt" + (module-path-index-join + "namespace.rkt" + (module-path-index-join "private/base.rkt" (module-path-index-join 'racket/base #f))))) 'print-values 0 0)) + (list)) + (list) + (list (list 0 (module-path-index-join 'racket/base #f)) (list 1) (list -1) (list #f)) + (list (apply-values + (toplevel 0 0 #f #t) + (application + (primval 231) + (list 1 'a)))) + (list) + (list (list) (list) (list)) + 2 + (toplevel 0 0 #f #f) + #(racket/language-info get-info #f) + #t))) + + (roundtrip + (compilation-top 0 + (prefix 0 empty empty) + (current-directory))) + + (roundtrip + (compilation-top 0 + (prefix 0 empty empty) + (list (current-directory)))) + + (roundtrip + (compilation-top + 0 + (prefix 0 empty empty) + (cons #hash() + #hash()))) + + (roundtrip + (compilation-top + 0 + (prefix 0 empty empty) + #hash()))) \ No newline at end of file diff --git a/collects/tests/compiler/zo-test-util.rkt b/collects/tests/compiler/zo-test-util.rkt new file mode 100644 index 0000000000..cf5c40bd34 --- /dev/null +++ b/collects/tests/compiler/zo-test-util.rkt @@ -0,0 +1,12 @@ +#lang racket + +(struct result (phase) #:prefab) +(struct failure result (serious? msg) #:prefab) +(struct success result () #:prefab) + +(provide/contract + [struct result ([phase symbol?])] + [struct failure ([phase symbol?] + [serious? boolean?] + [msg string?])] + [struct success ([phase symbol?])]) \ No newline at end of file diff --git a/collects/tests/compiler/zo-test-worker.rkt b/collects/tests/compiler/zo-test-worker.rkt new file mode 100644 index 0000000000..8442fb74f6 --- /dev/null +++ b/collects/tests/compiler/zo-test-worker.rkt @@ -0,0 +1,270 @@ +#lang racket/base +(require racket/cmdline + compiler/zo-parse + compiler/zo-marshal + compiler/decompile + racket/port + racket/bool + racket/list + racket/match + "zo-test-util.rkt") + +(define (bytes-gulp f) + (with-input-from-file f + (λ () (port->bytes (current-input-port))))) + +(define (read-compiled-bytes bs) + (define ib (open-input-bytes bs)) + (dynamic-wind void + (lambda () + (parameterize ([read-accept-compiled #t]) + (read ib))) + (lambda () + (close-input-port ib)))) + +(define (zo-parse/bytes bs) + (define ib (open-input-bytes bs)) + (dynamic-wind void + (lambda () + (zo-parse ib)) + (lambda () + (close-input-port ib)))) + +(define (bytes-not-equal?-error b1 b2) + (unless (bytes=? b1 b2) + (error 'bytes-not-equal?-error "Not equal"))) + +(define (replace-file file bytes) + (with-output-to-file file + (λ () (write-bytes bytes)) + #:exists 'truncate)) + +(define (equal?/why-not v1 v2) + (define v1->v2 (make-hasheq)) + (define (interned-symbol=? s1 s2) + (symbol=? (hash-ref! v1->v2 s1 s2) s2)) + (define (yield p m v1 v2) + (error 'equal?/why-not "~a in ~a: ~S ~S" + m (reverse p) v1 v2)) + (define (inner p v1 v2) + (unless (eq? v1 v2) + (match v1 + [(cons car1 cdr1) + (match v2 + [(cons car2 cdr2) + (inner (list* 'car p) car1 car2) + (inner (list* 'cdr p) cdr1 cdr2)] + [_ + (yield p "Not a cons on right" v1 v2)])] + [(? vector?) + (match v2 + [(? vector?) + (define v1l (vector-length v1)) + (define v2l (vector-length v2)) + (if (= v1l v2l) + (for ([i (in-range v1l)]) + (inner (list* `(vector-ref ,i) p) + (vector-ref v1 i) + (vector-ref v2 i))) + (yield p "Vector lengths not equal" v1 v2))] + [_ + (yield p "Not a vector on right" v1 v2)])] + [(? struct?) + (match v2 + [(? struct?) + (define vv1 (struct->vector v1)) + (define vv2 (struct->vector v2)) + (inner (list* `(struct->vector ,(vector-ref vv1 0)) p) + vv1 vv2)] + [_ + (yield p "Not a struct on right" v1 v2)])] + [(? hash?) + (match v2 + [(? hash?) + (let ([p (list* 'in-hash p)]) + (for ([(k1 hv1) (in-hash v1)]) + (define hv2 + (hash-ref v2 k1 + (lambda () + (yield p (format "~S not in hash on right" k1) v1 v2)))) + (inner (list* `(hash-ref ,k1) p) + hv1 hv2)))] + [_ + (yield p "Not a hash on right" v1 v2)])] + [(? module-path-index?) + (match v2 + [(? module-path-index?) + (define-values (mp1 bmpi1) (module-path-index-split v1)) + (define-values (mp2 bmpi2) (module-path-index-split v2)) + (inner (list* 'module-path-index-split_0 p) mp1 mp2) + (inner (list* 'module-path-index-split_1 p) bmpi1 bmpi2)] + [_ + (yield p "Not a module path index on right" v1 v2)])] + [(? string?) + (match v2 + [(? string?) + (unless (string=? v1 v2) + (yield p "Unequal strings" v1 v2))] + [_ + (yield p "Not a string on right" v1 v2)])] + [(? bytes?) + (match v2 + [(? bytes?) + (unless (bytes=? v1 v2) + (yield p "Unequal bytes" v1 v2))] + [_ + (yield p "Not a bytes on right" v1 v2)])] + [(? path?) + (match v2 + [(? path?) + (unless (equal? v1 v2) + (yield p "Unequal paths" v1 v2))] + [_ + (yield p "Not a path on right" v1 v2)])] + [(? number?) + (match v2 + [(? number?) + (unless (equal? v1 v2) + (yield p "Unequal numbers" v1 v2))] + [_ + (yield p "Not a number on right" v1 v2)])] + [(? regexp?) + (match v2 + [(? regexp?) + (unless (string=? (object-name v1) (object-name v2)) + (yield p "Unequal regexp" v1 v2))] + [_ + (yield p "Not a regexp on right" v1 v2)])] + [(? byte-regexp?) + (match v2 + [(? byte-regexp?) + (unless (bytes=? (object-name v1) (object-name v2)) + (yield p "Unequal byte-regexp" v1 v2))] + [_ + (yield p "Not a byte-regexp on right" v1 v2)])] + [(? box?) + (match v2 + [(? box?) + (inner (list* 'unbox) (unbox v1) (unbox v2))] + [_ + (yield p "Not a box on right" v1 v2)])] + [(? symbol?) + (match v2 + [(? symbol?) + (unless (symbol=? v1 v2) + (cond + [(and (symbol-interned? v1) (not (symbol-interned? v1))) + (yield p "Not interned symbol on right" v1 v2)] + [(and (symbol-unreadable? v1) (not (symbol-unreadable? v1))) + (yield p "Not unreadable symbol on right" v1 v2)] + [(and (symbol-uninterned? v1) (not (symbol-uninterned? v1))) + (yield p "Not uninterned symbol on right" v1 v2)] + [(and (symbol-uninterned? v1) (symbol-uninterned? v2)) + (unless (interned-symbol=? v1 v2) + (yield p "Uninterned symbols don't align" v1 v2))] + [else + (yield p "Other symbol-related problem" v1 v2)]))] + [_ + (yield p "Not a symbol on right" v1 v2)])] + [(? empty?) + (yield p "Not empty on right" v1 v2)] + [_ + (yield p "Cannot inspect values deeper" v1 v2)]))) + (inner empty v1 v2)) + +(define (symbol-uninterned? s) + (not (or (symbol-interned? s) (symbol-unreadable? s)))) + +(define (run-with-limit file k thnk) + (define file-custodian (make-custodian)) + (define ch (make-channel)) + (custodian-limit-memory file-custodian k) + (define worker-thread + (parameterize ([current-custodian file-custodian]) + (thread + (lambda () + (define r (thnk)) + (channel-put ch r) + (channel-get ch))))) + (begin0 + (sync + (handle-evt ch + (lambda (v) + (when (exn? v) (raise v)) + v)) + (handle-evt worker-thread + (lambda _ + (record! (failure 'memory #f "Over memory limit"))))) + (custodian-shutdown-all file-custodian))) + +(define-syntax run/stages* + (syntax-rules () + [(_ file) + (record! (success 'everything))] + [(_ file [step1 serious? e] . rst) + (let/ec esc + (let ([step1 (with-handlers ([exn:fail? + (lambda (x) + (record! (failure 'step1 serious? + (exn-message x))) + (if serious? + (esc #f) + #f))]) + (begin0 e + (record! (success 'step1))))]) + (run/stages* file . rst)))])) + +(define-syntax-rule (define-stages (run! file) + [stage serious? e] ...) + (define (run! file) + (run/stages* file [stage serious? e] ...))) + +(define-stages (run! file) + [read-orig + #t + (bytes-gulp file)] + [parse-orig + #t + (zo-parse/bytes read-orig)] + [marshal-parsed + #t + (zo-marshal parse-orig)] + [parse-marshalled + #t + (zo-parse/bytes marshal-parsed)] + #;[compare-parsed-to-parsed-marshalled + #f + (equal?/why-not parse-orig parse-marshalled)] + #;[marshal-marshalled + #t + (zo-marshal parse-marshalled)] + #;[compare-marshalled-to-marshalled-marshalled + #f + (bytes-not-equal?-error marshal-parsed marshal-marshalled)] + #;[replace-with-marshalled + #t + (replace-file file marshal-marshalled)] + #;[decompile-parsed + #t + (decompile parse-orig)] + [c-parse-marshalled + #t + (read-compiled-bytes marshal-parsed)] + #;[compare-orig-to-marshalled + #f + (bytes-not-equal?-error read-orig marshal-parsed)]) + +(define RESULTS empty) +(define (record! v) + (set! RESULTS (list* v RESULTS))) +(define (run-test file) + (run-with-limit + file + (* 1024 1024 512) + (lambda () + (run! file))) + (write (reverse RESULTS))) + +(command-line #:program "zo-test-worker" + #:args (file) + (run-test file)) \ No newline at end of file diff --git a/collects/tests/compiler/zo-test.rkt b/collects/tests/compiler/zo-test.rkt index d280efac02..1b1279eb36 100755 --- a/collects/tests/compiler/zo-test.rkt +++ b/collects/tests/compiler/zo-test.rkt @@ -3,204 +3,15 @@ exec racket -t "$0" -- -s -t 60 -v -R $* |# -#lang scheme -(require compiler/zo-parse - compiler/zo-marshal - compiler/decompile - setup/dirs) - -;; Helpers -(define (bytes->hex-string bs) - (apply string-append - (for/list ([b bs]) - (format "~a~x" - (if (b . <= . 15) "0" "") - b)))) - -(define (show-bytes-side-by-side orig new) - (define max-length - (max (bytes-length orig) (bytes-length new))) - (define BYTES-PER-LINE 38) - (define lines - (ceiling (/ max-length BYTES-PER-LINE))) - (define (subbytes* b s e) - (subbytes b (min s (bytes-length b)) (min e (bytes-length b)))) - (for ([line (in-range lines)]) - (define start (* line BYTES-PER-LINE)) - (define end (* (add1 line) BYTES-PER-LINE)) - (printf "+ ~a\n" (bytes->hex-string (subbytes* orig start end))) - (printf "- ~a\n" (bytes->hex-string (subbytes* new start end))))) - -(define (bytes-gulp f) - (with-input-from-file f - (λ () (port->bytes (current-input-port))))) - -(define (read-compiled-bytes bs) - (define ib (open-input-bytes bs)) - (dynamic-wind void - (lambda () - (parameterize ([read-accept-compiled #t]) - (read ib))) - (lambda () - (close-input-port ib)))) - -(define (zo-parse/bytes bs) - (define ib (open-input-bytes bs)) - (dynamic-wind void - (lambda () - (zo-parse ib)) - (lambda () - (close-input-port ib)))) - -(define (bytes-not-equal?-error b1 b2) - (unless (bytes=? b1 b2) - (error 'bytes-not-equal?-error "Not equal"))) - -(define (replace-file file bytes) - (with-output-to-file file - (λ () (write-bytes bytes)) - #:exists 'truncate)) +#lang racket +(require setup/dirs + racket/runtime-path + racket/future + "zo-test-util.rkt") (define ((make-recorder! ht) file phase) (hash-update! ht phase (curry list* file) empty)) -(define (equal?/why-not v1 v2) - (define v1->v2 (make-hasheq)) - (define (interned-symbol=? s1 s2) - (symbol=? (hash-ref! v1->v2 s1 s2) s2)) - (define (yield p m v1 v2) - (error 'equal?/why-not "~a in ~a: ~S ~S" - m (reverse p) v1 v2)) - (define (inner p v1 v2) - (unless (eq? v1 v2) - (match v1 - [(cons car1 cdr1) - (match v2 - [(cons car2 cdr2) - (inner (list* 'car p) car1 car2) - (inner (list* 'cdr p) cdr1 cdr2)] - [_ - (yield p "Not a cons on right" v1 v2)])] - [(? vector?) - (match v2 - [(? vector?) - (define v1l (vector-length v1)) - (define v2l (vector-length v2)) - (if (= v1l v2l) - (for ([i (in-range v1l)]) - (inner (list* `(vector-ref ,i) p) - (vector-ref v1 i) - (vector-ref v2 i))) - (yield p "Vector lengths not equal" v1 v2))] - [_ - (yield p "Not a vector on right" v1 v2)])] - [(? struct?) - (match v2 - [(? struct?) - (define vv1 (struct->vector v1)) - (define vv2 (struct->vector v2)) - (inner (list* `(struct->vector ,(vector-ref vv1 0)) p) - vv1 vv2)] - [_ - (yield p "Not a struct on right" v1 v2)])] - [(? hash?) - (match v2 - [(? hash?) - (let ([p (list* 'in-hash p)]) - (for ([(k1 hv1) (in-hash v1)]) - (define hv2 - (hash-ref v2 k1 - (lambda () - (yield p (format "~S not in hash on right" k1) v1 v2)))) - (inner (list* `(hash-ref ,k1) p) - hv1 hv2)))] - [_ - (yield p "Not a hash on right" v1 v2)])] - [(? module-path-index?) - (match v2 - [(? module-path-index?) - (define-values (mp1 bmpi1) (module-path-index-split v1)) - (define-values (mp2 bmpi2) (module-path-index-split v2)) - (inner (list* 'module-path-index-split_0 p) mp1 mp2) - (inner (list* 'module-path-index-split_1 p) bmpi1 bmpi2)] - [_ - (yield p "Not a module path index on right" v1 v2)])] - [(? string?) - (match v2 - [(? string?) - (unless (string=? v1 v2) - (yield p "Unequal strings" v1 v2))] - [_ - (yield p "Not a string on right" v1 v2)])] - [(? bytes?) - (match v2 - [(? bytes?) - (unless (bytes=? v1 v2) - (yield p "Unequal bytes" v1 v2))] - [_ - (yield p "Not a bytes on right" v1 v2)])] - [(? path?) - (match v2 - [(? path?) - (unless (equal? v1 v2) - (yield p "Unequal paths" v1 v2))] - [_ - (yield p "Not a path on right" v1 v2)])] - [(? number?) - (match v2 - [(? number?) - (unless (equal? v1 v2) - (yield p "Unequal numbers" v1 v2))] - [_ - (yield p "Not a number on right" v1 v2)])] - [(? regexp?) - (match v2 - [(? regexp?) - (unless (string=? (object-name v1) (object-name v2)) - (yield p "Unequal regexp" v1 v2))] - [_ - (yield p "Not a regexp on right" v1 v2)])] - [(? byte-regexp?) - (match v2 - [(? byte-regexp?) - (unless (bytes=? (object-name v1) (object-name v2)) - (yield p "Unequal byte-regexp" v1 v2))] - [_ - (yield p "Not a byte-regexp on right" v1 v2)])] - [(? box?) - (match v2 - [(? box?) - (inner (list* 'unbox) (unbox v1) (unbox v2))] - [_ - (yield p "Not a box on right" v1 v2)])] - [(? symbol?) - (match v2 - [(? symbol?) - (unless (symbol=? v1 v2) - (cond - [(and (symbol-interned? v1) (not (symbol-interned? v1))) - (yield p "Not interned symbol on right" v1 v2)] - [(and (symbol-unreadable? v1) (not (symbol-unreadable? v1))) - (yield p "Not unreadable symbol on right" v1 v2)] - [(and (symbol-uninterned? v1) (not (symbol-uninterned? v1))) - (yield p "Not uninterned symbol on right" v1 v2)] - [(and (symbol-uninterned? v1) (symbol-uninterned? v2)) - (unless (interned-symbol=? v1 v2) - (yield p "Uninterned symbols don't align" v1 v2))] - [else - (yield p "Other symbol-related problem" v1 v2)]))] - [_ - (yield p "Not a symbol on right" v1 v2)])] - [(? empty?) - (yield p "Not empty on right" v1 v2)] - [_ - (yield p "Cannot inspect values deeper" v1 v2)]))) - (inner empty v1 v2)) - -(define (symbol-uninterned? s) - (not (or (symbol-interned? s) (symbol-unreadable? s)))) - -;; Parameters (define stop-on-first-error (make-parameter #f)) (define verbose-mode (make-parameter #f)) (define care-about-nonserious? (make-parameter #t)) @@ -208,137 +19,23 @@ exec racket -t "$0" -- -s -t 60 -v -R $* (define time-limit (make-parameter +inf.0)) (define randomize (make-parameter #f)) -;; Work (define errors (make-hash)) +(define (record-common-error! exn-msg) + (hash-update! errors (common-message exn-msg) add1 0)) -(define (common-message exn) - (define given-messages (regexp-match #rx".*given" (exn-message exn))) +(define (common-message exn-msg) + (define given-messages (regexp-match #rx".*given" exn-msg)) (if (and given-messages (not (empty? given-messages))) (first given-messages) - (exn-message exn))) - -(define (exn-printer file phase serious? exn) - (hash-update! errors (common-message exn) add1 0) - (unless (and (not (care-about-nonserious?)) (not serious?)) - (when (or (verbose-mode) (stop-on-first-error)) - (fprintf (current-error-port) "~a -- ~a: ~a~n" file phase (exn-message exn))) - (when (stop-on-first-error) - exn))) - -(define (run-with-time-limit t thnk) - (define th (thread thnk)) - (sync th - (handle-evt (alarm-evt (+ (current-inexact-milliseconds) - (* 1000 t))) - (lambda _ - (kill-thread th))))) - -(define (run-with-limit file k thnk) - (define file-custodian (make-custodian)) - (define ch (make-channel)) - (custodian-limit-memory file-custodian k) - (local [(define worker-thread - (parameterize ([current-custodian file-custodian]) - (thread - (lambda () - (define r (thnk)) - (channel-put ch r) - (channel-get ch)))))] - (begin0 - (sync - (handle-evt ch - (lambda (v) - (when (exn? v) (raise v)) - v)) - (handle-evt worker-thread - (lambda _ - (failure! file 'memory)))) - (custodian-shutdown-all file-custodian)))) + exn-msg)) (define success-ht (make-hasheq)) (define success! (make-recorder! success-ht)) (define failure-ht (make-hasheq)) (define failure! (make-recorder! failure-ht)) -(define-syntax run/stages* - (syntax-rules () - [(_ file) (success! file 'everything)] - [(_ file [step1 serious? e] . rst) - (let/ec esc - (let ([step1 (with-handlers ([exn:fail? - (lambda (x) - (failure! file 'step1) - (esc (exn-printer file 'step1 serious? x)))]) - e)]) - (success! file 'step1) - (run/stages* file . rst)))])) - -(define-syntax-rule (define-stages (stages run!) - file - [stage serious? e] ...) - (define-values (stages run!) - (values '(stage ...) - (lambda (file) - (run/stages* file [stage serious? e] ...))))) - (define debugging? (make-parameter #f)) -(define (print-bytes orig new) - (when (debugging?) - (show-bytes-side-by-side orig new)) - #t) - -(define-stages (stages run!) - file - [read-orig - #t - (bytes-gulp file)] - [parse-orig - #t - (zo-parse/bytes read-orig)] - [marshal-parsed - #t - (zo-marshal parse-orig)] - #;[ignored - #f - (printf "orig: ~a, marshalled: ~a~n" - (bytes-length read-orig) - (bytes-length marshal-parsed))] - [parse-marshalled - #t - (zo-parse/bytes marshal-parsed)] - [compare-parsed-to-parsed-marshalled - #f - (equal?/why-not parse-orig parse-marshalled)] - [marshal-marshalled - #t - (zo-marshal parse-marshalled)] - [compare-marshalled-to-marshalled-marshalled - #f - (bytes-not-equal?-error marshal-parsed marshal-marshalled)] - #;[replace-with-marshalled - #t - (replace-file file marshal-marshalled)] - [decompile-parsed - #t - (decompile parse-orig)] - [show-orig-and-marshal-parsed - #f - (print-bytes read-orig marshal-parsed)] - [c-parse-marshalled - #f - (read-compiled-bytes marshal-parsed)] - [compare-orig-to-marshalled - #f - (bytes-not-equal?-error read-orig marshal-parsed)]) - -(define (run-test file) - (run-with-limit - file - (* 1024 1024 128) - (lambda () - (run! file)))) - (define (randomize-list l) (define ll (length l)) (define seen? (make-hasheq)) @@ -364,59 +61,163 @@ exec racket -t "$0" -- -s -t 60 -v -R $* [(regexp-match #rx"\\.zo$" p-str) (! p-str)])) -(define (zo-test paths) - (run-with-time-limit - (time-limit) - (lambda () - (for-each (curry for-zos run-test) paths))) - - (unless (invariant-output) - (for ([kind-name (list* 'memory stages)]) - (define fails (length (hash-ref failure-ht kind-name empty))) - (define succs (length (hash-ref success-ht kind-name empty))) - (define all (+ fails succs)) - (unless (zero? all) - (printf "~S~n" - `(,kind-name - (#f ,fails) - (#t ,succs) - ,all)))) - (printf "~a tests passed~n" (length (hash-ref success-ht 'everything empty))) - - (printf "Common Errors:~n") - - (for ([p (in-list (sort (filter (λ (p) ((car p) . > . 10)) - (hash-map errors (λ (k v) (cons v k)))) - > #:key car))]) - (printf "~a:~n~a~n~n" (car p) (cdr p))))) +(define-runtime-path zo-test-worker-path "zo-test-worker.rkt") +(define racket-path (path->string (find-executable-path "racket"))) -; Run -#;(current-command-line-arguments #("-s" "/home/bjohn3x/development/plt/collects/browser/compiled/browser_scrbl.zo")) -(command-line #:program "zo-test" - #:once-each - [("-D") - "Enable debugging output" - (debugging? #t)] - [("-s" "--stop-on-first-error") - "Stop testing when first error is encountered" - (stop-on-first-error #t)] - [("-S") - "Don't take some errors seriously" - (care-about-nonserious? #f)] - [("-v" "--verbose") - "Display verbose error messages" - (verbose-mode #t)] - [("-I") - "Invariant output" - (invariant-output #t)] - [("-R") - "Randomize" - (randomize #t)] - [("-t") - number - "Limit the run to a given amount of time" - (time-limit (string->number number))] - #:args p - (zo-test (if (empty? p) - (list (find-collects-dir)) - p))) \ No newline at end of file +(define p + (command-line #:program "zo-test" + #:once-each + [("-D") + "Enable debugging output" + (debugging? #t)] + [("-s" "--stop-on-first-error") + "Stop testing when first error is encountered" + (stop-on-first-error #t)] + [("-S") + "Don't take some errors seriously" + (care-about-nonserious? #f)] + [("-v" "--verbose") + "Display verbose error messages" + (verbose-mode #t)] + [("-I") + "Invariant output" + (invariant-output #t)] + [("-R") + "Randomize" + (randomize #t)] + [("-t") + number + "Limit the run to a given amount of time" + (time-limit (string->number number))] + #:args p + (if (empty? p) + (list (find-collects-dir)) + p))) + +(define to-worker-ch (make-channel)) +(define stop-ch (make-channel)) +(define from-worker-ch (make-channel)) + +(define worker-threads + (for/list ([i (in-range (processor-count))]) + (thread + (λ () + (let loop () + (sync + (handle-evt to-worker-ch + (λ (p) + (when (debugging?) + (printf "~a\n" p)) + (define-values + (sp stdout stdin stderr) + (subprocess #f #f #f racket-path (path->string zo-test-worker-path) p)) + (define r + (dynamic-wind + void + (λ () + (read stdout)) + (λ () + (close-input-port stdout) + (close-input-port stderr) + (close-output-port stdin) + (subprocess-kill sp #t)))) + (channel-put from-worker-ch (cons p r)) + (loop))) + (handle-evt stop-ch + (λ (die) + (void))))))))) + +(define (process-result p r) + (match r + [(success phase) + (success! p phase)] + [(failure phase serious? exn-msg) + (record-common-error! exn-msg) + (failure! p phase) + + (unless (and (not (care-about-nonserious?)) (not serious?)) + (when (or (verbose-mode) (stop-on-first-error)) + (fprintf (current-error-port) "~a -- ~a: ~a\n" p phase exn-msg)) + (when (stop-on-first-error) + (stop!)))])) + +(define timing-thread + (thread + (λ () + (sync + (alarm-evt (+ (current-inexact-milliseconds) + (* 1000 (time-limit))))) + (stop!)))) + +(define server-thread + (thread + (λ () + (let loop ([ts worker-threads]) + (if (empty? ts) + (stop!) + (apply + sync + (handle-evt from-worker-ch + (match-lambda + [(cons p rs) + (for-each (curry process-result p) rs) + (loop ts)])) + (for/list ([t (in-list ts)]) + (handle-evt t (λ _ (loop (remq t ts))))))))))) + +(define (spawn-worker p) + (channel-put to-worker-ch p)) + +(define (zo-test paths) + (for-each (curry for-zos spawn-worker) paths) + + (for ([i (in-range (processor-count))]) + (channel-put stop-ch #t))) + +(define root-thread + (thread + (λ () + (zo-test p)))) + +(define final-sema (make-semaphore 0)) +(define (stop!) + (semaphore-post final-sema)) + +(define (hash-keys ht) + (hash-map ht (λ (k v) k))) + +(define final-thread + (thread + (λ () + (semaphore-wait final-sema) + (for-each kill-thread + (list* root-thread server-thread worker-threads)) + (unless (invariant-output) + (newline) + (for ([kind-name + (remove-duplicates + (append + (hash-keys failure-ht) + (hash-keys success-ht)))]) + (define fails (length (hash-ref failure-ht kind-name empty))) + (define succs (length (hash-ref success-ht kind-name empty))) + (define all (+ fails succs)) + (unless (zero? all) + (printf "~S\n" + `(,kind-name + (#f ,fails) + (#t ,succs) + ,all)))) + (newline) + (printf "~a tests passed\n" (length (hash-ref success-ht 'everything empty))) + + (let ([common-errors + (sort (filter (λ (p) ((car p) . > . 10)) + (hash-map errors (λ (k v) (cons v k)))) + > #:key car)]) + (unless (empty? common-errors) + (printf "Common Errors:\n") + (for ([p (in-list common-errors)]) + (printf "~a:\n~a\n\n" (car p) (cdr p))))))))) + +(thread-wait final-thread) diff --git a/collects/tests/racket/embed-me1.rkt b/collects/tests/racket/embed-me1.rkt index 7e2bb11748..65f7030bb1 100644 --- a/collects/tests/racket/embed-me1.rkt +++ b/collects/tests/racket/embed-me1.rkt @@ -1,5 +1,5 @@ (module embed-me1 mzscheme (with-output-to-file "stdout" - (lambda () (printf "This is 1~n")) + (lambda () (printf "This is 1\n")) 'append)) diff --git a/collects/tests/racket/embed-me12-rd.ss b/collects/tests/racket/embed-me12-rd.ss new file mode 100644 index 0000000000..682396a20b --- /dev/null +++ b/collects/tests/racket/embed-me12-rd.ss @@ -0,0 +1,15 @@ +(module embed-me11-rd mzscheme + (provide (rename *read-syntax read-syntax) + (rename *read read)) + + (define (*read port) + `(module embed-me11 mzscheme + (with-output-to-file "stdout" + (lambda () + (printf ,(read port) + ;; Use `getenv' at read time!!! + ,(getenv "ELEVEN"))) + 'append))) + + (define (*read-syntax src port) + (*read port))) diff --git a/collects/tests/racket/embed-me1b.rkt b/collects/tests/racket/embed-me1b.rkt index 5af91026b6..5c2ae8fce6 100644 --- a/collects/tests/racket/embed-me1b.rkt +++ b/collects/tests/racket/embed-me1b.rkt @@ -4,6 +4,6 @@ (for-syntax scheme/base)) (define-runtime-path file '(lib "icons/file.gif")) (with-output-to-file "stdout" - (lambda () (printf "This is 1b~n")) + (lambda () (printf "This is 1b\n")) #:exists 'append) diff --git a/collects/tests/racket/embed-me1c.rkt b/collects/tests/racket/embed-me1c.rkt index 067c8ad230..70c8a943c8 100644 --- a/collects/tests/racket/embed-me1c.rkt +++ b/collects/tests/racket/embed-me1c.rkt @@ -4,6 +4,6 @@ (for-syntax scheme/base)) (define-runtime-path file '(lib "etc.ss")) ; in mzlib (with-output-to-file "stdout" - (lambda () (printf "This is 1c~n")) + (lambda () (printf "This is 1c\n")) #:exists 'append) diff --git a/collects/tests/racket/embed-me1d.rkt b/collects/tests/racket/embed-me1d.rkt index cc6b750193..7bc3cd2149 100644 --- a/collects/tests/racket/embed-me1d.rkt +++ b/collects/tests/racket/embed-me1d.rkt @@ -4,5 +4,5 @@ (for-syntax scheme/base)) (define-runtime-path file '(lib "file.gif" "icons")) (with-output-to-file "stdout" - (lambda () (printf "This is 1d~n")) + (lambda () (printf "This is 1d\n")) #:exists 'append) diff --git a/collects/tests/racket/embed-me1e.rkt b/collects/tests/racket/embed-me1e.rkt index 645df59905..8ad79cff45 100644 --- a/collects/tests/racket/embed-me1e.rkt +++ b/collects/tests/racket/embed-me1e.rkt @@ -4,5 +4,5 @@ (for-syntax scheme/base)) (define-runtime-path file '(lib "html")) (with-output-to-file "stdout" - (lambda () (printf "This is 1e~n")) + (lambda () (printf "This is 1e\n")) #:exists 'append) diff --git a/collects/tests/racket/embed-me2.rkt b/collects/tests/racket/embed-me2.rkt index 53abb21299..0e4d9481dd 100644 --- a/collects/tests/racket/embed-me2.rkt +++ b/collects/tests/racket/embed-me2.rkt @@ -2,8 +2,5 @@ (require "embed-me1.ss" mzlib/etc) (with-output-to-file "stdout" - (lambda () (printf "This is 2: ~a~n" true)) + (lambda () (printf "This is 2: ~a\n" true)) 'append)) - - - diff --git a/collects/tests/racket/embed.rktl b/collects/tests/racket/embed.rktl index 457f2ea6b4..25924e8f06 100644 --- a/collects/tests/racket/embed.rktl +++ b/collects/tests/racket/embed.rktl @@ -37,7 +37,7 @@ (mk-dest-bin #t))) (define (prepare exe src) - (printf "Making ~a with ~a...~n" exe src) + (printf "Making ~a with ~a...\n" exe src) (when (file-exists? exe) (delete-file exe))) @@ -397,23 +397,36 @@ ;; Try including source that needs a reader extension -(define (try-reader-test mred?) +(define (try-reader-test 12? mred? ss-file? ss-reader?) + ;; actual "11" files use ".rkt", actual "12" files use ".ss" (define dest (mk-dest mred?)) - (define filename "embed-me11.rkt") + (define filename (format (if ss-file? + "embed-me~a.ss" + "embed-me~a.rkt") + (if 12? "12" "11"))) (define (flags s) (string-append "-" s)) + (printf "Trying ~s ~s ~s ~s...\n" (if 12? "12" "11") mred? ss-file? ss-reader?) + (create-embedding-executable dest #:modules `((#t (lib ,filename "tests" "racket"))) #:cmdline `(,(flags "l") ,(string-append "tests/racket/" filename)) #:src-filter (lambda (f) (let-values ([(base name dir?) (split-path f)]) - (equal? name (string->path filename)))) + (equal? name (path-replace-suffix (string->path filename) + (if 12? #".ss" #".rkt"))))) #:get-extra-imports (lambda (f code) (let-values ([(base name dir?) (split-path f)]) - (if (equal? name (string->path filename)) - '((lib "embed-me11-rd.rkt" "tests" "racket")) + (if (equal? name (path-replace-suffix (string->path filename) + (if 12? #".ss" #".rkt"))) + `((lib ,(format (if ss-reader? + "embed-me~a-rd.ss" + "embed-me~a-rd.rkt") + (if 12? "12" "11")) + "tests" + "racket")) null))) #:mred? mred?) @@ -422,8 +435,11 @@ (putenv "ELEVEN" "done")) (define (try-reader) - (try-reader-test #f) - (try-reader-test #t)) + (for ([12? (in-list '(#f #t))]) + (try-reader-test 12? #f #f #f) + (try-reader-test 12? #t #f #f) + (try-reader-test 12? #f #t #f) + (try-reader-test 12? #f #f #t))) ;; ----------------------------------------