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

rolling back some unnecessary changes

Browse Source 
original commit: a315f79ebd
This commit is contained in:
Blake Johnson 2010-10-27 23:33:19 -06:00 committed by Jay McCarthy
parent 969c0f4d58
commit 345f30f7e5
1 changed files with 24 additions and 78 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -66,23 +66,15 @@
(hash-set! shared v pos)
pos)))
(define (do-pass)
(out-compilation-top
(λ (v #:error? [error? #f])
(cond
#;[(contains-a-cycle? v)
#f]
[(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)
#;(when (cyclic-closure? v)
(record-contains-a-cycle!))
(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)]
@ -92,54 +84,15 @@
(encounter! v)]))
(λ (v)
(unencounter! v))
(open-output-nowhere)))
;(do-pass)
;(hash-remove-all! shared)
;(hash-remove-all! encountered)
(do-pass)
(open-output-nowhere))
(define symbol-table (make-vector (hash-count shared) (not-ready)))
; Closures go first in the symbol table
; to avoid...
; Reading symtab#1 where it references symtab #2
; Symtab#2 is a closure
; Symtab#2 references symtab#1
; Thus, there is a "cycle" reading symtab#1
; and cycles are only allowed in closures.
; XXX Can we get the following?
; [1 |-> (closure ... #2 ...)]
; [2 |-> (closure ... #1 ...)]
; JM: We can fabricate one, definitely, but I don't think
; we could possibly parse it. And I don't think the
; compiler would ever make one.
(define sorted-shared-objs
(sort (hash-keys shared)
(λ (x y)
; Move closures to the left
(closure? x))))
(define relabeling (make-vector (hash-count shared) #f))
(for ([obj sorted-shared-objs]
[actual-pos (in-naturals)])
(define pos (hash-ref shared obj))
(vector-set! relabeling (sub1 pos) (add1 actual-pos))
(vector-set! symbol-table actual-pos obj))
(define (relabeled-shared-obj-pos v #:error? [error? #f])
(define old-pos
(shared-obj-pos v #:error? error?))
(and old-pos
(vector-ref relabeling (sub1 old-pos))))
(values symbol-table relabeled-shared-obj-pos))
(hash-map shared (λ (k v) (vector-set! symbol-table (sub1 v) k)))
(values symbol-table shared-obj-pos))
(define-values (symbol-table shared-obj-pos)
(create-symbol-table))
#;(for ([(i v) (in-dict symbol-table)])
(printf "~a: ~a\n" i 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
@ -528,18 +481,11 @@
(define-syntax with-type-trace
(syntax-rules ()
[(_ v body ...)
(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
#;(begin body ...)
(with-continuation-mark 'zo (typeof v)
(begin0 (begin body ...) (void)))]))
(define (out-anything v out)
(with-cycle-check v
(with-type-trace v
(out-shared
v out
@ -915,7 +861,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))