From a5f557b90e214eeb435b20230f9cee8c24f6c59c Mon Sep 17 00:00:00 2001 From: Blake Johnson Date: Wed, 25 Aug 2010 17:25:10 -0600 Subject: [PATCH] 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))