From 1325701f829f0d04c2550e57ee4e28ee01c55f83 Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Thu, 15 Jul 2010 15:35:54 -0600 Subject: [PATCH 01/60] handling top-level-renames and mark-barriers (cherry picked from commit 8df94dd746b2a3b08e21f1a07730165294dc6821) original commit: 06c829d8c0e482abd1fbb534a9999c1f21aa1ac0 --- collects/compiler/zo-marshal.rkt | 4 ++++ collects/compiler/zo-parse.rkt | 4 ++-- collects/compiler/zo-structs.rkt | 9 ++++++++- 3 files changed, 14 insertions(+), 3 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 0ff5989dfb..8333ef8c23 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -609,6 +609,10 @@ (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)) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 46ad7d584f..7c1186ed64 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -624,9 +624,9 @@ (and plus-kern? 'plus-kern)))] [else (error "bad module rename: ~e" a)]))] [(boolean? a) - `(#%top-level-rename ,a)] + (make-top-level-rename a)] [(symbol? a) - '(#%mark-barrier)] + (make-mark-barrier a)] [(box? a) (match (unbox a) [(list (? symbol?) ...) (make-prune (unbox a))] diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index 7c3e317bd4..daba19df57 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -23,6 +23,7 @@ (define-syntax-rule (define-form-struct* id id+par ([field-id field-contract] ...)) (begin (define-struct id+par (field-id ...) #:prefab) + #;(provide (struct-out id)) (provide/contract [struct id ([field-id field-contract] ...)]))) @@ -147,7 +148,7 @@ (define-form-struct (primval expr) ([id exact-nonnegative-integer?])) ; direct preference to a kernel primitive ;; Top-level `require' -(define-form-struct (req form) ([reqs syntax?] [dummy toplevel?])) +(define-form-struct (req form) ([reqs stx?] [dummy toplevel?])) (define-form-struct (lexical-rename wrap) ([bool1 boolean?] ; this needs a name [bool2 boolean?] ; this needs a name @@ -194,6 +195,12 @@ [mark-renames any/c] [plus-kern? boolean?])) +; XXX better name for 'flag' +(define-form-struct (top-level-rename wrap) ([flag boolean?])) + +; XXX better name for 'value' +(define-form-struct (mark-barrier wrap) ([value symbol?])) + (provide/contract (struct indirect ([v (or/c closure? #f)]))) From 8e53d9458b2c81025ec4e3b1b9e963057d7bf604 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 19 Jul 2010 13:55:23 -0600 Subject: [PATCH 02/60] raco exe: fix missing ss->rkt conversion and remove debugging printf Merge to 5.0.1 (cherry picked from commit f602d11a7f77fb8cd14d11698150a8240a7d4b3f) original commit: 77a0796a6ca17b061cfb9531189276012ca66ff2 --- collects/tests/racket/embed.rktl | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/collects/tests/racket/embed.rktl b/collects/tests/racket/embed.rktl index 25036d3566..16a4e71a87 100644 --- a/collects/tests/racket/embed.rktl +++ b/collects/tests/racket/embed.rktl @@ -460,6 +460,7 @@ (go '(planet racket-tester/p1/alt) "one\nalt\n") (go '(planet racket-tester/p1/other) "two\nother\n") (go '(planet "private/sub.rkt" ("racket-tester" "p2.plt" 2 0)) "two\nsub\n") + (go '(planet "private/sub.ss" ("racket-tester" "p2.plt" 2 0)) "two\nsub\n") (void)) @@ -468,11 +469,11 @@ ;; ---------------------------------------- -(try-basic) -(try-mzc) -(try-extension) -(try-gracket) -(try-reader) +;(try-basic) +;(try-mzc) +;(try-extension) +;(try-gracket) +;(try-reader) (try-planet) ;; ---------------------------------------- From b4ec84d1a9c3ce673ae2690547d3d400e7d69b95 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 20 Jul 2010 06:36:24 -0600 Subject: [PATCH 03/60] another ss->rkt repair to exe creator Merge to 5.0.1 (cherry picked from commit ce03a3431829ac54a1cccfc392881eca1b766dcd) original commit: 6c79f0d39975a24038ea67269e6e92ae244b389c --- collects/tests/racket/embed.rktl | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/collects/tests/racket/embed.rktl b/collects/tests/racket/embed.rktl index 16a4e71a87..457f2ea6b4 100644 --- a/collects/tests/racket/embed.rktl +++ b/collects/tests/racket/embed.rktl @@ -461,6 +461,7 @@ (go '(planet racket-tester/p1/other) "two\nother\n") (go '(planet "private/sub.rkt" ("racket-tester" "p2.plt" 2 0)) "two\nsub\n") (go '(planet "private/sub.ss" ("racket-tester" "p2.plt" 2 0)) "two\nsub\n") + (go '(planet "main.ss" ("racket-tester" "p2.plt" 2 0)) "two\n") (void)) @@ -469,11 +470,11 @@ ;; ---------------------------------------- -;(try-basic) -;(try-mzc) -;(try-extension) -;(try-gracket) -;(try-reader) +(try-basic) +(try-mzc) +(try-extension) +(try-gracket) +(try-reader) (try-planet) ;; ---------------------------------------- From 78faf5e6d696686f75f57517b9fdab796fb5049c Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Mon, 26 Jul 2010 11:45:01 -0600 Subject: [PATCH 04/60] zo-marshal wrap fixes, optional port for zo-parse original commit: 8eeed899824236c3c4a31954917c82d8f34d3948 --- collects/compiler/zo-marshal.rkt | 41 +++++++++++++++++++++++++---- collects/compiler/zo-parse.rkt | 3 ++- collects/tests/compiler/zo-test.rkt | 2 +- 3 files changed, 39 insertions(+), 7 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 8333ef8c23..f3b11324db 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -621,11 +621,42 @@ (define (encode-wrapped w) (match w [(struct wrapped (datum wraps certs)) - (vector - (cons - datum - (encode-wraps 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)])))] + [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 a ...) (list->vector + (map encode-wrapped a))] + [(? prefab-struct-key) + (let ([l (vector->list (struct->vector datum))]) + (make-prefab-struct + (car l) + (map encode-wrapped (cdr l))))] + [_ datum])] + [p (cons enc-datum + (encode-wraps wraps))]) + (if certs + (vector p certs) + p))])) (define (lookup-encoded-wrapped w out) (hash-ref (out-encoded-wraps out) w)) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 7c1186ed64..8cca2af017 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -502,6 +502,7 @@ (if (integer? v) (unmarshal-stx-get/decode cp v decode-stx) (let loop ([v v]) + ;(printf "~s~n" v) (let-values ([(cert-marks v encoded-wraps) (match v [`#((,datum . ,wraps) ,cert-marks) (values cert-marks datum wraps)] @@ -933,7 +934,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)) diff --git a/collects/tests/compiler/zo-test.rkt b/collects/tests/compiler/zo-test.rkt index d280efac02..56cd89db6e 100755 --- a/collects/tests/compiler/zo-test.rkt +++ b/collects/tests/compiler/zo-test.rkt @@ -326,7 +326,7 @@ exec racket -t "$0" -- -s -t 60 -v -R $* #f (print-bytes read-orig marshal-parsed)] [c-parse-marshalled - #f + #t (read-compiled-bytes marshal-parsed)] [compare-orig-to-marshalled #f From 99c7fa04e209adf9da7e3921993db5e873d36308 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 26 Jul 2010 12:18:01 -0600 Subject: [PATCH 05/60] Fixing up a few things in zo-parse/etc original commit: 28432037af571e844cdcab35875e090d3800fc96 --- collects/compiler/zo-marshal.rkt | 17 ++++++++++------- collects/compiler/zo-parse.rkt | 1 - collects/tests/compiler/zo-test.rkt | 8 +++++--- 3 files changed, 15 insertions(+), 11 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index f3b11324db..ff27685f18 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -1,6 +1,7 @@ #lang scheme/base (require compiler/zo-structs scheme/port + racket/vector scheme/match scheme/contract scheme/local @@ -633,6 +634,7 @@ (bloop b2))] [else (encode-wrapped b)])))] + ; XXX Cylic list error possible [len (let loop ([datum datum][len 0]) (cond [(null? datum) #f] @@ -643,14 +645,15 @@ (if len (cons len p) p))] - [(box x) (box (encode-wrapped x))] - [(vector a ...) (list->vector - (map encode-wrapped a))] + [(box x) + (box (encode-wrapped x))] + [(? vector? v) + (vector-map encode-wrapped v)] [(? prefab-struct-key) - (let ([l (vector->list (struct->vector datum))]) - (make-prefab-struct - (car l) - (map encode-wrapped (cdr l))))] + (define l (vector->list (struct->vector datum))) + (make-prefab-struct + (car l) + (map encode-wrapped (cdr l)))] [_ datum])] [p (cons enc-datum (encode-wraps wraps))]) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 8cca2af017..625de6963d 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -502,7 +502,6 @@ (if (integer? v) (unmarshal-stx-get/decode cp v decode-stx) (let loop ([v v]) - ;(printf "~s~n" v) (let-values ([(cert-marks v encoded-wraps) (match v [`#((,datum . ,wraps) ,cert-marks) (values cert-marks datum wraps)] diff --git a/collects/tests/compiler/zo-test.rkt b/collects/tests/compiler/zo-test.rkt index 56cd89db6e..81e86bd365 100755 --- a/collects/tests/compiler/zo-test.rkt +++ b/collects/tests/compiler/zo-test.rkt @@ -316,15 +316,15 @@ exec racket -t "$0" -- -s -t 60 -v -R $* [compare-marshalled-to-marshalled-marshalled #f (bytes-not-equal?-error marshal-parsed marshal-marshalled)] + #;[show-orig-and-marshal-parsed + #f + (print-bytes read-orig marshal-parsed)] #;[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 #t (read-compiled-bytes marshal-parsed)] @@ -333,6 +333,8 @@ exec racket -t "$0" -- -s -t 60 -v -R $* (bytes-not-equal?-error read-orig marshal-parsed)]) (define (run-test file) + (when (debugging?) + (printf "~a\n" file)) (run-with-limit file (* 1024 1024 128) From 9b95b870491055fe2326c24206b6c39ad1699843 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 27 Jul 2010 11:10:34 -0600 Subject: [PATCH 06/60] Fixing parts of zo-marshal re protect-quote; parallelizing zo-test; there is no the path error again in zo-marshal though original commit: 8d36dfad81c859968bff787b49de06b6889c736c --- collects/compiler/zo-marshal.rkt | 16 +- collects/tests/compiler/zo-exs.rkt | 15 +- collects/tests/compiler/zo-test-util.rkt | 12 + collects/tests/compiler/zo-test-worker.rkt | 270 +++++++++++ collects/tests/compiler/zo-test.rkt | 538 +++++++-------------- 5 files changed, 472 insertions(+), 379 deletions(-) create mode 100644 collects/tests/compiler/zo-test-util.rkt create mode 100644 collects/tests/compiler/zo-test-worker.rkt diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index ff27685f18..e8206838de 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -16,7 +16,6 @@ Less sharing occurs than in the C implementation, creating much larger files - 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)) @@ -681,11 +680,11 @@ (out-module form out)] [(struct def-values (ids rhs)) (out-syntax DEFINE_VALUES_EXPD - (list->vector (cons rhs ids)) + (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* rhs + (list->vector (list* (protect-quote rhs) prefix max-let-depth *dummy* @@ -693,7 +692,7 @@ out)] [(struct def-for-syntax (ids rhs prefix max-let-depth)) (out-syntax DEFINE_FOR_SYNTAX_EXPD - (list->vector (list* rhs + (list->vector (list* (protect-quote rhs) prefix max-let-depth *dummy* @@ -1091,11 +1090,12 @@ (define-struct quoted (v) #:prefab) +; 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 (protect-quote v) - v - #;(if (or (list? v) (vector? v) (box? v) (hash? v)) - (make-quoted v) - v)) + #;v + (if (or (list? v) (vector? v) (box? v) (hash? v)) + (make-quoted v) + v)) (define-struct svector (vec)) diff --git a/collects/tests/compiler/zo-exs.rkt b/collects/tests/compiler/zo-exs.rkt index b8ab07e067..75aea4d252 100644 --- a/collects/tests/compiler/zo-exs.rkt +++ b/collects/tests/compiler/zo-exs.rkt @@ -19,4 +19,17 @@ (make-reader-graph ht)))))] (hash-test make-hash-placeholder) (hash-test make-hasheq-placeholder) - (hash-test make-hasheqv-placeholder))) + (hash-test make-hasheqv-placeholder)) + + + (roundtrip + (compilation-top 0 + (prefix 0 empty empty) + (current-directory))) + + (roundtrip + (compilation-top 0 + (prefix 0 empty empty) + (list (current-directory))))) + + 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..0a698fe246 --- /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))]) + 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 128) + (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 81e86bd365..31ee8825d8 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,139 +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)] - #;[show-orig-and-marshal-parsed - #f - (print-bytes read-orig marshal-parsed)] - #;[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 (run-test file) - (when (debugging?) - (printf "~a\n" file)) - (run-with-limit - file - (* 1024 1024 128) - (lambda () - (run! file)))) - (define (randomize-list l) (define ll (length l)) (define seen? (make-hasheq)) @@ -366,59 +61,162 @@ 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-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) \ No newline at end of file From d8dae45321e14ec4d2df01808ed52aae8845fa28 Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Tue, 27 Jul 2010 12:48:57 -0600 Subject: [PATCH 07/60] Do not use CPT_ESCAPE for every CPT_QUOTE, instead if it was a protect-quote, then just put the CPT_QUOTE in. original commit: 53fdc09e7a071b93b67e84e617487e46e95e7689 --- collects/compiler/zo-marshal.rkt | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index e8206838de..27b7e7f7d8 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -778,9 +778,9 @@ 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]) + [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)] @@ -1078,14 +1078,14 @@ (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)))])) + (if (quoted? expr) + (out-data (quoted-v expr) out) + (let ([s (open-output-bytes)]) + (write 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) From b662bdef4c3561975d3ab3f015686d821615e857 Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Tue, 27 Jul 2010 13:41:58 -0600 Subject: [PATCH 08/60] closing stderr in zo-test original commit: 8b195d1c3c54cdac25c28f1619a4babf72f0d311 --- collects/tests/compiler/zo-test.rkt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/tests/compiler/zo-test.rkt b/collects/tests/compiler/zo-test.rkt index 31ee8825d8..dc4f49f939 100755 --- a/collects/tests/compiler/zo-test.rkt +++ b/collects/tests/compiler/zo-test.rkt @@ -109,7 +109,7 @@ exec racket -t "$0" -- -s -t 60 -v -R $* (when (debugging?) (printf "~a\n" p)) (define-values - (sp stdout stdin _stderr) + (sp stdout stdin stderr) (subprocess #f #f #f racket-path (path->string zo-test-worker-path) p)) (define r (dynamic-wind @@ -118,6 +118,7 @@ exec racket -t "$0" -- -s -t 60 -v -R $* (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)) From 8e7a64be3fafa2e7b5c98b7ad3dc0af88605c514 Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Wed, 28 Jul 2010 14:39:01 -0600 Subject: [PATCH 09/60] added another case for all-from-module renames original commit: 2dfd34003179b950b552b5c0d5c247c062badc49 --- collects/compiler/zo-marshal.rkt | 14 ++++++----- collects/compiler/zo-parse.rkt | 41 +++++++++++++------------------- 2 files changed, 24 insertions(+), 31 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 27b7e7f7d8..5e47a7ea18 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -576,12 +576,14 @@ (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-all-from-module + (match-lambda + [(struct all-from-module (path phase src-phase (list) #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 prefix)) + (list* path phase src-phase (append exns prefix))])) (define (encode-wraps wraps) (for/list ([wrap (in-list wraps)]) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 625de6963d..051b578d40 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -594,31 +594,22 @@ (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) + (map (local [(define (phase? v) + (or (number? v) (not v)))] + (match-lambda + [(list* path (? phase? phase) (? phase? src-phase) exn ... prefix) + (make-all-from-module + (parse-module-path-index cp path) + phase src-phase exn 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 empty #f)])) + unmarshals) (decode-renames renames) mark-renames (and plus-kern? 'plus-kern)))] From bb6903c6bf2d2301886a695c733ceaca306dac2e Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 30 Jul 2010 04:20:46 -0400 Subject: [PATCH 10/60] typo original commit: 14de7399bd592b76899acc00611b47952c9ce90d --- collects/compiler/commands/exe.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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)] From ad67592f9815327c508640e72925087020ec8ae6 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 30 Jul 2010 04:20:46 -0400 Subject: [PATCH 11/60] typo (cherry picked from commit 14de7399bd592b76899acc00611b47952c9ce90d) original commit: 700cb5ee8d2adff343ef79732c2010e7c55cae7d --- collects/compiler/commands/exe.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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)] From 7c32e885f3ad769cb85f3848d2dd2f08c86c7906 Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Fri, 30 Jul 2010 14:00:11 -0600 Subject: [PATCH 12/60] better certificate handling in zo-parse and zo-marshal original commit: 80c6ba482ded562f53b2625cfc32de9e795d4275 --- collects/compiler/zo-marshal.rkt | 26 ++++++++++++++++++++++++-- collects/compiler/zo-parse.rkt | 22 +++++++++++++++++++++- collects/compiler/zo-structs.rkt | 21 ++++++++++++++++++++- 3 files changed, 65 insertions(+), 4 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 5e47a7ea18..c466244325 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -76,7 +76,8 @@ (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) + (define symtabsize (add1 (hash-count shared))) + (write-bytes (int->bytes symtabsize) 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)) @@ -233,6 +234,8 @@ (for ([(k v) (in-hash expr)]) (traverse-data k visit) (traverse-data v visit)))] + [(protected-symref? expr) + (visit (protected-symref-val expr))] [else (void)])) @@ -620,6 +623,21 @@ [(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))])) + (define (encode-wrapped w) (match w [(struct wrapped (datum wraps certs)) @@ -659,7 +677,7 @@ [p (cons enc-datum (encode-wraps wraps))]) (if certs - (vector p certs) + (vector p (encode-certs certs)) p))])) (define (lookup-encoded-wrapped w out) @@ -932,6 +950,10 @@ (define (out-value expr out) (cond + [(protected-symref? expr) + (let* ([val (protected-symref-val expr)] + [val-ref ((out-shared-index out) val)]) + (out-value val-ref out))] [(and (symbol? expr) (not (symbol-interned? expr))) (out-as-bytes expr #:before-length (if (symbol-unreadable? expr) 0 1) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 051b578d40..4c29dab5ce 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -498,6 +498,25 @@ ;; ---------------------------------------- ;; Syntax unmarshaling +(define (decode-mark-map alist) + alist + #;(let loop ([alist alist] + [ht (make-immutable-hasheq empty)]) + (match alist + [(list) ht] + [(list* (? number? key) (? module-path-index? val) alist) + (loop alist (hash-set ht key val))]))) + +(define (decode-marks cp ms) + (match ms + [#f #f] + [(list* #f (? number? symref) alist) + (make-certificate:ref + (vector-ref (cport-symtab cp) symref) + (decode-mark-map alist))] + [(list* (? list? nested) alist) + (make-certificate:nest (decode-mark-map nested) (decode-mark-map alist))])) + (define (decode-stx cp v) (if (integer? v) (unmarshal-stx-get/decode cp v decode-stx) @@ -508,7 +527,8 @@ [`(,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))]) + [marks (decode-marks cp cert-marks)] + [add-wrap (lambda (v) (make-wrapped v wraps marks))]) (cond [(pair? v) (if (eq? #t (car v)) diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index daba19df57..e776109093 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -42,10 +42,29 @@ [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 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?])) From f7c42c1e6a588a128fbb56b167e0032a047819d3 Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Fri, 30 Jul 2010 15:30:14 -0600 Subject: [PATCH 13/60] Added case in zo-marshal for prefab structs Made quoted not-prefab so it isn't captured by prefab case original commit: 63c6cc5d2c6ae3b467bcbe54931885964b720802 --- collects/compiler/zo-marshal.rkt | 24 +++++++++++++++++++----- 1 file changed, 19 insertions(+), 5 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index c466244325..2f809b47bb 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -234,6 +234,11 @@ (for ([(k v) (in-hash expr)]) (traverse-data k visit) (traverse-data v visit)))] + [(prefab-struct-key expr) + (when (visit expr) + (let ([v (struct->vector expr)]) + (for ([i (in-range 1 (vector-length v))]) + (traverse-data (vector-ref v i) visit))))] [(protected-symref? expr) (visit (protected-symref-val expr))] [else @@ -310,7 +315,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) @@ -681,7 +686,9 @@ p))])) (define (lookup-encoded-wrapped w out) - (hash-ref (out-encoded-wraps out) w)) + (hash-ref (out-encoded-wraps out) w + (lambda () + (error 'lookup-encoded-wrapped "Cannot find encoded version of wrap: ~e" w)))) (define (out-wrapped w out) (out-data (lookup-encoded-wrapped w out) out)) @@ -1053,6 +1060,7 @@ (print-contents-as-proper) (out-data 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) @@ -1099,7 +1107,13 @@ [(stx? expr) (out-stx expr out)] [(wrapped? expr) - (out-wrapped expr out)] + (out-wrapped expr out)] + [(prefab-struct-key expr) + => (lambda (key) + (define pre-v (struct->vector expr)) + (vector-set! pre-v 0 key) + (out-byte CPT_PREFAB out) + (out-data pre-v out))] [else (out-byte CPT_QUOTE out) (if (quoted? expr) @@ -1112,12 +1126,12 @@ (out-bytes bstr out))))])) -(define-struct quoted (v) #:prefab) +(define-struct quoted (v)) ; 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 (protect-quote v) #;v - (if (or (list? v) (vector? v) (box? v) (hash? v)) + (if (or (pair? v) (vector? v) (prefab-struct-key v) (box? v) (hash? v) (svector? v)) (make-quoted v) v)) From 2efb39c39194f163f70f567eae5de0e5bf5f7cb0 Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Thu, 29 Jul 2010 15:52:12 -0600 Subject: [PATCH 14/60] another all-from-module fix original commit: 7653ce037bdb099a859a2008001ae271eaa65ba3 --- collects/compiler/zo-marshal.rkt | 8 ++++---- collects/compiler/zo-parse.rkt | 11 +++++------ collects/compiler/zo-structs.rkt | 4 ++-- 3 files changed, 11 insertions(+), 12 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 2f809b47bb..d3b0210063 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -586,12 +586,12 @@ (define encode-all-from-module (match-lambda - [(struct all-from-module (path phase src-phase (list) #f)) - (list* path phase src-phase)] + [(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 prefix)) - (list* path phase src-phase (append exns prefix))])) + [(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)]) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 4c29dab5ce..e7adc72a82 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -26,8 +26,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 @@ -587,7 +585,7 @@ [(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))) + [(and (pair? a) (number? (car a))) (make-wrap-mark (car a))] [(vector? a) @@ -617,10 +615,11 @@ (map (local [(define (phase? v) (or (number? v) (not v)))] (match-lambda - [(list* path (? phase? phase) (? phase? src-phase) exn ... prefix) + [(list* path (? phase? phase) (? phase? src-phase) + (list exn ...) prefix) (make-all-from-module (parse-module-path-index cp path) - phase src-phase exn prefix)] + 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) @@ -628,7 +627,7 @@ [(list* path (? phase? phase) (? phase? src-phase)) (make-all-from-module (parse-module-path-index cp path) - phase src-phase empty #f)])) + phase src-phase #f #f)])) unmarshals) (decode-renames renames) mark-renames diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index e776109093..8cc5042729 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -179,8 +179,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 symbol?) #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?])) From c998fe85e9d67502ee58fb9b8722feaaaa230702 Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Mon, 2 Aug 2010 16:18:11 -0600 Subject: [PATCH 15/60] applying make-prefab-struct original commit: 551ef5ba30fbd274fc30f53cd06d9926873eff28 --- collects/compiler/zo-marshal.rkt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index d3b0210063..6e0d8ae475 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -675,7 +675,8 @@ (vector-map encode-wrapped v)] [(? prefab-struct-key) (define l (vector->list (struct->vector datum))) - (make-prefab-struct + (apply + make-prefab-struct (car l) (map encode-wrapped (cdr l)))] [_ datum])] From aee68bb7884e5adf336e878cce4c72e91d445474 Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Tue, 3 Aug 2010 15:19:30 -0600 Subject: [PATCH 16/60] cases for more complicated lexical renames original commit: b062c900a1b7e153aea8fd317f323d0c479bfc3c --- collects/compiler/zo-marshal.rkt | 10 ++++++++++ collects/compiler/zo-parse.rkt | 9 ++++++++- collects/compiler/zo-structs.rkt | 26 +++++++++++++++++++++++--- 3 files changed, 41 insertions(+), 4 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 6e0d8ae475..29bff55b83 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -271,6 +271,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 () @@ -446,6 +447,14 @@ (list->vector stxs))) out)])) +(define (out-free-id-info a-free-id-info out) + (match a-free-id-info + [(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)])) + (define-struct module-decl (content)) (define (out-module mod-form out) @@ -954,6 +963,7 @@ [(prefix? expr) (out-prefix expr out)] [(global-bucket? expr) (out-toplevel expr out)] [(module-variable? expr) (out-toplevel expr out)] + [(free-id-info? expr) (out-free-id-info expr out)] [else (out-form expr out)])) (define (out-value expr out) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index e7adc72a82..3afd74e4d3 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -70,6 +70,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) @@ -313,6 +318,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 @@ -333,7 +339,8 @@ (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) diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index 8cc5042729..509a2dc7d5 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -169,9 +169,27 @@ ;; 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])) @@ -179,7 +197,7 @@ (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 (or/c (listof symbol?) #f)] ; should be (listof symbol?) + [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 ()) @@ -226,3 +244,5 @@ + + From 4b9635cb70c38e6b7faee6140c2d09605d00f7fe Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 17 Aug 2010 17:18:24 -0600 Subject: [PATCH 17/60] fix bytecode-writing inconsistencies related to syntax objects and paths and improve organization of the docs original commit: 0d9f5016ba98a7a7b9c83abddcfa3c02498a63fb --- collects/compiler/zo-marshal.rkt | 26 ++++++++++++++++++++++++-- collects/compiler/zo-parse.rkt | 18 +++++++++++++++++- 2 files changed, 41 insertions(+), 3 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index f10a095f3b..da13079be1 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -8,7 +8,9 @@ racket/local racket/list racket/dict - racket/function) + racket/function + racket/pretty + racket/path) (provide/contract [zo-marshal (compilation-top? . -> . bytes?)] @@ -901,6 +903,7 @@ CPT_BYTE_STRING #f out)] + #; [(path? expr) (out-as-bytes expr path->bytes @@ -1024,7 +1027,20 @@ (if (quoted? expr) (out-data (quoted-v expr) out) (let ([s (open-output-bytes)]) - (write expr s) + ;; print `expr' to a string, but print paths + ;; in a special way + (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 expr s)) (out-byte CPT_ESCAPE out) (let ([bstr (get-output-bytes s)]) (out-number (bytes-length bstr) out) @@ -1041,5 +1057,11 @@ (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 3afd74e4d3..ed2541fdaf 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -732,7 +732,23 @@ [read-decimal-as-inexact #t] [read-accept-dot #t] [read-accept-infix-dot #t] - [read-accept-quasiquote #t]) + [read-accept-quasiquote #t] + ;; Use a readtable for special path support in escaped: + [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))] From 03593e433bcd7610ef61a3908b9fdf290d4b8aa4 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 25 Aug 2010 14:48:22 -0600 Subject: [PATCH 18/60] teach decompiler about literal prims from `#%futures' original commit: 9be05599361316c9e01b6facaca9b8a66c6ab2f5 --- collects/compiler/decompile.rkt | 1 + 1 file changed, 1 insertion(+) diff --git a/collects/compiler/decompile.rkt b/collects/compiler/decompile.rkt index 6c8c75d4a4..b592d15776 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))))))] From 9bebb5a98d70967ecb9f15af290e3ce2c31a047f Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 25 Aug 2010 16:10:55 -0400 Subject: [PATCH 19/60] Lots of "~e" to "~.s" changes. original commit: 606b7f60dc597a6870efc11364e1dd3e1a8b4a1b --- collects/compiler/zo-parse.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index ed2541fdaf..51b844e775 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -530,7 +530,7 @@ (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)])]) + [else (error 'decode-wraps "bad datum+wrap: ~.s" v)])]) (let* ([wraps (decode-wraps cp encoded-wraps)] [marks (decode-marks cp cert-marks)] [add-wrap (lambda (v) (make-wrapped v wraps marks))]) From 33624300a8994fa6efbd5164ff7e754cbe911a67 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 25 Aug 2010 17:16:32 -0400 Subject: [PATCH 20/60] Change a bunch of "~%" and "~n" in format strings to "\n". original commit: 7dc4d2e5a63ab416d90e44d7bf75cb5593329909 --- collects/tests/compiler/zo-test.rkt | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/collects/tests/compiler/zo-test.rkt b/collects/tests/compiler/zo-test.rkt index dc4f49f939..1b1279eb36 100755 --- a/collects/tests/compiler/zo-test.rkt +++ b/collects/tests/compiler/zo-test.rkt @@ -203,21 +203,21 @@ exec racket -t "$0" -- -s -t 60 -v -R $* (define succs (length (hash-ref success-ht kind-name empty))) (define all (+ fails succs)) (unless (zero? all) - (printf "~S~n" + (printf "~S\n" `(,kind-name (#f ,fails) (#t ,succs) ,all)))) (newline) - (printf "~a tests passed~n" (length (hash-ref success-ht 'everything empty))) + (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") + (printf "Common Errors:\n") (for ([p (in-list common-errors)]) - (printf "~a:~n~a~n~n" (car p) (cdr p))))))))) + (printf "~a:\n~a\n\n" (car p) (cdr p))))))))) -(thread-wait final-thread) \ No newline at end of file +(thread-wait final-thread) From f38ec26ea5df762525ac575f860285923f7c69e3 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 26 Aug 2010 12:10:48 -0400 Subject: [PATCH 21/60] More "~n" -> "\n" changes original commit: 8e0f8dd39c3744472b450021f003f9cbe8cbcb62 --- collects/tests/racket/embed-me1.rkt | 2 +- collects/tests/racket/embed-me1b.rkt | 2 +- collects/tests/racket/embed-me1c.rkt | 2 +- collects/tests/racket/embed-me1d.rkt | 2 +- collects/tests/racket/embed-me1e.rkt | 2 +- collects/tests/racket/embed-me2.rkt | 5 +---- collects/tests/racket/embed.rktl | 2 +- 7 files changed, 7 insertions(+), 10 deletions(-) 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-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..f959ec7031 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))) From 1b3843bd9cb6e4cb8fe79e4daf6742633f5c7360 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 30 Aug 2010 09:17:21 -0600 Subject: [PATCH 22/60] fix yet more ss<->rkt problems that interfered with *SL executables Closes PR 11106 original commit: 76c3c7621405d189993fa8935de2c6688567700f --- collects/tests/racket/embed-me12-rd.ss | 15 +++++++++++++ collects/tests/racket/embed.rktl | 30 ++++++++++++++++++++------ 2 files changed, 38 insertions(+), 7 deletions(-) create mode 100644 collects/tests/racket/embed-me12-rd.ss 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.rktl b/collects/tests/racket/embed.rktl index f959ec7031..25924e8f06 100644 --- a/collects/tests/racket/embed.rktl +++ b/collects/tests/racket/embed.rktl @@ -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))) ;; ---------------------------------------- From 1d54bf17a5072833da2e57d8e622f2bc64c855df Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Tue, 17 Aug 2010 12:09:05 -0600 Subject: [PATCH 23/60] zo-parse debugging and read in zo-exs original commit: f27fe3d5c9941e536275d0f56cb02d6df16ac283 --- collects/compiler/zo-parse.rkt | 15 +++++++++----- collects/tests/compiler/zo-exs.rkt | 33 +++++++++++++++++------------- 2 files changed, 29 insertions(+), 19 deletions(-) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 51b844e775..b7889fe291 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -709,10 +709,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) @@ -1004,8 +1005,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)) + + #;(for ([i (in-naturals)] + [v (in-vector (cport-symtab cp))]) + (printf "~a: ~s~n~n" i (placeholder-get v))) (set-cport-pos! cp shared-size) (make-reader-graph (read-marshalled 'compilation-top-type cp)))) diff --git a/collects/tests/compiler/zo-exs.rkt b/collects/tests/compiler/zo-exs.rkt index 75aea4d252..8fd5d3ee47 100644 --- a/collects/tests/compiler/zo-exs.rkt +++ b/collects/tests/compiler/zo-exs.rkt @@ -3,12 +3,28 @@ compiler/zo-marshal tests/eli-tester) +(define (read-compiled-bytes bs) + (parameterize ([read-accept-compiled #t]) + (read (open-input-bytes bs)))) + (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)))) (test + (roundtrip + (compilation-top 0 + (prefix 0 empty empty) + (current-directory))) + + (roundtrip + (compilation-top 0 + (prefix 0 empty empty) + (list (current-directory)))) + (local [(define (hash-test make-hash-placeholder) (roundtrip (compilation-top 0 @@ -19,17 +35,6 @@ (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) - (current-directory))) - - (roundtrip - (compilation-top 0 - (prefix 0 empty empty) - (list (current-directory))))) + (hash-test make-hasheqv-placeholder))) From 817b3186d97d73a77b90712a7b2973cdbbb2c030 Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Thu, 19 Aug 2010 12:33:31 -0600 Subject: [PATCH 24/60] zo-marshal single out-anything function and zo-parse debugging original commit: 37f07cb68b504ed1e80853c899ef710cbf60188d --- collects/compiler/zo-marshal.rkt | 1117 ++++++++++++++---------------- collects/compiler/zo-parse.rkt | 397 ++++++----- 2 files changed, 738 insertions(+), 776 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index da13079be1..fa3be595e9 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -8,9 +8,7 @@ racket/local racket/list racket/dict - racket/function - racket/pretty - racket/path) + racket/function) (provide/contract [zo-marshal (compilation-top? . -> . bytes?)] @@ -24,8 +22,8 @@ (define (zo-marshal-to top outp) (match top [(struct compilation-top (max-let-depth prefix form)) - (define shared (make-hasheq)) - (define wrapped (make-hasheq)) + (define shared (make-hash)) + (define wrapped (make-hash)) (define (shared-obj-pos v) (hash-ref shared v #f)) (define (share! v) @@ -34,13 +32,15 @@ (list* max-let-depth prefix (protect-quote form))) ; Compute what objects are in ct multiple times (by equal?) - (local [(define encountered (make-hasheq)) + (local [(define encountered (make-hash)) (define (encountered? v) (hash-ref encountered v #f)) (define (encounter! v) (hash-set! encountered v #t)) (define (visit! v) (cond + [(not (shareable? v)) + #t] [(shared-obj-pos v) #f] [(encountered? v) @@ -86,8 +86,8 @@ ; Compute where we ended (define post-shared (file-position outp)) ; Write the entire ctop - (out-data ct - (make-out outp shared-obj-pos wrapped)) + (out-anything ct + (make-out outp shared-obj-pos wrapped)) (values offsets post-shared (file-position outp))) ; Compute where the symbol table ends @@ -277,18 +277,146 @@ (define-struct case-seq (name lams)) (define-struct (seq0 seq) ()) + +(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 + (match-lambda + [(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))])) + +(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 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))) @@ -322,34 +450,375 @@ (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 (shareable? v) + (not (or-pred? v char? maybe-same-as-fixnum? empty? boolean? void?))) + +(define (maybe-same-as-fixnum? v) + (and (exact-integer? v) + (and (v . >= . -1073741824) (v . <= . 1073741823)))) (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)])) - -(define (out-free-id-info a-free-id-info out) - (match a-free-id-info - [(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)])) + (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 indirect (val)) (out-anything val out)] + [(struct closure (lam gen-id)) + (out-byte CPT_CLOSURE out) + (out-number ((out-shared-index out) v) 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) 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?) + (define (list-length-before-cycle/improper-end l) + (let loop ([len 1] [l (cdr l)]) + (cond + [((out-shared-index out) l) + (values len #f)] + [(null? l) + (values len #t)] + [(pair? l) + (loop (add1 len) (cdr 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] + [else 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)] + [else + (out-byte CPT_QUOTE out) + (if (quoted? v) + (out-anything (quoted-v v) out) + (let ([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 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 module-decl (content)) @@ -444,361 +913,15 @@ (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 - (match-lambda - [(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))])) - -(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 (lookup-encoded-wrapped w out) (hash-ref (out-encoded-wraps out) w (lambda () (error 'lookup-encoded-wrapped "Cannot find encoded version of wrap: ~e" 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 (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)] - [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) @@ -845,207 +968,13 @@ 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 (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)] - [(free-id-info? expr) (out-free-id-info expr out)] - [else (out-form expr out)])) - -(define (out-value expr out) - (cond - [(protected-symref? expr) - (let* ([val (protected-symref-val expr)] - [val-ref ((out-shared-index out) val)]) - (out-value val-ref out))] - [(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)) - ; 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? 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)] - [(prefab-struct-key expr) - => (lambda (key) - (define pre-v (struct->vector expr)) - (vector-set! pre-v 0 key) - (out-byte CPT_PREFAB out) - (out-data pre-v out))] - [else - (out-byte CPT_QUOTE out) - (if (quoted? expr) - (out-data (quoted-v expr) out) - (let ([s (open-output-bytes)]) - ;; print `expr' to a string, but print paths - ;; in a special way - (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 expr s)) - (out-byte CPT_ESCAPE out) - (let ([bstr (get-output-bytes s)]) - (out-number (bytes-length bstr) out) - (out-bytes bstr 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-struct quoted (v)) @@ -1057,11 +986,5 @@ (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 b7889fe291..9d57363ec8 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)) @@ -30,6 +32,8 @@ ;; ---------------------------------------- ;; Bytecode unmarshalers for various forms +(define debug-symrefs #f) + (define (read-toplevel v) (define SCHEME_TOPLEVEL_CONST #x01) (define SCHEME_TOPLEVEL_READY #x02) @@ -503,157 +507,172 @@ ;; ---------------------------------------- ;; 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 - #;(let loop ([alist alist] - [ht (make-immutable-hasheq empty)]) - (match alist - [(list) ht] - [(list* (? number? key) (? module-path-index? val) alist) - (loop alist (hash-set ht key val))]))) + alist) +(define marks-memo (make-memo)) (define (decode-marks cp ms) - (match ms - [#f #f] - [(list* #f (? number? symref) alist) - (make-certificate:ref - (vector-ref (cport-symtab cp) symref) - (decode-mark-map alist))] - [(list* (? list? nested) alist) - (make-certificate:nest (decode-mark-map nested) (decode-mark-map alist))])) + (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))]))) +(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: ~.s" v)])]) - (let* ([wraps (decode-wraps cp encoded-wraps)] - [marks (decode-marks cp cert-marks)] - [add-wrap (lambda (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]) + (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) (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 (local [(define (phase? v) - (or (number? v) (not v)))] - (match-lambda - [(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)])) - 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)]))) - 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 @@ -665,40 +684,48 @@ (λ _ #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) @@ -734,7 +761,6 @@ [read-accept-dot #t] [read-accept-infix-dot #t] [read-accept-quasiquote #t] - ;; Use a readtable for special path support in escaped: [current-readtable (make-readtable #f @@ -910,10 +936,10 @@ (make-application (read-compact cp) (for/list ([i (in-range c)]) (read-compact cp))))] - [(closure) + [(closure) ; XXX The use of indirect may be an artifact from pre-placeholder days (let* ([l (read-compact-number cp)] [ind (make-indirect #f)]) - (placeholder-set! (vector-ref (cport-symtab cp) l) ind) + (symtab-write! cp l ind) (let* ([v (read-compact cp)] [cl (make-closure v (gensym (let ([s (lam-name v)]) @@ -941,15 +967,22 @@ (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) + (when (mark-parameter-first read-sym-mark) + (dict-update! debug-symrefs (mark-parameter-first read-sym-mark) (λ (last) (cons i last)) empty)) + (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 @@ -1003,11 +1036,17 @@ (define symtab (build-vector symtabsize (λ (i) (make-placeholder nr)))) + (set! debug-symrefs (make-vector symtabsize empty)) + (define cp (make-cport 0 shared-size port size* rst-start symtab so* (make-vector symtabsize #f) (make-hash) (make-hash))) (for ([i (in-range 1 symtabsize)]) (read-sym cp i)) + (for ([i (in-naturals)] + [v (in-vector debug-symrefs)]) + (printf "~a: ~a~n" i v)) + #;(for ([i (in-naturals)] [v (in-vector (cport-symtab cp))]) (printf "~a: ~s~n~n" i (placeholder-get v))) From ae4b7709399eae6529fba0e213dc3719f18b0532 Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Fri, 20 Aug 2010 13:47:03 -0600 Subject: [PATCH 25/60] zo-marshal fixes and read.c fix for hash tables in symbol table original commit: 9599304ca90d1a76a80e5edcf13f13e9bc83ac53 --- collects/compiler/zo-marshal.rkt | 17 +++++++++++++---- collects/compiler/zo-parse.rkt | 4 ++-- collects/tests/compiler/zo-exs.rkt | 16 +++++++++++++--- 3 files changed, 28 insertions(+), 9 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index fa3be595e9..42d143df7d 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -8,7 +8,9 @@ racket/local racket/list racket/dict - racket/function) + racket/function + racket/pretty + racket/path) (provide/contract [zo-marshal (compilation-top? . -> . bytes?)] @@ -305,8 +307,8 @@ (list* path phase export-name (encode-nominal-path nominal-path) nominal-export-name)]))) encoded-bindings) -(define encode-all-from-module - (match-lambda +(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)) @@ -814,7 +816,7 @@ (lambda (v mode port) (display "#^" port) (write (path->bytes (make-relative v)) port))]) - (pretty-write expr s)) + (pretty-write v s)) (out-byte CPT_ESCAPE out) (let ([bstr (get-output-bytes s)]) (out-number (bytes-length bstr) out) @@ -986,5 +988,12 @@ (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 9d57363ec8..3b1b820733 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -1043,10 +1043,10 @@ (for ([i (in-range 1 symtabsize)]) (read-sym cp i)) - (for ([i (in-naturals)] + #;(for ([i (in-naturals)] [v (in-vector debug-symrefs)]) (printf "~a: ~a~n" i v)) - + #;(printf "SYMBOL TABLE:~n~n") #;(for ([i (in-naturals)] [v (in-vector (cport-symtab cp))]) (printf "~a: ~s~n~n" i (placeholder-get v))) diff --git a/collects/tests/compiler/zo-exs.rkt b/collects/tests/compiler/zo-exs.rkt index 8fd5d3ee47..a5bd61d5f0 100644 --- a/collects/tests/compiler/zo-exs.rkt +++ b/collects/tests/compiler/zo-exs.rkt @@ -9,23 +9,33 @@ (define (roundtrip ct) (define bs (zo-marshal ct)) + (with-output-to-file "test_rkt.zo" (λ () (write-bytes bs)) #:exists 'replace) (test #:failure-prefix (format "~S" ct) (test bs (zo-parse (open-input-bytes bs)) => ct (read-compiled-bytes bs)))) +(define mpi (module-path-index-join #f #f)) + (test - (roundtrip + #;(roundtrip (compilation-top 0 (prefix 0 empty empty) (current-directory))) - (roundtrip + #;(roundtrip (compilation-top 0 (prefix 0 empty empty) (list (current-directory)))) - (local [(define (hash-test make-hash-placeholder) + (roundtrip + (compilation-top + 0 + (prefix 0 empty empty) + (cons #hasheq() + #hasheq()))) + + #;(local [(define (hash-test make-hash-placeholder) (roundtrip (compilation-top 0 (prefix 0 empty empty) From 4379002ddce7f0e9aff37653975432671a0344b6 Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Mon, 23 Aug 2010 18:09:54 -0600 Subject: [PATCH 26/60] traverse while writing rather than a separate step original commit: 88dcab6b5abf562644267d3c3dc8e2d4bc5010e2 --- collects/compiler/zo-marshal.rkt | 224 +++++++++++++------------------ 1 file changed, 95 insertions(+), 129 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 42d143df7d..58aa361ca5 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -21,136 +21,102 @@ (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 shared (make-hash)) - (define wrapped (make-hash)) - (define (shared-obj-pos v) - (hash-ref shared v #f)) - (define (share! v) - (hash-set! shared v (add1 (hash-count shared)))) - (define ct - (list* max-let-depth prefix (protect-quote form))) - - ; Compute what objects are in ct multiple times (by equal?) - (local [(define encountered (make-hash)) - (define (encountered? v) - (hash-ref encountered v #f)) - (define (encounter! v) - (hash-set! encountered v #t)) - (define (visit! v) - (cond - [(not (shareable? v)) - #t] - [(shared-obj-pos v) - #f] - [(encountered? v) - (share! v) - #f] - [else - (encounter! v) - ; All closures MUST be in the symbol table - (when (closure? v) - (share! v)) - #t]))] - (traverse wrapped visit! ct)) - - ; Hash tables aren't sorted, so we need to order them - (define in-order-shareds - (sort (hash-map shared (lambda (k v) (cons v k))) - < - #:key car)) - - (define (write-all outp) - ; As we are writing the symbol table entry for v, - ; the writing code will attempt to see if v is shared and - ; insert a symtable reference, which would be wrong. - ; So, the first time it is encountered while writing, - ; we should pretend it ISN'T shared, so it is actually written. - ; However, subsequent times (or for other shared values) - ; we defer to the normal 'shared-obj-pos' - (define (shared-obj-pos/modulo-v v) - (define skip? #t) - (lambda (v2) - (if (and skip? (eq? v v2)) - (begin - (set! skip? #f) - #f) - (shared-obj-pos v2)))) - ; Write the symbol table, computing offsets as we go - (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 (shared-obj-pos/modulo-v v) wrapped))))) - ; Compute where we ended - (define post-shared (file-position outp)) - ; Write the entire ctop - (out-anything ct - (make-out outp shared-obj-pos wrapped)) - (values offsets post-shared (file-position outp))) - - ; Compute where the symbol table ends - (define counting-p (open-output-nowhere)) - (define-values (offsets post-shared all-forms-length) - (write-all counting-p)) - - ; 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) - - ; Write the symbol table information (size, offsets) - (define symtabsize (add1 (hash-count shared))) - (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) - ; Write the symbol table then the ctop - (write-all outp) - (void)])) +; function -> 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 out-compilation-top) + (define encountered (make-hash)) + (define shared (make-hash)) + (define (encountered? v) + (hash-ref encountered v #f)) + (define (encounter! v) + (hash-set! encountered v #t)) + (define (shared-obj-pos v) + (hash-ref shared v #f)) + (define (share! v) + (hash-set! shared v (add1 (hash-count-shared)))) + + (out-compilation-top + (λ (v) + (if (or (closure? v) + (and (encountered? v) + (shareable? v))) + (share! v) + (encounter! v)) + #f) + (open-output-nowhere)) + + (define symbol-table (make-vector (hash-count shared))) + (hash-map shared (λ (k v) (vector-set! symbol-table v k))) + (values symbol-table shared-obj-pos)) -(define (traverse wrapped-ht visit! expr) - (when (visit! expr) - (match expr - [(? wrapped? w) - (define encoded-w - (hash-ref! wrapped-ht w (lambda () (encode-wrapped w)))) - (traverse wrapped-ht visit! encoded-w)] - [(? prefab-struct-key) - (map (curry traverse wrapped-ht visit!) (struct->list expr))] - [(cons l r) - (traverse wrapped-ht visit! l) - (traverse wrapped-ht visit! r)] - [(? vector?) - (for ([v (in-vector expr)]) - (traverse wrapped-ht visit! v))] - [(? hash?) - (for ([(k v) (in-hash expr)]) - (traverse wrapped-ht visit! k) - (traverse wrapped-ht visit! v))] - [(? module-path-index?) - (define-values (name base) (module-path-index-split expr)) - (traverse wrapped-ht visit! name) - (traverse wrapped-ht visit! base)] - [(box v) - (traverse wrapped-ht visit! v)] - [(protected-symref v) - (traverse wrapped-ht visit! v)] - [(quoted v) - (traverse wrapped-ht visit! v)] - [else (void)]))) +(define (zo-marshal-to top outp) + + ; XXX: wraps were encoded in traverse, now needs to be handled when writing + (define wrapped (make-hash)) + + ; function 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 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 wrapped)) + (file-position outp)) + + (define-values (symbol-table shared-obj-pos) (create-symbol-table out-compilation-top)) + + ; 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) + (if (and skip? (eq? v v2)) + (begin + (set! skip? #f) + #f) + (shared-obj-pos v2)))) + (values + (for/list ([v (in-vector symbol-table)]) + (begin0 + (file-position outp) + (out-anything v (make-out outp (shared-obj-pos/modulo-v v) 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 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) + + ; Write the symbol table information (size, offsets) + (define symtabsize (add1 (hash-count shared))) + (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 outp) + (void)) ;; ---------------------------------------- From b63f532735a8cf4947ddd46b89562ea5eb1c550f Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Tue, 24 Aug 2010 14:42:19 -0600 Subject: [PATCH 27/60] encoding wraps and fixes for zo-marshal sharing original commit: 54f2d34a2e332c79e3f0cce89fa70bb46708fad6 --- collects/compiler/zo-marshal.rkt | 44 ++++++++++++++++-------------- collects/compiler/zo-parse.rkt | 2 +- collects/tests/compiler/zo-exs.rkt | 34 ++++++++++++++++++++++- 3 files changed, 57 insertions(+), 23 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 58aa361ca5..872afea1b1 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -10,18 +10,21 @@ racket/dict racket/function racket/pretty - racket/path) + racket/path + racket/set) (provide/contract [zo-marshal (compilation-top? . -> . bytes?)] [zo-marshal-to (compilation-top? output-port? . -> . void?)]) +(struct not-ready ()) + (define (zo-marshal top) (define bs (open-output-bytes)) (zo-marshal-to top bs) (get-output-bytes bs)) -; function -> vector +; ((obj -> (or pos #f)) output-port -> number) -> 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 out-compilation-top) @@ -30,24 +33,26 @@ (define (encountered? v) (hash-ref encountered v #f)) (define (encounter! v) - (hash-set! encountered v #t)) + (hash-set! encountered v #t) + #f) (define (shared-obj-pos v) (hash-ref shared v #f)) (define (share! v) - (hash-set! shared v (add1 (hash-count-shared)))) + (or (hash-ref shared v #f) + (let ([pos (add1 (hash-count shared))]) + (hash-set! shared v pos) + pos))) (out-compilation-top (λ (v) (if (or (closure? v) - (and (encountered? v) - (shareable? v))) + (encountered? v)) (share! v) - (encounter! v)) - #f) + (encounter! v))) (open-output-nowhere)) - (define symbol-table (make-vector (hash-count shared))) - (hash-map shared (λ (k v) (vector-set! symbol-table v k))) + (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 (zo-marshal-to top outp) @@ -55,7 +60,7 @@ ; XXX: wraps were encoded in traverse, now needs to be handled when writing (define wrapped (make-hash)) - ; function output-port -> number + ; (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 outp) @@ -65,9 +70,8 @@ (list* max-let-depth prefix (protect-quote form))])) (out-anything ct (make-out outp shared-obj-pos wrapped)) (file-position outp)) - (define-values (symbol-table shared-obj-pos) (create-symbol-table out-compilation-top)) - + ; 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 @@ -91,7 +95,6 @@ (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 counting-port)) - ; Write the compiled form header (write-bytes #"#~" outp) @@ -101,13 +104,12 @@ (write-bytes version-bs outp) ; Write the symbol table information (size, offsets) - (define symtabsize (add1 (hash-count shared))) + (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 @@ -686,14 +688,14 @@ (out-anything (unbox v) out)] [(? pair?) (define (list-length-before-cycle/improper-end l) - (let loop ([len 1] [l (cdr l)]) + (let loop ([len 1] [l (cdr l)] [seen (set)]) (cond - [((out-shared-index out) l) + [(set-member? seen l) (values len #f)] [(null? l) (values len #t)] [(pair? l) - (loop (add1 len) (cdr 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)) @@ -884,8 +886,8 @@ (define (lookup-encoded-wrapped w out) (hash-ref (out-encoded-wraps out) w - (lambda () - (error 'lookup-encoded-wrapped "Cannot find encoded version of wrap: ~e" w)))) + (λ () + (encode-wrapped w)))) (define (out-lam expr out) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 3b1b820733..5e195c90a7 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -1046,7 +1046,7 @@ #;(for ([i (in-naturals)] [v (in-vector debug-symrefs)]) (printf "~a: ~a~n" i v)) - #;(printf "SYMBOL TABLE:~n~n") + #;(printf "SYMBOL TABLE(~a):~n~n" symtabsize) #;(for ([i (in-naturals)] [v (in-vector (cport-symtab cp))]) (printf "~a: ~s~n~n" i (placeholder-get v))) diff --git a/collects/tests/compiler/zo-exs.rkt b/collects/tests/compiler/zo-exs.rkt index a5bd61d5f0..c46e7fd7e6 100644 --- a/collects/tests/compiler/zo-exs.rkt +++ b/collects/tests/compiler/zo-exs.rkt @@ -18,6 +18,38 @@ (define mpi (module-path-index-join #f #f)) (test + (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) @@ -28,7 +60,7 @@ (prefix 0 empty empty) (list (current-directory)))) - (roundtrip + #;(roundtrip (compilation-top 0 (prefix 0 empty empty) From b816da148dd939bb11523edd102a144d13dcb51c Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Tue, 24 Aug 2010 17:12:32 -0600 Subject: [PATCH 28/60] quoting parameter and not prefab structs original commit: 893294674a77ed6d6f84df6d54017c1bc7bd34ce --- collects/compiler/zo-marshal.rkt | 9 +++++++-- collects/compiler/zo-structs.rkt | 2 +- 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 872afea1b1..a34d4c6445 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -425,13 +425,17 @@ (define (or-pred? v . ps) (ormap (lambda (?) (? v)) ps)) + +(define quoting? (make-parameter #f)) + (define (shareable? v) - (not (or-pred? v char? maybe-same-as-fixnum? empty? boolean? void?))) + (not (or quoting? (or-pred? v char? maybe-same-as-fixnum? empty? boolean? void?)))) (define (maybe-same-as-fixnum? v) (and (exact-integer? v) (and (v . >= . -1073741824) (v . <= . 1073741823)))) + (define (out-anything v out) (out-shared v out @@ -771,7 +775,8 @@ [else (out-byte CPT_QUOTE out) (if (quoted? v) - (out-anything (quoted-v v) out) + (parameterize ([quoting? #t]) + (out-anything (quoted-v v) out)) (let ([s (open-output-bytes)]) (parameterize ([pretty-print-size-hook (lambda (v mode port) diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index 509a2dc7d5..cbb987a5fa 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -22,7 +22,7 @@ (define-syntax-rule (define-form-struct* id id+par ([field-id field-contract] ...)) (begin - (define-struct id+par (field-id ...) #:prefab) + (define-struct id+par (field-id ...)) #;(provide (struct-out id)) (provide/contract [struct id ([field-id field-contract] ...)]))) From 46f22d28829a8131e4419be62d1d1b140f3d1bf7 Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Tue, 24 Aug 2010 17:28:00 -0600 Subject: [PATCH 29/60] handling closures while writing symbol table original commit: c2fee2a2f078bcff4256d1ccb0ed8f99c9447cf2 --- collects/compiler/zo-marshal.rkt | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index a34d4c6445..444afc38db 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -38,7 +38,7 @@ (define (shared-obj-pos v) (hash-ref shared v #f)) (define (share! v) - (or (hash-ref shared v #f) + (or (shared-obj-pos v) (let ([pos (add1 (hash-count shared))]) (hash-set! shared v pos) pos))) @@ -70,8 +70,8 @@ (list* max-let-depth prefix (protect-quote form))])) (out-anything ct (make-out outp shared-obj-pos wrapped)) (file-position outp)) + (define-values (symbol-table shared-obj-pos) (create-symbol-table out-compilation-top)) - ; 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 @@ -79,7 +79,7 @@ (define (shared-obj-pos/modulo-v v) (define skip? #t) (λ (v2) - (if (and skip? (eq? v v2)) + (if (and skip? (eq? v v2) (not (closure? v2))) (begin (set! skip? #f) #f) @@ -102,6 +102,7 @@ (define version-bs (string->bytes/latin-1 (version))) (write-bytes (bytes (bytes-length version-bs)) outp) (write-bytes version-bs outp) + ; Write the symbol table information (size, offsets) (define symtabsize (add1 (vector-length symbol-table))) From a5f557b90e214eeb435b20230f9cee8c24f6c59c Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Wed, 25 Aug 2010 17:25:10 -0600 Subject: [PATCH 30/60] zo-marshal fixes and switching back to prefabs original commit: ecc9ceb842fc928615d5c59273feee799b285d4b --- collects/compiler/zo-marshal.rkt | 100 ++++++++++++++++------------- collects/compiler/zo-structs.rkt | 10 ++- collects/tests/compiler/zo-exs.rkt | 23 +++++++ 3 files changed, 87 insertions(+), 46 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 444afc38db..67e44567d4 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -10,8 +10,7 @@ racket/dict racket/function racket/pretty - racket/path - racket/set) + racket/path) (provide/contract [zo-marshal (compilation-top? . -> . bytes?)] @@ -24,36 +23,8 @@ (zo-marshal-to top bs) (get-output-bytes bs)) -; ((obj -> (or pos #f)) output-port -> number) -> 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 out-compilation-top) - (define encountered (make-hash)) - (define shared (make-hash)) - (define (encountered? v) - (hash-ref encountered v #f)) - (define (encounter! v) - (hash-set! encountered v #t) - #f) - (define (shared-obj-pos v) - (hash-ref shared v #f)) - (define (share! v) - (or (shared-obj-pos v) - (let ([pos (add1 (hash-count shared))]) - (hash-set! shared v pos) - pos))) - - (out-compilation-top - (λ (v) - (if (or (closure? v) - (encountered? v)) - (share! v) - (encounter! 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 (got-here n) + (void) #;(printf "got here: ~a~n" n)) (define (zo-marshal-to top outp) @@ -71,14 +42,51 @@ (out-anything ct (make-out outp shared-obj-pos wrapped)) (file-position outp)) - (define-values (symbol-table shared-obj-pos) (create-symbol-table out-compilation-top)) + ; -> 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-hash)) + (define shared (make-hash)) + (define (encountered? v) + (hash-ref encountered v #f)) + (define (encounter! v) + (hash-set! encountered v #t) + #f) + (define (shared-obj-pos v #:share [share? #t]) + (hash-ref shared v #f)) + (define (share! v) + (or (shared-obj-pos v) + (let ([pos (add1 (hash-count shared))]) + (hash-set! shared v pos) + pos))) + + (out-compilation-top + (λ (v #:share [share? #t]) + (and share? + (if (or (closure? v) + (encountered? v)) + (share! v) + (encounter! 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)) + + (got-here 1) + (define-values (symbol-table shared-obj-pos) (create-symbol-table)) + (got-here 2) + #;(for ([v (in-vector symbol-table)]) + (printf "v = ~a~n" v)) + ; 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) + (λ (v2 #:share [share? #t]) (if (and skip? (eq? v v2) (not (closure? v2))) (begin (set! skip? #f) @@ -94,7 +102,9 @@ ; Calculate file positions (define counting-port (open-output-nowhere)) (define-values (offsets post-shared) (out-symbol-table symbol-table counting-port)) + (got-here 3) (define all-forms-length (out-compilation-top shared-obj-pos counting-port)) + (got-here 4) ; Write the compiled form header (write-bytes #"#~" outp) @@ -115,10 +125,12 @@ (write-bytes (int->bytes post-shared) outp) ; This is where the file should end (write-bytes (int->bytes all-forms-length) outp) - + (got-here 5) ; Actually write the zo (out-symbol-table symbol-table outp) + (got-here 6) (out-compilation-top shared-obj-pos outp) + (got-here 7) (void)) ;; ---------------------------------------- @@ -430,7 +442,7 @@ (define quoting? (make-parameter #f)) (define (shareable? v) - (not (or quoting? (or-pred? v char? maybe-same-as-fixnum? empty? boolean? void?)))) + (not (or (quoting?) (or-pred? v char? maybe-same-as-fixnum? empty? boolean? void?)))) (define (maybe-same-as-fixnum? v) (and (exact-integer? v) @@ -631,7 +643,9 @@ (begin (out-byte CPT_APPLICATION out) (out-number len out))) - (for-each (lambda (e) (out-anything (protect-quote e) out)) + (for-each (lambda (e) + #;(printf "here: ~a~n" e) + (out-anything (protect-quote e) out)) (cons rator rands)))] [(struct apply-values (proc args-expr)) (out-syntax APPVALS_EXPD @@ -693,14 +707,14 @@ (out-anything (unbox v) out)] [(? pair?) (define (list-length-before-cycle/improper-end l) - (let loop ([len 1] [l (cdr l)] [seen (set)]) + (let loop ([len 1] [l (cdr l)]) (cond - [(set-member? seen l) + [((out-shared-index out) l #:share #f) (values len #f)] [(null? l) (values len #t)] [(pair? l) - (loop (add1 len) (cdr l) (set-add seen l))] + (loop (add1 len) (cdr l))] [else (values len #f)]))) (define-values (len proper?) (list-length-before-cycle/improper-end v)) @@ -740,7 +754,7 @@ (out-number (cond [(hash-eqv? v) 2] [(hash-eq? v) 0] - [else 1]) + [(hash-equal? v) 1]) out) (out-number (hash-count v) out) (for ([(k v) (in-hash v)]) @@ -891,7 +905,7 @@ (define (lookup-encoded-wrapped w out) - (hash-ref (out-encoded-wraps out) w + (hash-ref! (out-encoded-wraps out) w (λ () (encode-wrapped w)))) @@ -955,7 +969,7 @@ (define-struct quoted (v)) (define (protect-quote v) - (if (or (pair? v) (vector? v) (prefab-struct-key v) (box? v) (hash? v) (svector? v)) + (if (or (pair? v) (vector? v) (and (not zo?) (prefab-struct-key v)) (box? v) (hash? v) (svector? v)) (make-quoted v) v)) diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index cbb987a5fa..acb2476831 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -22,17 +22,20 @@ (define-syntax-rule (define-form-struct* id id+par ([field-id field-contract] ...)) (begin - (define-struct id+par (field-id ...)) + (define-struct id+par (field-id ...) #:prefab) #;(provide (struct-out id)) (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 @@ -77,7 +80,8 @@ (define-form-struct (expr form) ()) ;; A static closure can refer directly to itself, creating a cycle -(define-struct indirect ([v #:mutable]) #:prefab) +; XXX: this might not be needed anymore with the current sharing model +(define-struct (indirect zo) ([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 diff --git a/collects/tests/compiler/zo-exs.rkt b/collects/tests/compiler/zo-exs.rkt index c46e7fd7e6..872d025b5a 100644 --- a/collects/tests/compiler/zo-exs.rkt +++ b/collects/tests/compiler/zo-exs.rkt @@ -17,8 +17,31 @@ (define mpi (module-path-index-join #f #f)) + (test + #;(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) + (gensym))]) + (placeholder-set! ph x) + (make-reader-graph x)))) + + #;(roundtrip (compilation-top 0 (prefix 0 (list #f) (list)) From b8fe95cd26c4320df22cb6b02941208ee7ecdb5a Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Fri, 27 Aug 2010 15:36:45 -0600 Subject: [PATCH 31/60] fixing closure problem original commit: 2dfaab00f4d3a02315c9048456d3c9993be6f4c1 --- collects/compiler/zo-marshal.rkt | 2 +- collects/compiler/zo-parse.rkt | 14 +-- collects/tests/compiler/zo-exs.rkt | 142 ++++++++++++++--------------- 3 files changed, 80 insertions(+), 78 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 67e44567d4..83e629ee4e 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -87,7 +87,7 @@ (define (shared-obj-pos/modulo-v v) (define skip? #t) (λ (v2 #:share [share? #t]) - (if (and skip? (eq? v v2) (not (closure? v2))) + (if (and skip? (eq? v v2) #;(not (closure? v2))) (begin (set! skip? #f) #f) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 5e195c90a7..28d0bd4ac5 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -941,12 +941,14 @@ [ind (make-indirect #f)]) (symtab-write! 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]))))]) + [cl (make-closure v + ; XXX Why call gensym here? + (gensym + (let ([s (lam-name v)]) + (cond + [(symbol? s) s] + [(vector? s) (vector-ref s 0)] + [else 'closure]))))]) (set-indirect-v! ind cl) ind))] [(svector) diff --git a/collects/tests/compiler/zo-exs.rkt b/collects/tests/compiler/zo-exs.rkt index 872d025b5a..79ab23f1e7 100644 --- a/collects/tests/compiler/zo-exs.rkt +++ b/collects/tests/compiler/zo-exs.rkt @@ -20,86 +20,86 @@ (test #;(roundtrip - (compilation-top 0 - (prefix 0 empty empty) - (list 1 (list 2 3) (list 2 3) 4 5))) + (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) - (gensym))]) + [x (indirect (closure + (lam 'name + empty + 0 + empty + #f + #() + empty + 0 + ph) + 'name))]) (placeholder-set! ph x) (make-reader-graph x)))) - - #;(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 #hasheq() - #hasheq()))) + (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 #hasheq() + #hasheq()))) #;(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) + (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))) From 070d86473db1209fa51cb399821ceb22fa0577b5 Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Thu, 2 Sep 2010 12:30:38 -0600 Subject: [PATCH 32/60] traversing inside closures and using a seen set for lists original commit: 32a9e60abeac894f6587213787bccb8bd72bd0e2 --- collects/compiler/zo-marshal.rkt | 163 +++++++++++++++++++---------- collects/compiler/zo-parse.rkt | 4 + collects/tests/compiler/zo-exs.rkt | 3 +- 3 files changed, 112 insertions(+), 58 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 83e629ee4e..74eabb5f48 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -10,7 +10,8 @@ racket/dict racket/function racket/pretty - racket/path) + racket/path + racket/set) (provide/contract [zo-marshal (compilation-top? . -> . bytes?)] @@ -24,7 +25,8 @@ (get-output-bytes bs)) (define (got-here n) - (void) #;(printf "got here: ~a~n" n)) + (void) + #;(printf "got here: ~a~n" n)) (define (zo-marshal-to top outp) @@ -34,12 +36,12 @@ ; (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 outp) + (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 wrapped)) + (out-anything ct (make-out outp shared-obj-pos shared-obj-unsee wrapped)) (file-position outp)) ; -> vector @@ -49,25 +51,46 @@ (define encountered (make-hash)) (define shared (make-hash)) (define (encountered? v) - (hash-ref encountered v #f)) + ((hash-ref encountered v 0) . > . 0)) (define (encounter! v) - (hash-set! encountered v #t) + (hash-update! encountered v add1 0) #f) - (define (shared-obj-pos v #:share [share? #t]) - (hash-ref shared v #f)) - (define (share! v) + (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]) + (define pos + (hash-ref shared v + (if error? + (λ () (error 'symref "~e not in symbol table" v)) + #f))) + #;(when (closure? v) + (printf "Looking up ~a, got ~a\n" v pos)) + pos) + (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 #:share [share? #t]) - (and share? - (if (or (closure? v) - (encountered? v)) - (share! v) - (encounter! v)))) + (λ (v #:error? [error? #f]) + (cond + [(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))) @@ -75,7 +98,8 @@ (values symbol-table shared-obj-pos)) (got-here 1) - (define-values (symbol-table shared-obj-pos) (create-symbol-table)) + (define-values (symbol-table shared-obj-pos) + (create-symbol-table)) (got-here 2) #;(for ([v (in-vector symbol-table)]) (printf "v = ~a~n" v)) @@ -86,24 +110,27 @@ (define (out-symbol-table symbol-table outp) (define (shared-obj-pos/modulo-v v) (define skip? #t) - (λ (v2 #:share [share? #t]) - (if (and skip? (eq? v v2) #;(not (closure? v2))) + (λ (v2 #:error? [error? #f]) + (if (and skip? (eq? v v2)) (begin (set! skip? #f) #f) - (shared-obj-pos v2)))) + (shared-obj-pos v2 + #:error? error?)))) (values - (for/list ([v (in-vector symbol-table)]) + (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) wrapped)))) + #;(printf "Out ~a -->" i) #;(pretty-print v) + (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)) (got-here 3) - (define all-forms-length (out-compilation-top shared-obj-pos counting-port)) + (define all-forms-length (out-compilation-top shared-obj-pos void counting-port)) (got-here 4) ; Write the compiled form header (write-bytes #"#~" outp) @@ -129,7 +156,7 @@ ; Actually write the zo (out-symbol-table symbol-table outp) (got-here 6) - (out-compilation-top shared-obj-pos outp) + (out-compilation-top shared-obj-pos void outp) (got-here 7) (void)) @@ -390,7 +417,7 @@ (vector p (encode-certs certs)) p))])) -(define-struct out (s shared-index encoded-wraps)) +(define-struct out (s shared-index shared-unsee encoded-wraps)) (define (out-shared v out k) (if (shareable? v) (let ([v ((out-shared-index out) v)]) @@ -438,17 +465,22 @@ (define (or-pred? v . ps) (ormap (lambda (?) (? v)) ps)) - (define quoting? (make-parameter #f)) (define (shareable? v) - (not (or (quoting?) (or-pred? v char? maybe-same-as-fixnum? empty? boolean? void?)))) + (define never-share-this? + (or-pred? v char? maybe-same-as-fixnum? empty? boolean? void?)) + (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 (out-anything v out) (out-shared v out @@ -479,11 +511,13 @@ (unless (zero? phase) (out-number -2 out)) (out-number pos out)] - [(struct indirect (val)) (out-anything val out)] + [(struct indirect (val)) + (out-anything val out)] [(struct closure (lam gen-id)) (out-byte CPT_CLOSURE out) - (out-number ((out-shared-index out) v) out) - (out-anything lam 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 @@ -668,7 +702,7 @@ expr out)] [(protected-symref v) - (out-anything ((out-shared-index out) v) out)] + (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) @@ -706,18 +740,29 @@ (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 1] [l (cdr l)]) + (let loop ([len 0] [l l] [seen (set)]) (cond - [((out-shared-index out) l #:share #f) + [(set-member? seen l) (values len #f)] [(null? l) (values len #t)] [(pair? l) - (loop (add1 len) (cdr 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))) @@ -787,28 +832,33 @@ (vector-set! pre-v 0 (prefab-struct-key v)) (out-byte CPT_PREFAB out) (out-anything pre-v out)] - [else + [(quoted qv) (out-byte CPT_QUOTE out) - (if (quoted? v) - (parameterize ([quoting? #t]) - (out-anything (quoted-v v) out)) - (let ([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) - (let ([bstr (get-output-bytes s)]) - (out-number (bytes-length bstr) out) - (out-bytes bstr 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)])))) (define-struct module-decl (content)) @@ -969,11 +1019,10 @@ (define-struct quoted (v)) (define (protect-quote v) - (if (or (pair? v) (vector? v) (and (not zo?) (prefab-struct-key v)) (box? v) (hash? v) (svector? 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) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 28d0bd4ac5..0b441796c0 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -837,6 +837,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]) diff --git a/collects/tests/compiler/zo-exs.rkt b/collects/tests/compiler/zo-exs.rkt index 79ab23f1e7..c84eac9dc6 100644 --- a/collects/tests/compiler/zo-exs.rkt +++ b/collects/tests/compiler/zo-exs.rkt @@ -27,7 +27,8 @@ (compilation-top 0 (prefix 0 empty empty) (let* ([ph (make-placeholder #f)] - [x (indirect (closure + [x (indirect + (closure (lam 'name empty 0 From 78d5856d4dd7fd204b001edf91081406c4636269 Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Mon, 6 Sep 2010 23:39:05 -0600 Subject: [PATCH 33/60] never sharing hashes and trace debugging original commit: 0d136ba4c774548828cec985d7d89e4769a6a01a --- collects/compiler/zo-marshal.rkt | 26 ++++++++++++++++++++++++-- collects/tests/compiler/zo-exs.rkt | 14 ++++++++++---- 2 files changed, 34 insertions(+), 6 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 74eabb5f48..7b1dbbc9e7 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -77,6 +77,7 @@ (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) @@ -101,6 +102,8 @@ (define-values (symbol-table shared-obj-pos) (create-symbol-table)) (got-here 2) + + #;(printf "symtab[998] = ~a\n" (vector-ref symbol-table 998)) #;(for ([v (in-vector symbol-table)]) (printf "v = ~a~n" v)) @@ -469,7 +472,7 @@ (define (shareable? v) (define never-share-this? - (or-pred? v char? maybe-same-as-fixnum? empty? boolean? void?)) + (or-pred? v char? maybe-same-as-fixnum? empty? boolean? void? hash? )) (define always-share-this? (or-pred? v closure?)) (or always-share-this? @@ -481,7 +484,26 @@ (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) + (with-type-trace v (out-shared v out (λ () @@ -858,7 +880,7 @@ (out-byte CPT_ESCAPE out) (define bstr (get-output-bytes s)) (out-number (bytes-length bstr) out) - (out-bytes bstr out)])))) + (out-bytes bstr out)]))))) (define-struct module-decl (content)) diff --git a/collects/tests/compiler/zo-exs.rkt b/collects/tests/compiler/zo-exs.rkt index c84eac9dc6..a66ed0f39e 100644 --- a/collects/tests/compiler/zo-exs.rkt +++ b/collects/tests/compiler/zo-exs.rkt @@ -23,7 +23,7 @@ (compilation-top 0 (prefix 0 empty empty) (list 1 (list 2 3) (list 2 3) 4 5))) - (roundtrip + #;(roundtrip (compilation-top 0 (prefix 0 empty empty) (let* ([ph (make-placeholder #f)] @@ -84,12 +84,18 @@ (prefix 0 empty empty) (list (current-directory)))) - #;(roundtrip + (roundtrip (compilation-top 0 (prefix 0 empty empty) - (cons #hasheq() - #hasheq()))) + (cons #hash() + #hash()))) + + (roundtrip + (compilation-top + 0 + (prefix 0 empty empty) + #hash())) #;(local [(define (hash-test make-hash-placeholder) (roundtrip From 785033b8806a9986a1abfccf92dd698aeeea85bc Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Wed, 8 Sep 2010 15:27:33 -0600 Subject: [PATCH 34/60] Removing pieces of zo-test-worker we dont care about original commit: e94823b82c0c87227e414466a98c9007b4920d5b --- collects/tests/compiler/zo-test-worker.rkt | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/collects/tests/compiler/zo-test-worker.rkt b/collects/tests/compiler/zo-test-worker.rkt index 0a698fe246..022d661058 100644 --- a/collects/tests/compiler/zo-test-worker.rkt +++ b/collects/tests/compiler/zo-test-worker.rkt @@ -210,8 +210,8 @@ (if serious? (esc #f) #f))]) - e)]) - (record! (success 'step1)) + (begin0 e + (record! (success 'step1))))]) (run/stages* file . rst)))])) (define-syntax-rule (define-stages (run! file) @@ -235,22 +235,22 @@ [compare-parsed-to-parsed-marshalled #f (equal?/why-not parse-orig parse-marshalled)] - [marshal-marshalled + #;[marshal-marshalled #t (zo-marshal parse-marshalled)] - [compare-marshalled-to-marshalled-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 + #;[decompile-parsed #t (decompile parse-orig)] [c-parse-marshalled #t (read-compiled-bytes marshal-parsed)] - [compare-orig-to-marshalled + #;[compare-orig-to-marshalled #f (bytes-not-equal?-error read-orig marshal-parsed)]) @@ -260,7 +260,7 @@ (define (run-test file) (run-with-limit file - (* 1024 1024 128) + (* 1024 1024 1024) (lambda () (run! file))) (write (reverse RESULTS))) From 4d82ab734ed0b280fd74dd77b187f794f5f6dce8 Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Wed, 8 Sep 2010 15:33:04 -0600 Subject: [PATCH 35/60] Changing memory limit original commit: 407a36c9d21dacfb3b6a5649072be96b532f53f5 --- collects/tests/compiler/zo-test-worker.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/tests/compiler/zo-test-worker.rkt b/collects/tests/compiler/zo-test-worker.rkt index 022d661058..e73f0630bb 100644 --- a/collects/tests/compiler/zo-test-worker.rkt +++ b/collects/tests/compiler/zo-test-worker.rkt @@ -260,7 +260,7 @@ (define (run-test file) (run-with-limit file - (* 1024 1024 1024) + (* 1024 1024 512) (lambda () (run! file))) (write (reverse RESULTS))) From 1f08f652826758e5e59a0fb854db9cb898bd8eb1 Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Fri, 10 Sep 2010 12:41:51 -0600 Subject: [PATCH 36/60] removing debugging information original commit: 6338a97e0a05c43d4c97aaefc9278d28e437e62d --- collects/compiler/zo-marshal.rkt | 32 ++++++-------------------------- collects/compiler/zo-parse.rkt | 13 ------------- 2 files changed, 6 insertions(+), 39 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 7b1dbbc9e7..76a5731737 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -24,10 +24,6 @@ (zo-marshal-to top bs) (get-output-bytes bs)) -(define (got-here n) - (void) - #;(printf "got here: ~a~n" n)) - (define (zo-marshal-to top outp) ; XXX: wraps were encoded in traverse, now needs to be handled when writing @@ -60,14 +56,10 @@ (when (= how-many-encounters 1) (hash-set! encountered v 0))) (define (shared-obj-pos v #:error? [error? #f]) - (define pos - (hash-ref shared v - (if error? - (λ () (error 'symref "~e not in symbol table" v)) - #f))) - #;(when (closure? v) - (printf "Looking up ~a, got ~a\n" v pos)) - pos) + (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))]) @@ -83,7 +75,7 @@ (if (encountered? v) pos (encounter! v)))] - #;[error? ; If we would error if this were not present, then we must share it + [error? ; If we would error if this were not present, then we must share it (encounter! v) (share! v)] [(encountered? v) @@ -98,14 +90,8 @@ (hash-map shared (λ (k v) (vector-set! symbol-table (sub1 v) k))) (values symbol-table shared-obj-pos)) - (got-here 1) (define-values (symbol-table shared-obj-pos) (create-symbol-table)) - (got-here 2) - - #;(printf "symtab[998] = ~a\n" (vector-ref symbol-table 998)) - #;(for ([v (in-vector symbol-table)]) - (printf "v = ~a~n" v)) ; vector output-port -> (listof number) number ; writes symbol-table to outp @@ -125,16 +111,14 @@ [i (in-naturals)]) (begin0 (file-position outp) - #;(printf "Out ~a -->" i) #;(pretty-print v) (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)) - (got-here 3) (define all-forms-length (out-compilation-top shared-obj-pos void counting-port)) - (got-here 4) + ; Write the compiled form header (write-bytes #"#~" outp) @@ -155,12 +139,9 @@ (write-bytes (int->bytes post-shared) outp) ; This is where the file should end (write-bytes (int->bytes all-forms-length) outp) - (got-here 5) ; Actually write the zo (out-symbol-table symbol-table outp) - (got-here 6) (out-compilation-top shared-obj-pos void outp) - (got-here 7) (void)) ;; ---------------------------------------- @@ -700,7 +681,6 @@ (out-byte CPT_APPLICATION out) (out-number len out))) (for-each (lambda (e) - #;(printf "here: ~a~n" e) (out-anything (protect-quote e) out)) (cons rator rands)))] [(struct apply-values (proc args-expr)) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 0b441796c0..6a8edd6032 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -32,8 +32,6 @@ ;; ---------------------------------------- ;; Bytecode unmarshalers for various forms -(define debug-symrefs #f) - (define (read-toplevel v) (define SCHEME_TOPLEVEL_CONST #x01) (define SCHEME_TOPLEVEL_READY #x02) @@ -981,8 +979,6 @@ (placeholder-set! (vector-ref (cport-symtab cp) i) v)) (define (symtab-lookup cp i) - (when (mark-parameter-first read-sym-mark) - (dict-update! debug-symrefs (mark-parameter-first read-sym-mark) (λ (last) (cons i last)) empty)) (vector-ref (cport-symtab cp) i)) (require unstable/markparam) @@ -1042,20 +1038,11 @@ (define symtab (build-vector symtabsize (λ (i) (make-placeholder nr)))) - (set! debug-symrefs (make-vector symtabsize empty)) - (define cp (make-cport 0 shared-size port size* rst-start symtab so* (make-vector symtabsize #f) (make-hash) (make-hash))) (for ([i (in-range 1 symtabsize)]) (read-sym cp i)) - #;(for ([i (in-naturals)] - [v (in-vector debug-symrefs)]) - (printf "~a: ~a~n" i v)) - #;(printf "SYMBOL TABLE(~a):~n~n" symtabsize) - #;(for ([i (in-naturals)] - [v (in-vector (cport-symtab cp))]) - (printf "~a: ~s~n~n" i (placeholder-get v))) (set-cport-pos! cp shared-size) (make-reader-graph (read-marshalled 'compilation-top-type cp)))) From 428d1d383d413f9295b67645c45fd024c0932b93 Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Fri, 10 Sep 2010 12:42:34 -0600 Subject: [PATCH 37/60] re-enabling tests original commit: 1cb11ce6cc7ef7d5a7c7d2e3e6c9f1a6cffed4ff --- collects/tests/compiler/zo-exs.rkt | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/collects/tests/compiler/zo-exs.rkt b/collects/tests/compiler/zo-exs.rkt index a66ed0f39e..34ca2e4c2e 100644 --- a/collects/tests/compiler/zo-exs.rkt +++ b/collects/tests/compiler/zo-exs.rkt @@ -19,10 +19,11 @@ (test - #;(roundtrip + (roundtrip (compilation-top 0 (prefix 0 empty empty) (list 1 (list 2 3) (list 2 3) 4 5))) + ; XXX This should work, but closures have a field that is gensym'ed #;(roundtrip (compilation-top 0 (prefix 0 empty empty) @@ -42,6 +43,7 @@ (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 @@ -74,12 +76,12 @@ (toplevel 0 0 #f #f) #(racket/language-info get-info #f) #t))) - #;(roundtrip + (roundtrip (compilation-top 0 (prefix 0 empty empty) (current-directory))) - #;(roundtrip + (roundtrip (compilation-top 0 (prefix 0 empty empty) (list (current-directory)))) From 4c5dfd88af537540123cf34a423ffc203ec980c5 Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Fri, 10 Sep 2010 12:58:56 -0600 Subject: [PATCH 38/60] fixing pr11036 by adding plain certificates original commit: 170ab47dc2bd1fa2232c30f33062ac8e4e0c1a26 --- collects/compiler/zo-marshal.rkt | 4 +++- collects/compiler/zo-parse.rkt | 4 +++- collects/compiler/zo-structs.rkt | 3 +++ 3 files changed, 9 insertions(+), 2 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 76a5731737..e9403b252c 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -356,7 +356,9 @@ [(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))])) + (list* #f (make-protected-symref val) (encode-mark-map m))] + [(struct certificate:plain (m)) + (encode-mark-map m)])) (define (encode-wrapped w) (match w diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 6a8edd6032..e6e677700e 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -524,7 +524,9 @@ (symtab-lookup cp symref) (decode-mark-map alist))] [(list* (? list? nested) alist) - (make-certificate:nest (decode-mark-map nested) (decode-mark-map 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 diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index acb2476831..4aba9f8ded 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -63,6 +63,9 @@ (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] From aa0d3e18aedb681252e10944d32c5bc38b5a1865 Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Fri, 10 Sep 2010 13:51:38 -0600 Subject: [PATCH 39/60] fixing pr11175, added only-rest-arg-not-used flag original commit: 3433af0a3003f86c61cd4e81e53cb8e604b46238 --- collects/compiler/zo-marshal.rkt | 4 +++- collects/compiler/zo-parse.rkt | 7 +++++-- collects/compiler/zo-structs.rkt | 4 ++-- 3 files changed, 10 insertions(+), 5 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index e9403b252c..0e219725fb 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -970,7 +970,9 @@ (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 diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index e6e677700e..cf00f05ce9 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -117,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)) diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index 4aba9f8ded..1e62a623d7 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -135,8 +135,8 @@ [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?)] From be19dcb79d4179a78cb7f465c5f2aea2c1abed7f Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 10 Sep 2010 09:48:53 -0400 Subject: [PATCH 40/60] Use "" instead of a misleading "", improve doc line for `--collect'. original commit: 41812ace0f128f4a7681b8fcb731b04952643f17 --- collects/compiler/commands/pack.rkt | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) 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 From d2ad91ae380c746e70b02d5eac30903123d74f1a Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Thu, 16 Sep 2010 12:13:15 -0600 Subject: [PATCH 41/60] removing indirects from zo handling original commit: c88eb704c7a4894fefecf353a970c877ea5dedf7 --- collects/compiler/decompile.rkt | 7 --- collects/compiler/zo-marshal.rkt | 2 - collects/compiler/zo-parse.rkt | 42 ++++++++--------- collects/compiler/zo-structs.rkt | 52 ++++++++++------------ collects/tests/compiler/zo-test-worker.rkt | 2 +- 5 files changed, 45 insertions(+), 60 deletions(-) diff --git a/collects/compiler/decompile.rkt b/collects/compiler/decompile.rkt index b592d15776..4af6bb5d08 100644 --- a/collects/compiler/decompile.rkt +++ b/collects/compiler/decompile.rkt @@ -160,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) @@ -288,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/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 0e219725fb..afd0a0b084 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -516,8 +516,6 @@ (unless (zero? phase) (out-number -2 out)) (out-number pos out)] - [(struct indirect (val)) - (out-anything val out)] [(struct closure (lam gen-id)) (out-byte CPT_CLOSURE out) (let ([pos ((out-shared-index out) v #:error? #t)]) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index cf00f05ce9..32d98ef065 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -348,9 +348,9 @@ (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 @@ -732,6 +732,9 @@ (define (parse-module-path-index cp s) s) + +(define (error-when-false v) + (or v (error "app rator is false"))) ;; ---------------------------------------- ;; Main parsing loop @@ -927,7 +930,7 @@ [(small-marshalled) (read-marshalled (- ch cpt-start) cp)] [(small-application2) - (make-application (read-compact cp) + (make-application (error-when-false (read-compact cp)) (list (read-compact cp)))] [(small-application3) (make-application (read-compact cp) @@ -935,29 +938,26 @@ (read-compact cp)))] [(small-application) (let ([c (add1 (- ch cpt-start))]) - (make-application (read-compact cp) + (make-application (error-when-false (read-compact cp)) (for/list ([i (in-range (sub1 c))]) (read-compact cp))))] [(application) (let ([c (read-compact-number cp)]) - (make-application (read-compact cp) + (make-application (error-when-false (read-compact cp)) (for/list ([i (in-range c)]) (read-compact cp))))] - [(closure) ; XXX The use of indirect may be an artifact from pre-placeholder days - (let* ([l (read-compact-number cp)] - [ind (make-indirect #f)]) - (symtab-write! cp l ind) - (let* ([v (read-compact cp)] - [cl (make-closure v - ; XXX Why call gensym here? - (gensym - (let ([s (lam-name v)]) - (cond - [(symbol? s) s] - [(vector? s) (vector-ref s 0)] - [else 'closure]))))]) - (set-indirect-v! ind cl) - ind))] + [(closure) + (read-compact-number cp) ; symbol table pos. our marshaler will generate this + (let ([v (read-compact cp)]) + (make-closure + v + ; XXX Why call gensym here? + (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) diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index 1e62a623d7..d3933aa349 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -82,11 +82,7 @@ (define-form-struct form ()) (define-form-struct (expr form) ()) -;; A static closure can refer directly to itself, creating a cycle -; XXX: this might not be needed anymore with the current sharing model -(define-struct (indirect zo) ([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?] @@ -102,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?])) @@ -125,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?))] @@ -142,35 +138,35 @@ [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' @@ -245,8 +241,6 @@ ; 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/tests/compiler/zo-test-worker.rkt b/collects/tests/compiler/zo-test-worker.rkt index e73f0630bb..8442fb74f6 100644 --- a/collects/tests/compiler/zo-test-worker.rkt +++ b/collects/tests/compiler/zo-test-worker.rkt @@ -232,7 +232,7 @@ [parse-marshalled #t (zo-parse/bytes marshal-parsed)] - [compare-parsed-to-parsed-marshalled + #;[compare-parsed-to-parsed-marshalled #f (equal?/why-not parse-orig parse-marshalled)] #;[marshal-marshalled From 4830a2d141b3e6ae369c695e61a8ae789ef3133a Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 16 Sep 2010 12:45:23 -0600 Subject: [PATCH 42/60] Removing debugging aid original commit: 089e99fac65b3d408041423742adfab0737f202d --- collects/compiler/zo-parse.rkt | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 32d98ef065..000c4efc35 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -733,8 +733,6 @@ (define (parse-module-path-index cp s) s) -(define (error-when-false v) - (or v (error "app rator is false"))) ;; ---------------------------------------- ;; Main parsing loop @@ -930,7 +928,7 @@ [(small-marshalled) (read-marshalled (- ch cpt-start) cp)] [(small-application2) - (make-application (error-when-false (read-compact cp)) + (make-application (read-compact cp) (list (read-compact cp)))] [(small-application3) (make-application (read-compact cp) @@ -938,12 +936,12 @@ (read-compact cp)))] [(small-application) (let ([c (add1 (- ch cpt-start))]) - (make-application (error-when-false (read-compact cp)) + (make-application (read-compact cp) (for/list ([i (in-range (sub1 c))]) (read-compact cp))))] [(application) (let ([c (read-compact-number cp)]) - (make-application (error-when-false (read-compact cp)) + (make-application (read-compact cp) (for/list ([i (in-range c)]) (read-compact cp))))] [(closure) From 52163c7f17a836b429620a6d360a60c492e6a6e5 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 19 Oct 2010 15:53:03 -0700 Subject: [PATCH 43/60] Describing architecture a little original commit: 039fc7095addf7670631e0d0e4923b6feeea06f4 --- collects/meta/drdr2/analyzer/analyzer.rkt | 1 + collects/meta/drdr2/master/master.rkt | 1 + 2 files changed, 2 insertions(+) create mode 100644 collects/meta/drdr2/analyzer/analyzer.rkt create mode 100644 collects/meta/drdr2/master/master.rkt 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 From 1f2e1c66473055e378efea4878988bf88ba9b384 Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Tue, 21 Sep 2010 12:20:29 -0600 Subject: [PATCH 44/60] moved demodularizer from github to collects and added it to raco original commit: 4676662e4b25f2c43433289433932523bd5c00aa --- collects/compiler/demodularizer/alpha.rkt | 19 ++ collects/compiler/demodularizer/batch.rkt | 127 ++++++++ .../compiler/demodularizer/gc-toplevels.rkt | 275 ++++++++++++++++++ collects/compiler/demodularizer/merge.rkt | 165 +++++++++++ collects/compiler/demodularizer/module.rkt | 35 +++ collects/compiler/demodularizer/mpi.rkt | 30 ++ collects/compiler/demodularizer/nodep.rkt | 178 ++++++++++++ .../demodularizer/update-toplevels.rkt | 97 ++++++ collects/compiler/demodularizer/util.rkt | 56 ++++ 9 files changed, 982 insertions(+) create mode 100644 collects/compiler/demodularizer/alpha.rkt create mode 100644 collects/compiler/demodularizer/batch.rkt create mode 100644 collects/compiler/demodularizer/gc-toplevels.rkt create mode 100644 collects/compiler/demodularizer/merge.rkt create mode 100644 collects/compiler/demodularizer/module.rkt create mode 100644 collects/compiler/demodularizer/mpi.rkt create mode 100644 collects/compiler/demodularizer/nodep.rkt create mode 100644 collects/compiler/demodularizer/update-toplevels.rkt create mode 100644 collects/compiler/demodularizer/util.rkt 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..b8e70bb143 --- /dev/null +++ b/collects/compiler/demodularizer/batch.rkt @@ -0,0 +1,127 @@ +#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 + "util.rkt" + "nodep.rkt" + "merge.rkt" + "gc-toplevels.rkt" + "alpha.rkt" + "module.rkt" + compiler/decompile + compiler/zo-marshal + racket/set) + +(define excluded-modules (make-parameter (set))) +(define file-to-batch + (command-line #:program "batch" + #:multi + [("-e" "--exclude-modules") mod + "Exclude a module from being batched" + (excluded-modules (set-add (excluded-modules) mod))] + #:args (filename) filename)) + +(define-values (base name dir?) (split-path file-to-batch)) +(when (or (eq? base #f) dir?) + (error 'batch "Cannot run on directory")) + + +;; Compile +#;(eprintf "Removing existing zo file~n") +#;(define compiled-zo-path (build-compiled-path base (path-add-suffix name #".zo"))) + +#;(when (file-exists? compiled-zo-path) + (delete-file compiled-zo-path)) + +(eprintf "Compiling module~n") +(void (system* (find-executable-path "raco") "make" file-to-batch)) + + +(define merged-source-path (path-add-suffix file-to-batch #".merged.rkt")) +(define-values (merged-source-base merged-source-name _1) (split-path merged-source-path)) +(define merged-zo-path (build-compiled-path merged-source-base (path-add-suffix merged-source-name #".zo"))) + +;; Transformations +(eprintf "Removing dependencies~n") +(define-values (batch-nodep top-lang-info top-self-modidx) + (nodep-file file-to-batch (excluded-modules))) + +(eprintf "Merging modules~n") +(define batch-merge + (merge-compilation-top batch-nodep)) + +(eprintf "GC-ing top-levels~n") +(define batch-gcd + (gc-toplevels batch-merge)) + +(eprintf "Alpha-varying top-levels~n") +(define batch-alpha + (alpha-vary-ctop batch-gcd)) + +(define batch-modname + (string->symbol (regexp-replace #rx"\\.rkt$" (path->string merged-source-name) ""))) +(eprintf "Modularizing into ~a~n" batch-modname) +(define batch-mod + (wrap-in-kernel-module batch-modname batch-modname top-lang-info top-self-modidx batch-alpha)) + +;; Output +(define batch-final batch-mod) + +(eprintf "Writing merged source~n") +(with-output-to-file + merged-source-path + (lambda () + (pretty-print (decompile batch-final))) + #:exists 'replace) + +(eprintf "Writing merged zo~n") +(void + (with-output-to-file + merged-zo-path + (lambda () + (write-bytes (zo-marshal batch-final))) + #:exists 'replace)) + +(eprintf "Running merged source~n") +(void (system* (find-executable-path "racket") (path->string merged-source-path))) + + + diff --git a/collects/compiler/demodularizer/gc-toplevels.rkt b/collects/compiler/demodularizer/gc-toplevels.rkt new file mode 100644 index 0000000000..df1d027969 --- /dev/null +++ b/collects/compiler/demodularizer/gc-toplevels.rkt @@ -0,0 +1,275 @@ +#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)) + (eprintf "Total TLS: ~S~n" (length normal-tls)) + (eprintf "Used TLS: ~S~n" normal-tls) + (eprintf "Total lifts: ~S~n" (length lifts)) + (eprintf "Used lifts: ~S~n" lifts) + (eprintf "Total stxs: ~S~n" (length stxs)) + (eprintf "Used stxs: ~S~n" 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 build-graph!** (build-form-memo build-graph!* #:void? #t)) + (define (build-graph! lhs form) (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 update + (build-form-memo inner-update)) + 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..33187add17 --- /dev/null +++ b/collects/compiler/demodularizer/merge.rkt @@ -0,0 +1,165 @@ +#lang racket +(require compiler/zo-parse + "util.rkt" + "mpi.rkt" + "nodep.rkt" + "update-toplevels.rkt") + +(define MODULE-TOPLEVEL-OFFSETS (make-hash)) + +(define (merge-compilation-top top) + (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)) + (eprintf "max-let-depth ~S to ~S~n" max-let-depth new-max-let-depth) + (eprintf "total toplevels ~S~n" total-tls) + (eprintf "total stxs ~S~n" total-stxs) + (eprintf "num-lifts ~S~n" 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)) + (eprintf "Rewriting ~a of ~S~n" 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 (get-modvar-rewrite modidx)) + (unless (or (not phase) (zero? phase)) + (error 'eliminate-module-variables "Non-zero phases not supported: ~S" mv)) + (cond + ; Primitive module like #%paramz + [(symbol? rw) + (eprintf "~S from ~S~n" 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))]))) + (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 toplevel-offset) + (unless (= (length toplevel-remap) + (length mod-toplevels)) + (error 'merge-module "Not remapping everything: ~S ~S~n" + mod-toplevels toplevel-remap)) + (eprintf "[~S] Incrementing toplevels by ~a~n" + name + toplevel-offset) + (eprintf "[~S] Incrementing lifts by ~a~n" + name + lift-offset) + (eprintf "[~S] Filtered mod-vars from ~a to ~a~n" + 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) + (eprintf "[~S] Updating top-levels\n" 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 (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..74d7ccd77b --- /dev/null +++ b/collects/compiler/demodularizer/module.rkt @@ -0,0 +1,35 @@ +#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..ae86a43832 --- /dev/null +++ b/collects/compiler/demodularizer/mpi.rkt @@ -0,0 +1,30 @@ +#lang scheme +(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-hash)) +(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~n" mpi)))) + +(provide/contract + [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..f6878c2c0d --- /dev/null +++ b/collects/compiler/demodularizer/nodep.rkt @@ -0,0 +1,178 @@ +#lang racket +(require compiler/zo-parse + "util.rkt" + "mpi.rkt" + racket/set) + +(define excluded-modules (make-parameter null)) + +(define (nodep-file file-to-batch excluded) + (excluded-modules excluded) + (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))])) + +(define (path->comp-top pth) + (call-with-input-file pth zo-parse)) + +(define (excluded? pth) + (set-member? (excluded-modules) (path->string pth))) + +(define MODULE-IDX-MAP (make-hash)) +(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 (get-modvar-rewrite modidx) + (define pth (mpi->path* modidx)) + (hash-ref MODULE-IDX-MAP pth + (lambda () + (error 'get-modvar-rewrite "Cannot locate modvar rewrite for ~S" pth)))) + +(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 PHASE*MODULE-CACHE (make-hash)) +(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 + (fprintf (current-error-port) "Load ~S @ ~S~n" 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) + (eprintf "Looking up ~S@~a~n" 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)) + (eprintf "[~S] module-variables: ~S~n" 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 (eprintf "[~S] lang-info : ~S~n" 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 (eprintf "[~S] Dropping module @ ~S~n" 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~n" ct)])) + +(provide/contract + [struct modvar-rewrite + ([modidx module-path-index?] + [provide->toplevel (symbol? exact-nonnegative-integer? . -> . exact-nonnegative-integer?)])] + [get-modvar-rewrite (module-path-index? . -> . (or/c symbol? modvar-rewrite? module-path-index?))] + [nodep-file (path-string? set? . -> . (values compilation-top? lang-info/c module-path-index?))]) \ No newline at end of file diff --git a/collects/compiler/demodularizer/update-toplevels.rkt b/collects/compiler/demodularizer/update-toplevels.rkt new file mode 100644 index 0000000000..701b4475d8 --- /dev/null +++ b/collects/compiler/demodularizer/update-toplevels.rkt @@ -0,0 +1,97 @@ +#lang racket +(require compiler/zo-parse + "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 update + (build-form-memo inner-update)) + 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..7f8c653049 --- /dev/null +++ b/collects/compiler/demodularizer/util.rkt @@ -0,0 +1,56 @@ +#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)) + +(define (build-form-memo inner-update #:void? [void? #f]) + (define memo (make-hasheq)) + (define (update form . args) + (cond + [(hash-ref memo form #f) + => (λ (x) x)] + [else + (let () + (define ph (make-placeholder #f)) + (hash-set! memo form ph) + (define nv (apply inner-update form args)) + (placeholder-set! ph nv) + nv)])) + (define (first-update form . args) + (define final (apply update form args)) + (make-reader-graph final)) + first-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?) + . ->* . + (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 From e0e144e210507e19d204b6c2af0657e9de77a922 Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Fri, 24 Sep 2010 12:49:52 -0600 Subject: [PATCH 45/60] changed eprintfs to log-debug original commit: 3ddda200e80d48ee5bc17c64b5f0ae4f85b0d1c1 --- collects/compiler/commands/info.rkt | 3 ++- collects/compiler/demodularizer/batch.rkt | 20 +++++++------- .../compiler/demodularizer/gc-toplevels.rkt | 12 ++++----- collects/compiler/demodularizer/merge.rkt | 26 +++++++++---------- collects/compiler/demodularizer/nodep.rkt | 10 +++---- 5 files changed, 35 insertions(+), 36 deletions(-) diff --git a/collects/compiler/commands/info.rkt b/collects/compiler/commands/info.rkt index 9a3106d696..41b92c0eae 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) + ("demod" compiler/demodularizer/batch "produce a whole program from a single module" #f))) diff --git a/collects/compiler/demodularizer/batch.rkt b/collects/compiler/demodularizer/batch.rkt index b8e70bb143..1c685d67ba 100644 --- a/collects/compiler/demodularizer/batch.rkt +++ b/collects/compiler/demodularizer/batch.rkt @@ -65,13 +65,13 @@ Here's the idea: ;; Compile -#;(eprintf "Removing existing zo file~n") +#;(log-debug "Removing existing zo file~n") #;(define compiled-zo-path (build-compiled-path base (path-add-suffix name #".zo"))) #;(when (file-exists? compiled-zo-path) (delete-file compiled-zo-path)) -(eprintf "Compiling module~n") +(log-debug "Compiling module~n") (void (system* (find-executable-path "raco") "make" file-to-batch)) @@ -80,39 +80,39 @@ Here's the idea: (define merged-zo-path (build-compiled-path merged-source-base (path-add-suffix merged-source-name #".zo"))) ;; Transformations -(eprintf "Removing dependencies~n") +(log-debug "Removing dependencies~n") (define-values (batch-nodep top-lang-info top-self-modidx) (nodep-file file-to-batch (excluded-modules))) -(eprintf "Merging modules~n") +(log-debug "Merging modules~n") (define batch-merge (merge-compilation-top batch-nodep)) -(eprintf "GC-ing top-levels~n") +(log-debug "GC-ing top-levels~n") (define batch-gcd (gc-toplevels batch-merge)) -(eprintf "Alpha-varying top-levels~n") +(log-debug "Alpha-varying top-levels~n") (define batch-alpha (alpha-vary-ctop batch-gcd)) (define batch-modname (string->symbol (regexp-replace #rx"\\.rkt$" (path->string merged-source-name) ""))) -(eprintf "Modularizing into ~a~n" batch-modname) +(log-debug (format "Modularizing into ~a~n" batch-modname)) (define batch-mod (wrap-in-kernel-module batch-modname batch-modname top-lang-info top-self-modidx batch-alpha)) ;; Output (define batch-final batch-mod) -(eprintf "Writing merged source~n") +(log-debug "Writing merged source~n") (with-output-to-file merged-source-path (lambda () (pretty-print (decompile batch-final))) #:exists 'replace) -(eprintf "Writing merged zo~n") +(log-debug "Writing merged zo~n") (void (with-output-to-file merged-zo-path @@ -120,8 +120,6 @@ Here's the idea: (write-bytes (zo-marshal batch-final))) #:exists 'replace)) -(eprintf "Running merged source~n") -(void (system* (find-executable-path "racket") (path->string merged-source-path))) diff --git a/collects/compiler/demodularizer/gc-toplevels.rkt b/collects/compiler/demodularizer/gc-toplevels.rkt index df1d027969..d0b4ddbcba 100644 --- a/collects/compiler/demodularizer/gc-toplevels.rkt +++ b/collects/compiler/demodularizer/gc-toplevels.rkt @@ -41,12 +41,12 @@ (index<=? stx-pos ordered-stxs)) (prefix-syntax-start new-prefix)) form)) - (eprintf "Total TLS: ~S~n" (length normal-tls)) - (eprintf "Used TLS: ~S~n" normal-tls) - (eprintf "Total lifts: ~S~n" (length lifts)) - (eprintf "Used lifts: ~S~n" lifts) - (eprintf "Total stxs: ~S~n" (length stxs)) - (eprintf "Used stxs: ~S~n" ordered-stxs) + (log-debug (format "Total TLS: ~S~n" (length normal-tls))) + (log-debug (format "Used TLS: ~S~n" normal-tls)) + (log-debug (format "Total lifts: ~S~n" (length lifts))) + (log-debug (format "Used lifts: ~S~n" lifts)) + (log-debug (format "Total stxs: ~S~n" (length stxs))) + (log-debug (format "Used stxs: ~S~n" ordered-stxs)) (make-compilation-top max-let-depth new-prefix diff --git a/collects/compiler/demodularizer/merge.rkt b/collects/compiler/demodularizer/merge.rkt index 33187add17..7163de96d2 100644 --- a/collects/compiler/demodularizer/merge.rkt +++ b/collects/compiler/demodularizer/merge.rkt @@ -15,10 +15,10 @@ (define total-tls (length (prefix-toplevels new-prefix))) (define total-stxs (length (prefix-stxs new-prefix))) (define total-lifts (prefix-num-lifts new-prefix)) - (eprintf "max-let-depth ~S to ~S~n" max-let-depth new-max-let-depth) - (eprintf "total toplevels ~S~n" total-tls) - (eprintf "total stxs ~S~n" total-stxs) - (eprintf "num-lifts ~S~n" total-lifts) + (log-debug (format "max-let-depth ~S to ~S~n" max-let-depth new-max-let-depth)) + (log-debug (format "total toplevels ~S~n" total-tls)) + (log-debug (format "total stxs ~S~n" total-stxs)) + (log-debug (format "num-lifts ~S~n" total-lifts)) (make-compilation-top new-max-let-depth new-prefix (make-splice (gen-new-forms new-prefix)))] @@ -60,7 +60,7 @@ [(struct module-variable (modidx sym pos phase)) (match rw [(struct modvar-rewrite (self-modidx provide->toplevel)) - (eprintf "Rewriting ~a of ~S~n" pos (mpi->path* modidx)) + (log-debug (format "Rewriting ~a of ~S~n" pos (mpi->path* modidx))) (+ (hash-ref MODULE-TOPLEVEL-OFFSETS self-modidx (lambda () (error 'compute-new-modvar "toplevel offset not yet computed: ~S" self-modidx))) @@ -81,7 +81,7 @@ (cond ; Primitive module like #%paramz [(symbol? rw) - (eprintf "~S from ~S~n" sym rw) + (log-debug (format "~S from ~S~n" sym rw)) (values (add1 i) (list* tl new-toplevels) (list* (+ i toplevel-offset) remap))] @@ -124,20 +124,20 @@ (length mod-toplevels)) (error 'merge-module "Not remapping everything: ~S ~S~n" mod-toplevels toplevel-remap)) - (eprintf "[~S] Incrementing toplevels by ~a~n" + (log-debug (format "[~S] Incrementing toplevels by ~a~n" name - toplevel-offset) - (eprintf "[~S] Incrementing lifts by ~a~n" + toplevel-offset)) + (log-debug (format "[~S] Incrementing lifts by ~a~n" name - lift-offset) - (eprintf "[~S] Filtered mod-vars from ~a to ~a~n" + lift-offset)) + (log-debug (format "[~S] Filtered mod-vars from ~a to ~a~n" name (length mod-toplevels) - (length new-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) - (eprintf "[~S] Updating top-levels\n" name) + (log-debug (format "[~S] Updating top-levels\n" 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)) diff --git a/collects/compiler/demodularizer/nodep.rkt b/collects/compiler/demodularizer/nodep.rkt index f6878c2c0d..54507f2365 100644 --- a/collects/compiler/demodularizer/nodep.rkt +++ b/collects/compiler/demodularizer/nodep.rkt @@ -57,7 +57,7 @@ (current-directory))) (define-values (modvar-rewrite lang-info ctop) (begin - (fprintf (current-error-port) "Load ~S @ ~S~n" pth phase) + (log-debug (format "Load ~S @ ~S~n" pth phase)) (nodep/dir (parameterize ([current-load-relative-directory base-directory]) (path->comp-top @@ -98,7 +98,7 @@ (when (symbol? tl) (hash-set! provide-ht (intern tl) i))) (lambda (sym pos) - (eprintf "Looking up ~S@~a~n" sym pos) + (log-debug (format "Looking up ~S@~a~n" sym pos)) (hash-ref provide-ht (intern sym) (lambda () (error 'provide->toplevel "Cannot find ~S in ~S" sym prefix))))) @@ -114,15 +114,15 @@ [tl (void)]) (prefix-toplevels new-prefix)) - (eprintf "[~S] module-variables: ~S~n" name (length (filter module-variable? (prefix-toplevels new-prefix)))) + (log-debug (format "[~S] module-variables: ~S~n" 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 (eprintf "[~S] lang-info : ~S~n" name lang-info) ; XXX Seems to always be #f now + (begin (log-debug (format "[~S] lang-info : ~S~n" 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 (eprintf "[~S] Dropping module @ ~S~n" name phase) + (begin (log-debug (format "[~S] Dropping module @ ~S~n" name phase)) empty))))] [else (error 'nodep-module "huh?: ~e" mod-form)])) From 7aac10e9380866070c976fca006a993b4da92583 Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Mon, 27 Sep 2010 15:58:54 -0600 Subject: [PATCH 46/60] offset calculation fix original commit: d84b78daab089923de0fc6a9f0e86e1fc838278f --- collects/compiler/demodularizer/batch.rkt | 3 +- .../compiler/demodularizer/gc-toplevels.rkt | 9 ++-- collects/compiler/demodularizer/merge.rkt | 10 ++-- .../demodularizer/update-toplevels.rkt | 6 +-- collects/compiler/demodularizer/util.rkt | 50 ++++++++++++++----- collects/compiler/zo-marshal.rkt | 7 +-- 6 files changed, 58 insertions(+), 27 deletions(-) diff --git a/collects/compiler/demodularizer/batch.rkt b/collects/compiler/demodularizer/batch.rkt index 1c685d67ba..001fb30d53 100644 --- a/collects/compiler/demodularizer/batch.rkt +++ b/collects/compiler/demodularizer/batch.rkt @@ -90,7 +90,8 @@ Here's the idea: (log-debug "GC-ing top-levels~n") (define batch-gcd - (gc-toplevels batch-merge)) + batch-merge + #;(gc-toplevels batch-merge)) (log-debug "Alpha-varying top-levels~n") (define batch-alpha diff --git a/collects/compiler/demodularizer/gc-toplevels.rkt b/collects/compiler/demodularizer/gc-toplevels.rkt index d0b4ddbcba..a016720caa 100644 --- a/collects/compiler/demodularizer/gc-toplevels.rkt +++ b/collects/compiler/demodularizer/gc-toplevels.rkt @@ -134,8 +134,9 @@ (void)] [(and v (not (? form?))) (void)])) - (define build-graph!** (build-form-memo build-graph!* #:void? #t)) - (define (build-graph! lhs form) (build-graph!** form lhs)) + (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) @@ -267,9 +268,9 @@ [(and v (not (? form?))) v] )) - (define update + (define-values (first-update update) (build-form-memo inner-update)) - 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 index 7163de96d2..a6d944d722 100644 --- a/collects/compiler/demodularizer/merge.rkt +++ b/collects/compiler/demodularizer/merge.rkt @@ -61,10 +61,10 @@ (match rw [(struct modvar-rewrite (self-modidx provide->toplevel)) (log-debug (format "Rewriting ~a of ~S~n" pos (mpi->path* modidx))) - (+ (hash-ref MODULE-TOPLEVEL-OFFSETS self-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))])])) + (provide->toplevel sym pos))])])) (define (filter-rewritable-module-variable? toplevel-offset mod-toplevels) (define-values @@ -76,6 +76,7 @@ (match tl [(and mv (struct module-variable (modidx sym pos phase))) (define rw (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 @@ -99,6 +100,7 @@ (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))) @@ -119,7 +121,9 @@ (define new-mod-prefix (struct-copy prefix mod-prefix [toplevels new-mod-toplevels])) - (hash-set! MODULE-TOPLEVEL-OFFSETS self-modidx toplevel-offset) + (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~n" diff --git a/collects/compiler/demodularizer/update-toplevels.rkt b/collects/compiler/demodularizer/update-toplevels.rkt index 701b4475d8..c6d1f4d9c6 100644 --- a/collects/compiler/demodularizer/update-toplevels.rkt +++ b/collects/compiler/demodularizer/update-toplevels.rkt @@ -1,5 +1,5 @@ #lang racket -(require compiler/zo-parse +(require compiler/zo-structs "util.rkt") (define (update-toplevels toplevel-updater topsyntax-updater topsyntax-new-midpt) @@ -84,9 +84,9 @@ [(and f (not (? form?))) f] )) - (define update + (define-values (first-update update) (build-form-memo inner-update)) - update) + first-update) (provide/contract [update-toplevels diff --git a/collects/compiler/demodularizer/util.rkt b/collects/compiler/demodularizer/util.rkt index 7f8c653049..1334e2911b 100644 --- a/collects/compiler/demodularizer/util.rkt +++ b/collects/compiler/demodularizer/util.rkt @@ -12,23 +12,46 @@ (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) - (cond - [(hash-ref memo form #f) - => (λ (x) x)] - [else - (let () - (define ph (make-placeholder #f)) - (hash-set! memo form ph) - (define nv (apply inner-update form args)) - (placeholder-set! ph nv) - nv)])) + (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)) - (make-reader-graph final)) - first-update) + (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))) @@ -51,6 +74,7 @@ (((unconstrained-domain-> any/c)) (#:void? boolean?) . ->* . - (unconstrained-domain-> any/c))] + (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 afd0a0b084..666763ba8b 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -481,8 +481,8 @@ (define-syntax with-type-trace (syntax-rules () [(_ v body ...) - (begin body ...) - #;(with-continuation-mark 'zo (typeof v) + #;(begin body ...) + (with-continuation-mark 'zo (typeof v) (begin0 (begin body ...) (void)))])) (define (out-anything v out) @@ -860,7 +860,8 @@ (out-byte CPT_ESCAPE out) (define bstr (get-output-bytes s)) (out-number (bytes-length bstr) out) - (out-bytes bstr out)]))))) + (out-bytes bstr out)] + [else (error 'out-anything "~s" (current-type-trace))]))))) (define-struct module-decl (content)) From 6b8a9b086101435588bb97267715d7eddd73224b Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Thu, 7 Oct 2010 13:24:25 -0600 Subject: [PATCH 47/60] Avoiding cycles in everything but closures original commit: 7bffbc31a24c8c22c77f5b62a72228551903e9e3 --- collects/compiler/demodularizer/batch.rkt | 8 ++++ collects/compiler/zo-marshal.rkt | 45 ++++++++++++++--------- collects/compiler/zo-parse.rkt | 2 + 3 files changed, 37 insertions(+), 18 deletions(-) diff --git a/collects/compiler/demodularizer/batch.rkt b/collects/compiler/demodularizer/batch.rkt index 001fb30d53..99ad2e5e5c 100644 --- a/collects/compiler/demodularizer/batch.rkt +++ b/collects/compiler/demodularizer/batch.rkt @@ -76,6 +76,7 @@ Here's the idea: (define merged-source-path (path-add-suffix file-to-batch #".merged.rkt")) +(define merged-struct-path (path-add-suffix file-to-batch #".mergeds.rkt")) (define-values (merged-source-base merged-source-name _1) (split-path merged-source-path)) (define merged-zo-path (build-compiled-path merged-source-base (path-add-suffix merged-source-name #".zo"))) @@ -113,6 +114,13 @@ Here's the idea: (pretty-print (decompile batch-final))) #:exists 'replace) +(log-debug "Writing merged struct~n") +(with-output-to-file + merged-struct-path + (lambda () + (pretty-write batch-final)) + #:exists 'replace) + (log-debug "Writing merged zo~n") (void (with-output-to-file diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 666763ba8b..78a5af08e7 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -68,20 +68,22 @@ (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)])) + (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)))] + [(member v (rest (continuation-mark-set->list (current-continuation-marks) 'cycle))) + #f] + [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)) @@ -455,7 +457,7 @@ (define (shareable? v) (define never-share-this? - (or-pred? v char? maybe-same-as-fixnum? empty? boolean? void? hash? )) + (or-pred? v char? maybe-same-as-fixnum? empty? boolean? void? hash?)) (define always-share-this? (or-pred? v closure?)) (or always-share-this? @@ -481,11 +483,18 @@ (define-syntax with-type-trace (syntax-rules () [(_ v body ...) - #;(begin body ...) - (with-continuation-mark 'zo (typeof v) + (begin body ...) + #;(with-continuation-mark 'zo (typeof v) + (begin0 (begin body ...) (void)))])) + +(define-syntax with-cycle-check + (syntax-rules () + [(_ v body ...) + (with-continuation-mark 'cycle v (begin0 (begin body ...) (void)))])) (define (out-anything v out) + (with-cycle-check v (with-type-trace v (out-shared v out @@ -861,7 +870,7 @@ (define bstr (get-output-bytes s)) (out-number (bytes-length bstr) out) (out-bytes bstr out)] - [else (error 'out-anything "~s" (current-type-trace))]))))) + [else (error 'out-anything "~s" (current-type-trace))])))))) (define-struct module-decl (content)) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 000c4efc35..04ff19f019 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -1046,6 +1046,8 @@ (for ([i (in-range 1 symtabsize)]) (read-sym cp i)) + #;(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)))) From 7e97041b8daaf47fb8cf8fdbe52035331554210f Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Wed, 13 Oct 2010 12:39:35 -0600 Subject: [PATCH 48/60] debugging original commit: 77c46d07eed7742d6bd525e7180866dbbe15217d --- collects/compiler/zo-marshal.rkt | 3 ++ collects/tests/compiler/zo-exs.rkt | 44 ++++++++++++++++++++++++------ 2 files changed, 38 insertions(+), 9 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 78a5af08e7..445128e074 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -95,6 +95,9 @@ (define-values (symbol-table shared-obj-pos) (create-symbol-table)) + (for ([(i v) (in-dict symbol-table)]) + (printf "~a: ~a\n" i v)) + ; 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 diff --git a/collects/tests/compiler/zo-exs.rkt b/collects/tests/compiler/zo-exs.rkt index 34ca2e4c2e..51b4e8dd9a 100644 --- a/collects/tests/compiler/zo-exs.rkt +++ b/collects/tests/compiler/zo-exs.rkt @@ -19,17 +19,17 @@ (test - (roundtrip + #;(roundtrip (compilation-top 0 (prefix 0 empty empty) (list 1 (list 2 3) (list 2 3) 4 5))) ; XXX This should work, but closures have a field that is gensym'ed - #;(roundtrip + + (roundtrip (compilation-top 0 (prefix 0 empty empty) (let* ([ph (make-placeholder #f)] - [x (indirect - (closure + [x (application (closure (lam 'name empty 0 @@ -39,7 +39,33 @@ empty 0 ph) - 'name))]) + 'name) empty)]) + (placeholder-set! ph x) + (let ([c (make-reader-graph x)]) + (closure (lam 'name2 + empty + 0 + empty + #f + #() + empty + 0 + (seq (list c c))) 'name2))))) + #;(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)))) @@ -76,24 +102,24 @@ (toplevel 0 0 #f #f) #(racket/language-info get-info #f) #t))) - (roundtrip + #;(roundtrip (compilation-top 0 (prefix 0 empty empty) (current-directory))) - (roundtrip + #;(roundtrip (compilation-top 0 (prefix 0 empty empty) (list (current-directory)))) - (roundtrip + #;(roundtrip (compilation-top 0 (prefix 0 empty empty) (cons #hash() #hash()))) - (roundtrip + #;(roundtrip (compilation-top 0 (prefix 0 empty empty) From b8122efb82cc471de1652454962e4b758f7ec503 Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Tue, 26 Oct 2010 15:39:39 -0600 Subject: [PATCH 49/60] using hasheq in zo-marshal original commit: 43e151f340abde95f4825a2f6409b67e048a6aec --- collects/compiler/zo-marshal.rkt | 64 ++++++++++++++++++++++++++------ 1 file changed, 53 insertions(+), 11 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index 445128e074..cbd2572bbe 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -44,8 +44,8 @@ ; 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-hash)) - (define shared (make-hash)) + (define encountered (make-hasheq)) + (define shared (make-hasheq)) (define (encountered? v) ((hash-ref encountered v 0) . > . 0)) (define (encounter! v) @@ -66,11 +66,17 @@ (hash-set! shared v pos) pos))) - (out-compilation-top - (λ (v #:error? [error? #f]) + (define (do-pass) + (out-compilation-top + (λ (v #:error? [error? #f]) (cond - [(hash? v) (error 'create-symbol-table "current type trace: ~a" (current-type-trace))] + #;[(contains-a-cycle? v) + #f] + [(hash? v) + (error 'create-symbol-table "current type trace: ~a" (current-type-trace))] [(closure? v) + #;(when (cyclic-closure? v) + (record-contains-a-cycle!)) (let ([pos (share! v)]) (if (encountered? v) pos @@ -84,18 +90,54 @@ (share! v)] [else (encounter! v)])) - (λ (v) - (unencounter! v)) - (open-output-nowhere)) + (λ (v) + (unencounter! v)) + (open-output-nowhere))) + + ;(do-pass) + ;(hash-remove-all! shared) + ;(hash-remove-all! encountered) + (do-pass) (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)) + + ; Closures go first in the symbol table + ; to avoid... + ; Reading symtab#1 where it references symtab #2 + ; Symtab#2 is a closure + ; Symtab#2 references symtab#1 + ; Thus, there is a "cycle" reading symtab#1 + ; and cycles are only allowed in closures. + ; XXX Can we get the following? + ; [1 |-> (closure ... #2 ...)] + ; [2 |-> (closure ... #1 ...)] + ; JM: We can fabricate one, definitely, but I don't think + ; we could possibly parse it. And I don't think the + ; compiler would ever make one. + (define sorted-shared-objs + (sort (hash-keys shared) + (λ (x y) + ; Move closures to the left + (closure? x)))) + (define relabeling (make-vector (hash-count shared) #f)) + (for ([obj sorted-shared-objs] + [actual-pos (in-naturals)]) + (define pos (hash-ref shared obj)) + (vector-set! relabeling (sub1 pos) (add1 actual-pos)) + (vector-set! symbol-table actual-pos obj)) + + (define (relabeled-shared-obj-pos v #:error? [error? #f]) + (define old-pos + (shared-obj-pos v #:error? error?)) + (and old-pos + (vector-ref relabeling (sub1 old-pos)))) + + (values symbol-table relabeled-shared-obj-pos)) (define-values (symbol-table shared-obj-pos) (create-symbol-table)) - (for ([(i v) (in-dict symbol-table)]) + #;(for ([(i v) (in-dict symbol-table)]) (printf "~a: ~a\n" i v)) ; vector output-port -> (listof number) number From 8392dd8fa4d7dbb87bb169f92290ccf383179b0e Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Tue, 26 Oct 2010 15:41:36 -0600 Subject: [PATCH 50/60] fixing logging and running code in zo-exs original commit: 0688c1859305c60441d97dc4d2b43cf9e5550802 --- collects/compiler/demodularizer/batch.rkt | 36 +++++++++++------------ collects/compiler/demodularizer/merge.rkt | 22 +++++++------- collects/compiler/zo-parse.rkt | 8 ++++- collects/tests/compiler/zo-exs.rkt | 10 +++++-- 4 files changed, 43 insertions(+), 33 deletions(-) diff --git a/collects/compiler/demodularizer/batch.rkt b/collects/compiler/demodularizer/batch.rkt index 99ad2e5e5c..2553baeaf9 100644 --- a/collects/compiler/demodularizer/batch.rkt +++ b/collects/compiler/demodularizer/batch.rkt @@ -46,6 +46,7 @@ Here's the idea: "gc-toplevels.rkt" "alpha.rkt" "module.rkt" + "replace-modidx.rkt" compiler/decompile compiler/zo-marshal racket/set) @@ -65,13 +66,13 @@ Here's the idea: ;; Compile -#;(log-debug "Removing existing zo file~n") +#;(log-debug "Removing existing zo file") #;(define compiled-zo-path (build-compiled-path base (path-add-suffix name #".zo"))) #;(when (file-exists? compiled-zo-path) (delete-file compiled-zo-path)) -(log-debug "Compiling module~n") +(log-debug "Compiling module") (void (system* (find-executable-path "raco") "make" file-to-batch)) @@ -81,52 +82,49 @@ Here's the idea: (define merged-zo-path (build-compiled-path merged-source-base (path-add-suffix merged-source-name #".zo"))) ;; Transformations -(log-debug "Removing dependencies~n") +(log-debug "Removing dependencies") (define-values (batch-nodep top-lang-info top-self-modidx) (nodep-file file-to-batch (excluded-modules))) -(log-debug "Merging modules~n") +(log-debug "Merging modules") (define batch-merge (merge-compilation-top batch-nodep)) -(log-debug "GC-ing top-levels~n") +(log-debug "GC-ing top-levels") (define batch-gcd batch-merge #;(gc-toplevels batch-merge)) -(log-debug "Alpha-varying top-levels~n") +(log-debug "Alpha-varying top-levels") (define batch-alpha (alpha-vary-ctop batch-gcd)) +(log-debug "Replacing self-modidx") +(define batch-replace-modidx + (replace-modidx batch-alpha top-self-modidx)) + (define batch-modname (string->symbol (regexp-replace #rx"\\.rkt$" (path->string merged-source-name) ""))) -(log-debug (format "Modularizing into ~a~n" batch-modname)) +(log-debug (format "Modularizing into ~a" batch-modname)) (define batch-mod - (wrap-in-kernel-module batch-modname batch-modname top-lang-info top-self-modidx batch-alpha)) + (wrap-in-kernel-module batch-modname batch-modname top-lang-info top-self-modidx batch-replace-modidx)) ;; Output (define batch-final batch-mod) -(log-debug "Writing merged source~n") +(log-debug "Writing merged source") (with-output-to-file merged-source-path (lambda () - (pretty-print (decompile batch-final))) + (write batch-final)) #:exists 'replace) -(log-debug "Writing merged struct~n") -(with-output-to-file - merged-struct-path - (lambda () - (pretty-write batch-final)) - #:exists 'replace) - -(log-debug "Writing merged zo~n") +(log-debug "Writing merged zo") (void (with-output-to-file merged-zo-path (lambda () - (write-bytes (zo-marshal batch-final))) + (zo-marshal-to batch-final (current-output-port))) #:exists 'replace)) diff --git a/collects/compiler/demodularizer/merge.rkt b/collects/compiler/demodularizer/merge.rkt index a6d944d722..942305bc93 100644 --- a/collects/compiler/demodularizer/merge.rkt +++ b/collects/compiler/demodularizer/merge.rkt @@ -15,10 +15,10 @@ (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~n" max-let-depth new-max-let-depth)) - (log-debug (format "total toplevels ~S~n" total-tls)) - (log-debug (format "total stxs ~S~n" total-stxs)) - (log-debug (format "num-lifts ~S~n" total-lifts)) + (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)))] @@ -60,7 +60,7 @@ [(struct module-variable (modidx sym pos phase)) (match rw [(struct modvar-rewrite (self-modidx provide->toplevel)) - (log-debug (format "Rewriting ~a of ~S~n" pos (mpi->path* modidx))) + (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))) @@ -82,7 +82,7 @@ (cond ; Primitive module like #%paramz [(symbol? rw) - (log-debug (format "~S from ~S~n" sym rw)) + (log-debug (format "~S from ~S" sym rw)) (values (add1 i) (list* tl new-toplevels) (list* (+ i toplevel-offset) remap))] @@ -126,22 +126,22 @@ (list-ref toplevel-remap n))) (unless (= (length toplevel-remap) (length mod-toplevels)) - (error 'merge-module "Not remapping everything: ~S ~S~n" + (error 'merge-module "Not remapping everything: ~S ~S" mod-toplevels toplevel-remap)) - (log-debug (format "[~S] Incrementing toplevels by ~a~n" + (log-debug (format "[~S] Incrementing toplevels by ~a" name toplevel-offset)) - (log-debug (format "[~S] Incrementing lifts by ~a~n" + (log-debug (format "[~S] Incrementing lifts by ~a" name lift-offset)) - (log-debug (format "[~S] Filtered mod-vars from ~a to ~a~n" + (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\n" name)) + (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)) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 04ff19f019..41865df308 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -950,7 +950,12 @@ (make-closure v ; XXX Why call gensym here? - (gensym + (let ([s (lam-name v)]) + (cond + [(symbol? s) s] + [(vector? s) (vector-ref s 0)] + [else 'closure])) + #;(gensym (let ([s (lam-name v)]) (cond [(symbol? s) s] @@ -1046,6 +1051,7 @@ (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) diff --git a/collects/tests/compiler/zo-exs.rkt b/collects/tests/compiler/zo-exs.rkt index 51b4e8dd9a..858a557def 100644 --- a/collects/tests/compiler/zo-exs.rkt +++ b/collects/tests/compiler/zo-exs.rkt @@ -7,13 +7,19 @@ (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)) - (with-output-to-file "test_rkt.zo" (λ () (write-bytes bs)) #:exists 'replace) + (with-output-to-file "compiled/test_rkt.zo" (λ () (write-bytes bs)) #:exists 'replace) (test #:failure-prefix (format "~S" ct) (test bs (zo-parse (open-input-bytes bs)) => ct - (read-compiled-bytes bs)))) + (run-compiled-bytes bs #t) + (run-compiled-bytes bs #f)))) (define mpi (module-path-index-join #f #f)) From 969c0f4d5848176eedf9517de0c828078c67362f Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Tue, 26 Oct 2010 15:45:30 -0600 Subject: [PATCH 51/60] replacing self modidx refs and tests original commit: b2b5875e3ebdf5a1f173c72f4d84707c9a3484d0 --- .../compiler/demodularizer/replace-modidx.rkt | 25 +++++++++ .../compiler/demodularizer/demod-test.rkt | 53 +++++++++++++++++++ .../compiler/demodularizer/tests/kernel-5.rkt | 5 ++ .../compiler/demodularizer/tests/racket-5.rkt | 2 + 4 files changed, 85 insertions(+) create mode 100644 collects/compiler/demodularizer/replace-modidx.rkt create mode 100644 collects/tests/compiler/demodularizer/demod-test.rkt create mode 100644 collects/tests/compiler/demodularizer/tests/kernel-5.rkt create mode 100644 collects/tests/compiler/demodularizer/tests/racket-5.rkt 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/tests/compiler/demodularizer/demod-test.rkt b/collects/tests/compiler/demodularizer/demod-test.rkt new file mode 100644 index 0000000000..ed29ff1f3e --- /dev/null +++ b/collects/tests/compiler/demodularizer/demod-test.rkt @@ -0,0 +1,53 @@ +#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.rkt"))) + + ; run whole program + (define-values (whole-output whole-error) + (capture-output (find-executable-path "racket") demod-filename)) + + (display whole-error) + + ; 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-on-program "/Users/blake/Development/plt/collects/tests/compiler/demodularizer/tests/racket-5.rkt") + +#;(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 From 345f30f7e5780075ce8e467404de1a252e8ad7b6 Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Wed, 27 Oct 2010 23:33:19 -0600 Subject: [PATCH 52/60] rolling back some unnecessary changes original commit: a315f79ebddaa7695f08f73ccdf78ae5c858f713 --- collects/compiler/zo-marshal.rkt | 102 ++++++++----------------------- 1 file changed, 24 insertions(+), 78 deletions(-) diff --git a/collects/compiler/zo-marshal.rkt b/collects/compiler/zo-marshal.rkt index cbd2572bbe..5629f4a917 100644 --- a/collects/compiler/zo-marshal.rkt +++ b/collects/compiler/zo-marshal.rkt @@ -66,80 +66,33 @@ (hash-set! shared v pos) pos))) - (define (do-pass) - (out-compilation-top - (λ (v #:error? [error? #f]) - (cond - #;[(contains-a-cycle? v) - #f] - [(hash? v) - (error 'create-symbol-table "current type trace: ~a" (current-type-trace))] - [(closure? v) - #;(when (cyclic-closure? v) - (record-contains-a-cycle!)) - (let ([pos (share! v)]) - (if (encountered? v) - pos - (encounter! v)))] - [(member v (rest (continuation-mark-set->list (current-continuation-marks) 'cycle))) - #f] - [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))) - - ;(do-pass) - ;(hash-remove-all! shared) - ;(hash-remove-all! encountered) - (do-pass) + (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))) - - ; Closures go first in the symbol table - ; to avoid... - ; Reading symtab#1 where it references symtab #2 - ; Symtab#2 is a closure - ; Symtab#2 references symtab#1 - ; Thus, there is a "cycle" reading symtab#1 - ; and cycles are only allowed in closures. - ; XXX Can we get the following? - ; [1 |-> (closure ... #2 ...)] - ; [2 |-> (closure ... #1 ...)] - ; JM: We can fabricate one, definitely, but I don't think - ; we could possibly parse it. And I don't think the - ; compiler would ever make one. - (define sorted-shared-objs - (sort (hash-keys shared) - (λ (x y) - ; Move closures to the left - (closure? x)))) - (define relabeling (make-vector (hash-count shared) #f)) - (for ([obj sorted-shared-objs] - [actual-pos (in-naturals)]) - (define pos (hash-ref shared obj)) - (vector-set! relabeling (sub1 pos) (add1 actual-pos)) - (vector-set! symbol-table actual-pos obj)) - - (define (relabeled-shared-obj-pos v #:error? [error? #f]) - (define old-pos - (shared-obj-pos v #:error? error?)) - (and old-pos - (vector-ref relabeling (sub1 old-pos)))) - - (values symbol-table relabeled-shared-obj-pos)) + (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)) - #;(for ([(i v) (in-dict symbol-table)]) - (printf "~a: ~a\n" i v)) - ; 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 @@ -528,18 +481,11 @@ (define-syntax with-type-trace (syntax-rules () [(_ v body ...) - (begin body ...) - #;(with-continuation-mark 'zo (typeof v) - (begin0 (begin body ...) (void)))])) - -(define-syntax with-cycle-check - (syntax-rules () - [(_ v body ...) - (with-continuation-mark 'cycle v + #;(begin body ...) + (with-continuation-mark 'zo (typeof v) (begin0 (begin body ...) (void)))])) (define (out-anything v out) - (with-cycle-check v (with-type-trace v (out-shared v out @@ -915,7 +861,7 @@ (define bstr (get-output-bytes s)) (out-number (bytes-length bstr) out) (out-bytes bstr out)] - [else (error 'out-anything "~s" (current-type-trace))])))))) + [else (error 'out-anything "~s" (current-type-trace))]))))) (define-struct module-decl (content)) From 8ae1cd0c3eb8a25d70948d26fc13f95e7e6e1b16 Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Fri, 29 Oct 2010 14:22:28 -0600 Subject: [PATCH 53/60] only creating zo file original commit: 783418ce37474b4562ae70dd4c1ca68158ab7f1d --- collects/compiler/demodularizer/batch.rkt | 47 +++++-------------- .../compiler/demodularizer/demod-test.rkt | 8 +--- 2 files changed, 15 insertions(+), 40 deletions(-) diff --git a/collects/compiler/demodularizer/batch.rkt b/collects/compiler/demodularizer/batch.rkt index 2553baeaf9..e65df730ac 100644 --- a/collects/compiler/demodularizer/batch.rkt +++ b/collects/compiler/demodularizer/batch.rkt @@ -66,67 +66,46 @@ Here's the idea: ;; Compile -#;(log-debug "Removing existing zo file") -#;(define compiled-zo-path (build-compiled-path base (path-add-suffix name #".zo"))) -#;(when (file-exists? compiled-zo-path) - (delete-file compiled-zo-path)) - -(log-debug "Compiling module") +(log-info "Compiling module") (void (system* (find-executable-path "raco") "make" file-to-batch)) -(define merged-source-path (path-add-suffix file-to-batch #".merged.rkt")) -(define merged-struct-path (path-add-suffix file-to-batch #".mergeds.rkt")) -(define-values (merged-source-base merged-source-name _1) (split-path merged-source-path)) -(define merged-zo-path (build-compiled-path merged-source-base (path-add-suffix merged-source-name #".zo"))) +(define merged-zo-path (path-add-suffix file-to-batch #"_merged.zo")) ;; Transformations -(log-debug "Removing dependencies") +(log-info "Removing dependencies") (define-values (batch-nodep top-lang-info top-self-modidx) (nodep-file file-to-batch (excluded-modules))) -(log-debug "Merging modules") +(log-info "Merging modules") (define batch-merge (merge-compilation-top batch-nodep)) -(log-debug "GC-ing top-levels") +; Not doing this for now +;(log-info "GC-ing top-levels") (define batch-gcd batch-merge #;(gc-toplevels batch-merge)) -(log-debug "Alpha-varying top-levels") +(log-info "Alpha-varying top-levels") (define batch-alpha (alpha-vary-ctop batch-gcd)) -(log-debug "Replacing self-modidx") +(log-info "Replacing self-modidx") (define batch-replace-modidx (replace-modidx batch-alpha top-self-modidx)) (define batch-modname - (string->symbol (regexp-replace #rx"\\.rkt$" (path->string merged-source-name) ""))) -(log-debug (format "Modularizing into ~a" 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)) -;; Output -(define batch-final batch-mod) - -(log-debug "Writing merged source") -(with-output-to-file - merged-source-path - (lambda () - (write batch-final)) - #:exists 'replace) - -(log-debug "Writing merged zo") +(log-info "Writing merged zo") (void (with-output-to-file merged-zo-path (lambda () - (zo-marshal-to batch-final (current-output-port))) - #:exists 'replace)) - - - - + (zo-marshal-to batch-mod (current-output-port))) + #:exists 'replace)) \ No newline at end of file diff --git a/collects/tests/compiler/demodularizer/demod-test.rkt b/collects/tests/compiler/demodularizer/demod-test.rkt index ed29ff1f3e..dec2f03a96 100644 --- a/collects/tests/compiler/demodularizer/demod-test.rkt +++ b/collects/tests/compiler/demodularizer/demod-test.rkt @@ -22,14 +22,12 @@ (define demod-filename (path->string - (path-add-suffix filename #".merged.rkt"))) + (path-add-suffix filename #"_merged.zo"))) ; run whole program (define-values (whole-output whole-error) (capture-output (find-executable-path "racket") demod-filename)) - (display whole-error) - ; compare output (test #:failure-prefix (format "~a stdout" filename) @@ -43,9 +41,7 @@ (and (not (regexp-match #rx"merged" filename)) (regexp-match #rx"rkt$" filename))) -(test-on-program "/Users/blake/Development/plt/collects/tests/compiler/demodularizer/tests/racket-5.rkt") - -#;(test +(test (for ([i (in-list (directory-list tests))]) (define ip (build-path tests i)) (when (modular-program? ip) From aae51fbb872dd4d02cd7be579718ba2f12b22227 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Fri, 29 Oct 2010 21:32:31 -0600 Subject: [PATCH 54/60] Repairing tests original commit: ec7157744f870825442f5e3263daf1e53e52a79e --- collects/tests/compiler/zo-exs.rkt | 61 ++++++------------------------ 1 file changed, 11 insertions(+), 50 deletions(-) diff --git a/collects/tests/compiler/zo-exs.rkt b/collects/tests/compiler/zo-exs.rkt index 858a557def..3bd665ca04 100644 --- a/collects/tests/compiler/zo-exs.rkt +++ b/collects/tests/compiler/zo-exs.rkt @@ -14,50 +14,24 @@ (define (roundtrip ct) (define bs (zo-marshal ct)) - (with-output-to-file "compiled/test_rkt.zo" (λ () (write-bytes bs)) #:exists 'replace) (test #:failure-prefix (format "~S" ct) (test bs (zo-parse (open-input-bytes bs)) => ct - (run-compiled-bytes bs #t) - (run-compiled-bytes bs #f)))) + (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 - #;(roundtrip + (roundtrip (compilation-top 0 (prefix 0 empty empty) (list 1 (list 2 3) (list 2 3) 4 5))) - ; XXX This should work, but closures have a field that is gensym'ed (roundtrip - (compilation-top 0 - (prefix 0 empty empty) - (let* ([ph (make-placeholder #f)] - [x (application (closure - (lam 'name - empty - 0 - empty - #f - #() - empty - 0 - ph) - 'name) empty)]) - (placeholder-set! ph x) - (let ([c (make-reader-graph x)]) - (closure (lam 'name2 - empty - 0 - empty - #f - #() - empty - 0 - (seq (list c c))) 'name2))))) - #;(roundtrip (compilation-top 0 (prefix 0 empty empty) (let* ([ph (make-placeholder #f)] @@ -108,39 +82,26 @@ (toplevel 0 0 #f #f) #(racket/language-info get-info #f) #t))) - #;(roundtrip + + (roundtrip (compilation-top 0 (prefix 0 empty empty) (current-directory))) - #;(roundtrip + (roundtrip (compilation-top 0 (prefix 0 empty empty) (list (current-directory)))) - #;(roundtrip + (roundtrip (compilation-top 0 (prefix 0 empty empty) (cons #hash() #hash()))) - #;(roundtrip + (roundtrip (compilation-top 0 (prefix 0 empty empty) - #hash())) - - #;(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))) - - + #hash()))) \ No newline at end of file From e5b1e20529f19d774f5b806cde227499143eead3 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Sat, 30 Oct 2010 08:31:23 -0600 Subject: [PATCH 55/60] Removing newlines from debug messages original commit: 46e2e7931a0dd01f8dc429f742db1f3fbba539b3 --- collects/compiler/demodularizer/gc-toplevels.rkt | 12 ++++++------ collects/compiler/demodularizer/mpi.rkt | 2 +- collects/compiler/demodularizer/nodep.rkt | 12 ++++++------ 3 files changed, 13 insertions(+), 13 deletions(-) diff --git a/collects/compiler/demodularizer/gc-toplevels.rkt b/collects/compiler/demodularizer/gc-toplevels.rkt index a016720caa..79401002d5 100644 --- a/collects/compiler/demodularizer/gc-toplevels.rkt +++ b/collects/compiler/demodularizer/gc-toplevels.rkt @@ -41,12 +41,12 @@ (index<=? stx-pos ordered-stxs)) (prefix-syntax-start new-prefix)) form)) - (log-debug (format "Total TLS: ~S~n" (length normal-tls))) - (log-debug (format "Used TLS: ~S~n" normal-tls)) - (log-debug (format "Total lifts: ~S~n" (length lifts))) - (log-debug (format "Used lifts: ~S~n" lifts)) - (log-debug (format "Total stxs: ~S~n" (length stxs))) - (log-debug (format "Used stxs: ~S~n" ordered-stxs)) + (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 diff --git a/collects/compiler/demodularizer/mpi.rkt b/collects/compiler/demodularizer/mpi.rkt index ae86a43832..135bf24ecc 100644 --- a/collects/compiler/demodularizer/mpi.rkt +++ b/collects/compiler/demodularizer/mpi.rkt @@ -22,7 +22,7 @@ (define (mpi->path* mpi) (hash-ref MODULE-PATHS mpi (lambda () - (error 'mpi->path* "Cannot locate cache of path for ~S~n" mpi)))) + (error 'mpi->path* "Cannot locate cache of path for ~S" mpi)))) (provide/contract [current-module-path (parameter/c path-string?)] diff --git a/collects/compiler/demodularizer/nodep.rkt b/collects/compiler/demodularizer/nodep.rkt index 54507f2365..827c38026f 100644 --- a/collects/compiler/demodularizer/nodep.rkt +++ b/collects/compiler/demodularizer/nodep.rkt @@ -57,7 +57,7 @@ (current-directory))) (define-values (modvar-rewrite lang-info ctop) (begin - (log-debug (format "Load ~S @ ~S~n" pth phase)) + (log-debug (format "Load ~S @ ~S" pth phase)) (nodep/dir (parameterize ([current-load-relative-directory base-directory]) (path->comp-top @@ -98,7 +98,7 @@ (when (symbol? tl) (hash-set! provide-ht (intern tl) i))) (lambda (sym pos) - (log-debug (format "Looking up ~S@~a~n" 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))))) @@ -114,15 +114,15 @@ [tl (void)]) (prefix-toplevels new-prefix)) - (log-debug (format "[~S] module-variables: ~S~n" name (length (filter module-variable? (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~n" name lang-info)) ; XXX Seems to always be #f now + (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~n" name phase)) + (begin (log-debug (format "[~S] Dropping module @ ~S" name phase)) empty))))] [else (error 'nodep-module "huh?: ~e" mod-form)])) @@ -168,7 +168,7 @@ [(@phase? ct) (extract-modules (@phase-ctop ct))] [else - (error 'extract-modules "Unknown extraction: ~S~n" ct)])) + (error 'extract-modules "Unknown extraction: ~S" ct)])) (provide/contract [struct modvar-rewrite From 5f064063f5f2e4c96f7aa297bcc0def3de9e990c Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Sat, 30 Oct 2010 08:54:13 -0600 Subject: [PATCH 56/60] Saving time by only reading zos once and saving space by limiting the extent of the hash tables original commit: 255489e0af804f05c8519d040b82a0bbce0f1f8c --- collects/compiler/demodularizer/batch.rkt | 4 +- collects/compiler/demodularizer/merge.rkt | 40 +++++++++--------- collects/compiler/demodularizer/nodep.rkt | 49 ++++++++++++++--------- 3 files changed, 54 insertions(+), 39 deletions(-) diff --git a/collects/compiler/demodularizer/batch.rkt b/collects/compiler/demodularizer/batch.rkt index e65df730ac..8bc8967d43 100644 --- a/collects/compiler/demodularizer/batch.rkt +++ b/collects/compiler/demodularizer/batch.rkt @@ -75,12 +75,12 @@ Here's the idea: ;; Transformations (log-info "Removing dependencies") -(define-values (batch-nodep top-lang-info top-self-modidx) +(define-values (batch-nodep top-lang-info top-self-modidx get-modvar-rewrite) (nodep-file file-to-batch (excluded-modules))) (log-info "Merging modules") (define batch-merge - (merge-compilation-top batch-nodep)) + (merge-compilation-top get-modvar-rewrite batch-nodep)) ; Not doing this for now ;(log-info "GC-ing top-levels") diff --git a/collects/compiler/demodularizer/merge.rkt b/collects/compiler/demodularizer/merge.rkt index 942305bc93..f25dd63166 100644 --- a/collects/compiler/demodularizer/merge.rkt +++ b/collects/compiler/demodularizer/merge.rkt @@ -7,22 +7,24 @@ (define MODULE-TOPLEVEL-OFFSETS (make-hash)) -(define (merge-compilation-top top) - (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 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) @@ -75,7 +77,7 @@ ([tl (in-list mod-toplevels)]) (match tl [(and mv (struct module-variable (modidx sym pos phase))) - (define rw (get-modvar-rewrite modidx)) + (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)) @@ -166,4 +168,6 @@ (map update body)))])) (provide/contract - [merge-compilation-top (compilation-top? . -> . compilation-top?)]) \ No newline at end of file + [merge-compilation-top (-> get-modvar-rewrite/c + compilation-top? + compilation-top?)]) \ No newline at end of file diff --git a/collects/compiler/demodularizer/nodep.rkt b/collects/compiler/demodularizer/nodep.rkt index 827c38026f..aaa98503e3 100644 --- a/collects/compiler/demodularizer/nodep.rkt +++ b/collects/compiler/demodularizer/nodep.rkt @@ -6,45 +6,53 @@ (define excluded-modules (make-parameter null)) -(define (nodep-file file-to-batch excluded) - (excluded-modules excluded) - (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))])) +(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 excluded) + (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)))) + (excluded-modules excluded) + (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) - (call-with-input-file pth zo-parse)) + (hash-ref! (ZOS) pth + (λ () + (call-with-input-file pth zo-parse)))) (define (excluded? pth) (set-member? (excluded-modules) (path->string pth))) -(define MODULE-IDX-MAP (make-hash)) (define (get-nodep-module-code/index mpi phase) (define pth (mpi->path! mpi)) (cond [(symbol? pth) - (hash-set! MODULE-IDX-MAP pth pth) + (hash-set! (MODULE-IDX-MAP) pth pth) pth] [(excluded? pth) - (hash-set! MODULE-IDX-MAP pth mpi) + (hash-set! (MODULE-IDX-MAP) pth mpi) mpi] [else (get-nodep-module-code/path pth phase)])) -(define (get-modvar-rewrite modidx) - (define pth (mpi->path* modidx)) - (hash-ref MODULE-IDX-MAP pth - (lambda () - (error 'get-modvar-rewrite "Cannot locate modvar rewrite for ~S" pth)))) (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 PHASE*MODULE-CACHE (make-hash)) (define (get-nodep-module-code/path pth phase) (define MODULE-CACHE - (hash-ref! PHASE*MODULE-CACHE phase make-hash)) + (hash-ref! (PHASE*MODULE-CACHE) phase make-hash)) (if (hash-ref MODULE-CACHE pth #f) #f (hash-ref! @@ -67,7 +75,7 @@ pth phase))) (when (and phase (zero? phase)) - (hash-set! MODULE-IDX-MAP pth modvar-rewrite)) + (hash-set! (MODULE-IDX-MAP) pth modvar-rewrite)) (make-@phase phase (make-module-code modvar-rewrite lang-info ctop)))))) @@ -170,9 +178,12 @@ [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 (module-path-index? . -> . (or/c symbol? modvar-rewrite? module-path-index?))] - [nodep-file (path-string? set? . -> . (values compilation-top? lang-info/c module-path-index?))]) \ No newline at end of file + [get-modvar-rewrite/c contract?] + [nodep-file (-> path-string? set? + (values compilation-top? lang-info/c module-path-index? get-modvar-rewrite/c))]) \ No newline at end of file From c428f6cafe9a5659ed54d8666e39b2578ae021f5 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Sat, 30 Oct 2010 09:14:58 -0600 Subject: [PATCH 57/60] Exposing more values to GC by not making them toplevels original commit: 26c7625c7903b4edb74d745ff9737fc7ab1e0021 --- collects/compiler/demodularizer/batch.rkt | 116 +++++++++++---------- collects/compiler/demodularizer/module.rkt | 1 - collects/compiler/demodularizer/mpi.rkt | 9 +- collects/compiler/demodularizer/nodep.rkt | 10 +- 4 files changed, 69 insertions(+), 67 deletions(-) diff --git a/collects/compiler/demodularizer/batch.rkt b/collects/compiler/demodularizer/batch.rkt index 8bc8967d43..97ec868b12 100644 --- a/collects/compiler/demodularizer/batch.rkt +++ b/collects/compiler/demodularizer/batch.rkt @@ -40,6 +40,7 @@ Here's the idea: (require racket/pretty racket/system + "mpi.rkt" "util.rkt" "nodep.rkt" "merge.rkt" @@ -51,61 +52,62 @@ Here's the idea: compiler/zo-marshal racket/set) -(define excluded-modules (make-parameter (set))) -(define file-to-batch - (command-line #:program "batch" - #:multi - [("-e" "--exclude-modules") mod - "Exclude a module from being batched" - (excluded-modules (set-add (excluded-modules) mod))] - #:args (filename) filename)) +(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))) -(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 -(log-info "Removing dependencies") -(define-values (batch-nodep top-lang-info top-self-modidx get-modvar-rewrite) - (nodep-file file-to-batch (excluded-modules))) - -(log-info "Merging modules") -(define batch-merge - (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)) \ No newline at end of file +(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/module.rkt b/collects/compiler/demodularizer/module.rkt index 74d7ccd77b..faa47c49e7 100644 --- a/collects/compiler/demodularizer/module.rkt +++ b/collects/compiler/demodularizer/module.rkt @@ -7,7 +7,6 @@ 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)) diff --git a/collects/compiler/demodularizer/mpi.rkt b/collects/compiler/demodularizer/mpi.rkt index 135bf24ecc..3c86837115 100644 --- a/collects/compiler/demodularizer/mpi.rkt +++ b/collects/compiler/demodularizer/mpi.rkt @@ -1,4 +1,4 @@ -#lang scheme +#lang racket (require syntax/modresolve) (define current-module-path (make-parameter #f)) @@ -9,10 +9,10 @@ [else (mpi->path! modidx)])) -(define MODULE-PATHS (make-hash)) +(define MODULE-PATHS (make-parameter #f)) (define (mpi->path! mpi) (hash-ref! - MODULE-PATHS mpi + (MODULE-PATHS) mpi (lambda () (define _pth (resolve-module-path-index mpi (current-module-path))) @@ -20,11 +20,12 @@ (simplify-path _pth #t) _pth)))) (define (mpi->path* mpi) - (hash-ref MODULE-PATHS 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 index aaa98503e3..0d8c01642d 100644 --- a/collects/compiler/demodularizer/nodep.rkt +++ b/collects/compiler/demodularizer/nodep.rkt @@ -4,13 +4,13 @@ "mpi.rkt" racket/set) -(define excluded-modules (make-parameter null)) +(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 excluded) +(define (nodep-file file-to-batch) (define idx-map (make-hash)) (parameterize ([ZOS (make-hash)] [MODULE-IDX-MAP idx-map] @@ -20,7 +20,6 @@ (hash-ref idx-map pth (lambda () (error 'get-modvar-rewrite "Cannot locate modvar rewrite for ~S" pth)))) - (excluded-modules excluded) (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)]))) @@ -31,7 +30,7 @@ (call-with-input-file pth zo-parse)))) (define (excluded? pth) - (set-member? (excluded-modules) (path->string pth))) + (set-member? (current-excluded-modules) (path->string pth))) (define (get-nodep-module-code/index mpi phase) (define pth (mpi->path! mpi)) @@ -185,5 +184,6 @@ ([modidx module-path-index?] [provide->toplevel (symbol? exact-nonnegative-integer? . -> . exact-nonnegative-integer?)])] [get-modvar-rewrite/c contract?] - [nodep-file (-> path-string? set? + [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 From 74c7025e6e4071e97b1879ae9b71a67153688708 Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Sat, 30 Oct 2010 12:31:00 -0600 Subject: [PATCH 58/60] scrbl file and longer command name original commit: 199a63772ad1a9d89bc091da4244902ae16dbd9b --- collects/compiler/commands/info.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/compiler/commands/info.rkt b/collects/compiler/commands/info.rkt index 41b92c0eae..d97e168309 100644 --- a/collects/compiler/commands/info.rkt +++ b/collects/compiler/commands/info.rkt @@ -8,4 +8,4 @@ ("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) - ("demod" compiler/demodularizer/batch "produce a whole program from a single module" #f))) + ("demodularize" compiler/demodularizer/batch "produce a whole program from a single module" #f))) From 37f822ccb258ed2a8f7eb3504462cfc5f7856c5b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 11 Nov 2010 14:21:04 -0700 Subject: [PATCH 59/60] restore gen-id gensym so that decompiler works original commit: 0a8e5e604ed6ae81391eb05cba992fa9caaba784 --- collects/compiler/zo-parse.rkt | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/collects/compiler/zo-parse.rkt b/collects/compiler/zo-parse.rkt index 41865df308..a4e11f586b 100644 --- a/collects/compiler/zo-parse.rkt +++ b/collects/compiler/zo-parse.rkt @@ -949,13 +949,7 @@ (let ([v (read-compact cp)]) (make-closure v - ; XXX Why call gensym here? - (let ([s (lam-name v)]) - (cond - [(symbol? s) s] - [(vector? s) (vector-ref s 0)] - [else 'closure])) - #;(gensym + (gensym (let ([s (lam-name v)]) (cond [(symbol? s) s] From 00134af67b8b0a2329629979e32ce2c5b9c5c2cc Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Wed, 24 Nov 2010 22:33:37 -0500 Subject: [PATCH 60/60] Removing test because we reintroduced gensym original commit: b686cc84a9e9606658e0e5f0773d402f2bce8854 --- collects/tests/compiler/zo-exs.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/tests/compiler/zo-exs.rkt b/collects/tests/compiler/zo-exs.rkt index 3bd665ca04..2abdaab4ff 100644 --- a/collects/tests/compiler/zo-exs.rkt +++ b/collects/tests/compiler/zo-exs.rkt @@ -31,7 +31,7 @@ (prefix 0 empty empty) (list 1 (list 2 3) (list 2 3) 4 5))) - (roundtrip + #;(roundtrip (compilation-top 0 (prefix 0 empty empty) (let* ([ph (make-placeholder #f)]