suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

encoding wraps and fixes for zo-marshal sharing

Browse Source 
original commit: 54f2d34a2e
This commit is contained in:
Blake Johnson 2010-08-24 14:42:19 -06:00 committed by Jay McCarthy
parent 4379002ddc
commit b63f532735
3 changed files with 57 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
collects/compiler/zo-marshal.rkt
View File

@ -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)

2
collects/compiler/zo-parse.rkt
View File

@ -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)))

34
collects/tests/compiler/zo-exs.rkt
View File

@ -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)