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)))) diff --git a/src/racket/src/read.c b/src/racket/src/read.c index 525d368931..73e557649d 100644 --- a/src/racket/src/read.c +++ b/src/racket/src/read.c @@ -4738,9 +4738,13 @@ static Scheme_Object *read_compact(CPort *port, int use_stack) l = read_compact_number(port); RANGE_CHECK(l, < port->symtab_size); v = port->symtab[l]; + if (v == -1) { + // there is a cycle + scheme_ill_formed_code(port); + }; if (!v) { long save_pos = port->pos; - port->symtab[l] = scheme_false; /* avoid cycles if marshaled form is broken: */ + port->symtab[l] = -1; /* avoid cycles if marshaled form is broken: */ port->pos = port->shared_offsets[l - 1]; v = read_compact(port, 0); port->pos = save_pos;