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