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

Chez Scheme: repair fasl of deeply nested values

Browse Source 
The Racket variant of Chez Scheme includes special treatment of deeply
nested structures to avoid a C-stack overflow on unfasl, but the
relevant callbacks had gotten mangled.

Closes #3454
This commit is contained in:
Matthew Flatt 2020-10-21 13:14:54 -06:00
parent c3dbc3dd2a
commit 3ce134866b
2 changed files with 10 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
racket/src/ChezScheme/s/compile.ss
View File

@ -493,8 +493,8 @@
(if omit-rtds? (constant fasl-omit-rtds) 0))])
(and (not (fx= flags 0)) flags))])
(c-build-fasl x t a?)
($fasl-start p t situation
(lambda (p) (c-faslobj x t p a?)))))
($fasl-start p t situation x
(lambda (x p) (c-faslobj x t p a?)))))
(define-record-type visit-chunk
(nongenerative)
@ -616,7 +616,7 @@
(parameterize ([$target-machine (machine-type)])
(let ([t ($fasl-table)])
($fasl-enter x1 t (constant annotation-all) 0)
($fasl-start wpoop t (constant fasl-type-visit-revisit) (lambda (p) ($fasl-out x1 p t (constant annotation-all)))))))))))
($fasl-start wpoop t (constant fasl-type-visit-revisit) x1 (lambda (x p) ($fasl-out x p t (constant annotation-all)))))))))))
(let-values ([(rcinfo* lpinfo* final*) (compile-file-help1 x1 source-info-string)])
(when hostop
; the host library file contains expander output possibly augmented with
@ -627,7 +627,7 @@
(parameterize ([$target-machine (machine-type)])
(let ([t ($fasl-table)])
($fasl-enter x1 t (constant annotation-all) 0)
($fasl-start hostop t (constant fasl-type-visit-revisit) (lambda (p) ($fasl-out x1 p t (constant annotation-all)))))))))
($fasl-start hostop t (constant fasl-type-visit-revisit) x1 (lambda (x p) ($fasl-out x p t (constant annotation-all)))))))))
(cfh0 (+ n 1) (cons rcinfo* rrcinfo**) (cons lpinfo* rlpinfo**) (cons final* rfinal**)))))))))))
(define library/program-info?
@ -1610,7 +1610,7 @@
(let ([x (fold-left (lambda (outer ir) (with-output-language (Lexpand Outer) `(group ,outer ,ir)))
(car ir*) (cdr ir*))])
($fasl-enter x t (constant annotation-all) 0)
($fasl-start wpoop t (constant fasl-type-visit-revisit) (lambda (p) ($fasl-out x p t (constant annotation-all))))))))))))))
($fasl-start wpoop t (constant fasl-type-visit-revisit) x (lambda (x p) ($fasl-out x p t (constant annotation-all))))))))))))))
(define build-required-library-list
(lambda (node* visit-lib*)

10
racket/src/ChezScheme/s/fasl.ss
View File

@ -662,7 +662,7 @@
(module (start)
(define start
(lambda (p t situation proc)
(lambda (p t situation x proc)
(shift-externals! t)
(dump-graph)
(let-values ([(bv* size)
@ -680,7 +680,7 @@
(proc x p)
(wrf x p t (constant annotation-all))))
begins)))
(proc p)
(proc x p)
(extractor))])
($write-fasl-bytevectors p bv* size situation (constant fasl-type-fasl)))))
@ -718,7 +718,7 @@
(constant fasl-omit-rtds)
0))])
(bld x t a? 0)
(start p t (constant fasl-type-visit-revisit) (lambda (p) (wrf x p t a?))))))
(start p t (constant fasl-type-visit-revisit) x (lambda (x p) (wrf x p t a?))))))
(define-who fasl-write
(case-lambda
@ -760,7 +760,7 @@
(emit-header p (constant scheme-version) (constant machine-type-any))
(let ([t (make-table)])
(bld-graph x t #f 0 #t really-bld-record)
(start p t (constant fasl-type-visit-revisit) (lambda (p) (wrf-graph x p t #f really-wrf-record))))))
(start p t (constant fasl-type-visit-revisit) x (lambda (x p) (wrf-graph x p t #f really-wrf-record))))))
($fasl-target (make-target bld-graph bld wrf start make-table wrf-graph fasl-base-rtd fasl-write fasl-file))
)
@ -774,7 +774,7 @@
(set! $fasl-bld-graph (lambda (x t a? d inner? handler) ((target-fasl-bld-graph (fasl-target)) x t a? d inner? handler)))
(set! $fasl-enter (lambda (x t a? d) ((target-fasl-enter (fasl-target)) x t a? d)))
(set! $fasl-out (lambda (x p t a?) ((target-fasl-out (fasl-target)) x p t a?)))
(set! $fasl-start (lambda (p t situation proc) ((target-fasl-start (fasl-target)) p t situation proc)))
(set! $fasl-start (lambda (p t situation x proc) ((target-fasl-start (fasl-target)) p t situation x proc)))
(set! $fasl-table (case-lambda
[() ((target-fasl-table (fasl-target)))]
[(external?-pred) ((target-fasl-table (fasl-target)) external?-pred)]))