Avoiding cycles in everything but closures

original commit: 7bffbc31a2

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 

collects/compiler/zo-marshal.rkt

@@ -68,20 +68,22 @@
     
     (out-compilation-top 
      (λ (v #:error? [error? #f])
-       (cond
+         (cond
-         [(hash? v) (error 'create-symbol-table "current type trace: ~a" (current-type-trace))]
+           [(hash? v) (error 'create-symbol-table "current type trace: ~a" (current-type-trace))]
-         [(closure? v)
+           [(closure? v)
-          (let ([pos (share! v)])
+            (let ([pos (share! v)])
-            (if (encountered? v)
+              (if (encountered? v)
-                pos
+                  pos
-                (encounter! v)))]
+                  (encounter! v)))]
-         [error? ; If we would error if this were not present, then we must share it
+           [(member v (rest (continuation-mark-set->list (current-continuation-marks) 'cycle)))
-          (encounter! v)
+            #f]
-          (share! v)]
+           [error? ; If we would error if this were not present, then we must share it
-         [(encountered? v)
+            (encounter! v)
-          (share! v)]
+            (share! v)]
-         [else
+           [(encountered? v)
-          (encounter! 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 ...)
+     (begin body ...)
-     (with-continuation-mark 'zo (typeof v)
+     #;(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))
 

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