avoid fasl overflow of C stack
When writing a fasl stream, add extra graph points as needed to limit recursive reading to about 500 non-tail recursions. original commit: a6759efdc6ac68e45ec8755a5fe9b75038e173a5
This commit is contained in:
Matthew Flatt
parent
03a33fb4fc
commit
6d3fc30233
2
LOG
2
LOG
|
|
@ -1027,3 +1027,5 @@
|
|||
cpnanopass.ss, x86_64.ss, x86.ss, foreign2.c, foreign.ms
|
||||
- added initialization of seginfo sorted and trigger_ephemerons fields.
|
||||
segment.c
|
||||
- avoid fasl overflow of C stack
|
||||
fasl.ss, compile.ss, cmacros.ss, fasl.c, 6.ms
|
||||
|
|
|
|||
7
c/fasl.c
7
c/fasl.c
|
|
@ -961,6 +961,13 @@ static void faslin(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f) {
|
|||
faslin(tc, &INITCDR(p), t, pstrbuf, f);
|
||||
return;
|
||||
}
|
||||
case fasl_type_begin: {
|
||||
uptr n = uptrin(f) - 1; ptr v;
|
||||
while (n--)
|
||||
faslin(tc, &v, t, pstrbuf, f);
|
||||
faslin(tc, x, t, pstrbuf, f);
|
||||
return;
|
||||
}
|
||||
default:
|
||||
S_error2("", "invalid object type ~d in fasl file ~a", FIX(ty), f->uf->path);
|
||||
}
|
||||
|
|
|
|||
40
mats/6.ms
40
mats/6.ms
|
|
@ -970,6 +970,46 @@
|
|||
'(#t #f #t #t #f #t))
|
||||
)
|
||||
|
||||
(mat fasl-depth
|
||||
(begin
|
||||
(define fasl-deep-N 100000)
|
||||
(define (check v)
|
||||
(let-values ([(o get) (open-bytevector-output-port)])
|
||||
(fasl-write v o)
|
||||
(equal? v (fasl-read (open-bytevector-input-port (get))))))
|
||||
(define (check-mk mk)
|
||||
(check (let loop ([n fasl-deep-N])
|
||||
(if (zero? n)
|
||||
'done
|
||||
(mk (loop (sub1 n)))))))
|
||||
(define-record-type other
|
||||
(fields val))
|
||||
(record-type-equal-procedure (record-type-descriptor other)
|
||||
(lambda (a b eql?)
|
||||
(eql? (other-val a) (other-val b))))
|
||||
#t)
|
||||
|
||||
(check-mk vector)
|
||||
(check-mk box)
|
||||
(check-mk list)
|
||||
(check-mk (lambda (v) (cons 'x v)))
|
||||
(check-mk make-other)
|
||||
|
||||
;; Generate a chain of code records:
|
||||
(let-values ([(o get) (open-bytevector-output-port)])
|
||||
(compile-to-port
|
||||
(list
|
||||
`(lambda ()
|
||||
,(let loop ([n fasl-deep-N])
|
||||
(if (zero? n)
|
||||
''end
|
||||
`(if (stop?)
|
||||
'stop
|
||||
,(loop (sub1 n)))))))
|
||||
o)
|
||||
(fasl-read (open-bytevector-input-port (get)))
|
||||
#t))
|
||||
|
||||
(mat clear-output-port ; test interactively
|
||||
(procedure? clear-output-port)
|
||||
)
|
||||
|
|
|
|||
|
|
@ -455,6 +455,8 @@
|
|||
(define-constant fasl-type-immutable-bytevector 39)
|
||||
(define-constant fasl-type-immutable-box 40)
|
||||
|
||||
(define-constant fasl-type-begin 41)
|
||||
|
||||
(define-constant fasl-fld-ptr 0)
|
||||
(define-constant fasl-fld-u8 1)
|
||||
(define-constant fasl-fld-i16 2)
|
||||
|
|
|
|||
54
s/compile.ss
54
s/compile.ss
|
|
@ -229,48 +229,48 @@
|
|||
|
||||
(define c-build-fasl
|
||||
(lambda (x t a?)
|
||||
(let build ([x x])
|
||||
(let build ([x x] [d 0])
|
||||
(record-case x
|
||||
[(object) (x) ($fasl-enter x t a?)]
|
||||
[(object) (x) ($fasl-enter x t a? d)]
|
||||
[(closure) func
|
||||
($fasl-bld-graph x t a?
|
||||
(lambda (x t a?)
|
||||
(build ($c-func-code-record func))))]
|
||||
($fasl-bld-graph x t a? d #f
|
||||
(lambda (x t a? d)
|
||||
(build ($c-func-code-record func) d)))]
|
||||
[(code) stuff
|
||||
($fasl-bld-graph x t a?
|
||||
(lambda (x t a?)
|
||||
($fasl-bld-graph x t a? d #f
|
||||
(lambda (x t a? d)
|
||||
(record-case x
|
||||
[(code) (func subtype free name arity-mask size code-list info pinfo*)
|
||||
($fasl-enter name t a?)
|
||||
($fasl-enter arity-mask t a?)
|
||||
($fasl-enter info t a?)
|
||||
($fasl-enter pinfo* t a?)
|
||||
($fasl-enter name t a? d)
|
||||
($fasl-enter arity-mask t a? d)
|
||||
($fasl-enter info t a? d)
|
||||
($fasl-enter pinfo* t a? d)
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(record-case x
|
||||
[(abs) (n x) (build x)]
|
||||
[(abs) (n x) (build x d)]
|
||||
[else
|
||||
(constant-case architecture
|
||||
[(x86)
|
||||
(record-case x
|
||||
[(rel) (n x) (build x)]
|
||||
[(rel) (n x) (build x d)]
|
||||
[else (void)])]
|
||||
[(x86_64)
|
||||
(record-case x
|
||||
[(x86_64-jump x86_64-call) (n x) (build x)]
|
||||
[(x86_64-jump x86_64-call) (n x) (build x d)]
|
||||
[else (void)])]
|
||||
[(arm32)
|
||||
(record-case x
|
||||
[(arm32-abs arm32-call arm32-jump) (n x) (build x)]
|
||||
[(arm32-abs arm32-call arm32-jump) (n x) (build x d)]
|
||||
[else (void)])]
|
||||
[(ppc32)
|
||||
(record-case x
|
||||
[(ppc32-abs ppc32-call ppc32-jump) (n x) (build x)]
|
||||
[(ppc32-abs ppc32-call ppc32-jump) (n x) (build x d)]
|
||||
[else (void)])])]))
|
||||
code-list)])))]
|
||||
[(group) elt* (for-each build elt*)]
|
||||
[(revisit-stuff) elt (build elt)]
|
||||
[(visit-stuff) elt (build elt)]))))
|
||||
[(group) elt* (for-each (lambda (elt) (build elt d)) elt*)]
|
||||
[(revisit-stuff) elt (build elt d)]
|
||||
[(visit-stuff) elt (build elt d)]))))
|
||||
|
||||
(include "fasl-helpers.ss")
|
||||
|
||||
|
|
@ -442,8 +442,8 @@
|
|||
(define (c-print-fasl x p)
|
||||
(let ([t ($fasl-table)] [a? (or (generate-inspector-information) (eq? ($compile-profile) 'source))])
|
||||
(c-build-fasl x t a?)
|
||||
($fasl-start p t
|
||||
(lambda (p) (c-faslobj x t p a?)))))
|
||||
($fasl-start x p t
|
||||
(lambda (x p) (c-faslobj x t p a?)))))
|
||||
|
||||
(define-record-type visit-chunk
|
||||
(nongenerative)
|
||||
|
|
@ -611,8 +611,8 @@
|
|||
(lambda ()
|
||||
(parameterize ([$target-machine (machine-type)])
|
||||
(let ([t ($fasl-table)])
|
||||
($fasl-enter x1 t #t)
|
||||
($fasl-start wpoop t (lambda (p) ($fasl-out x1 p t #t))))))))))
|
||||
($fasl-enter x1 t #t 0)
|
||||
($fasl-start x1 wpoop t (lambda (x p) ($fasl-out x p t #t))))))))))
|
||||
(compile-file-help1 x1 op source-info-string)
|
||||
(when hostop
|
||||
; the host library file contains expander output possibly augmented with
|
||||
|
|
@ -622,8 +622,8 @@
|
|||
(lambda ()
|
||||
(parameterize ([$target-machine (machine-type)])
|
||||
(let ([t ($fasl-table)])
|
||||
($fasl-enter x1 t #t)
|
||||
($fasl-start hostop t (lambda (p) ($fasl-out x1 p t #t)))))))))
|
||||
($fasl-enter x1 t #t 0)
|
||||
($fasl-start x1 hostop t (lambda (x p) ($fasl-out x p t #t)))))))))
|
||||
(cfh0 (+ n 1)))))))))
|
||||
|
||||
(define library/program-info?
|
||||
|
|
@ -1378,8 +1378,8 @@
|
|||
(let ([t ($fasl-table)])
|
||||
(let ([x (fold-left (lambda (outer ir) (with-output-language (Lexpand Outer) `(group ,outer ,ir)))
|
||||
(car ir*) (cdr ir*))])
|
||||
($fasl-enter x t #t)
|
||||
($fasl-start wpoop t (lambda (p) ($fasl-out x p t #t)))))))))
|
||||
($fasl-enter x t #t 0)
|
||||
($fasl-start x wpoop t (lambda (x p) ($fasl-out x p t #t)))))))))
|
||||
(close-port wpoop))))))
|
||||
|
||||
(define build-required-library-list
|
||||
|
|
|
|||
141
s/fasl.ss
141
s/fasl.ss
|
|
@ -53,47 +53,47 @@
|
|||
(include "fasl-helpers.ss")
|
||||
|
||||
(define bld-pair
|
||||
(lambda (x t a?)
|
||||
(bld (car x) t a?)
|
||||
(bld (cdr x) t a?)))
|
||||
(lambda (x t a? d)
|
||||
(bld (car x) t a? d)
|
||||
(bld (cdr x) t a? d)))
|
||||
|
||||
(define bld-vector
|
||||
(lambda (x t a?)
|
||||
(lambda (x t a? d)
|
||||
(let ([len (vector-length x)])
|
||||
(let bldvec ([i 0])
|
||||
(unless (fx= i len)
|
||||
(bld (vector-ref x i) t a?)
|
||||
(bld (vector-ref x i) t a? d)
|
||||
(bldvec (fx+ i 1)))))))
|
||||
|
||||
(define bld-record
|
||||
(lambda (x t a?)
|
||||
(lambda (x t a? d)
|
||||
(unless (eq? x #!base-rtd)
|
||||
(really-bld-record x t a?))))
|
||||
(really-bld-record x t a? d))))
|
||||
|
||||
(define really-bld-record
|
||||
(lambda (x t a?)
|
||||
(lambda (x t a? d)
|
||||
(let ([rtd ($record-type-descriptor x)])
|
||||
(bld rtd t a?)
|
||||
(bld rtd t a? d)
|
||||
(do ([flds (rtd-flds rtd) (cdr flds)] [i 0 (+ i 1)])
|
||||
((null? flds))
|
||||
(when (memq (fld-type (car flds)) '(scheme-object ptr))
|
||||
(bld ((csv7:record-field-accessor rtd i) x) t a?))))))
|
||||
(bld ((csv7:record-field-accessor rtd i) x) t a? d))))))
|
||||
|
||||
(define bld-ht
|
||||
(lambda (x t a?)
|
||||
(lambda (x t a? d)
|
||||
(let-values ([(keyvec valvec) (hashtable-entries x)])
|
||||
(vector-for-each
|
||||
(lambda (key val)
|
||||
(bld key t a?)
|
||||
(bld val t a?))
|
||||
(bld key t a? d)
|
||||
(bld val t a? d))
|
||||
keyvec valvec))))
|
||||
|
||||
(define bld-box
|
||||
(lambda (x t a?)
|
||||
(bld (unbox x) t a?)))
|
||||
(lambda (x t a? d)
|
||||
(bld (unbox x) t a? d)))
|
||||
|
||||
(define bld-simple
|
||||
(lambda (x t a?)
|
||||
(lambda (x t a? d)
|
||||
(void)))
|
||||
|
||||
(module (bld-graph dump-graph reset-dump-graph)
|
||||
|
|
@ -129,7 +129,7 @@
|
|||
(printf "~10s ~10s ~s\n" entry dup (car cat)))
|
||||
vcat ventry vdup))))
|
||||
(define bld-graph
|
||||
(lambda (x t a? handler)
|
||||
(lambda (x t a? d inner? handler)
|
||||
(let ([a (eq-hashtable-cell (table-hash t) x 'first)])
|
||||
(let ([p (cdr a)])
|
||||
(cond
|
||||
|
|
@ -138,8 +138,16 @@
|
|||
(when (fx= (modulo n 10000) 0)
|
||||
(printf "entries = ~s, ba = ~s, count = ~s\n" n (bytes-allocated) (table-count t))))
|
||||
(record! ventry x)
|
||||
(set-cdr! a #f)
|
||||
(handler x t a?)]
|
||||
(cond
|
||||
[(fx>= d 500)
|
||||
;; Limit depth of recursion by lifting to a `fasl-begin` graph:
|
||||
(let ([n (table-count t)])
|
||||
(set-cdr! a (cons n (if inner? 'inner-begin 'begin)))
|
||||
(table-count-set! t (fx+ n 1)))
|
||||
(handler x t a? 0)]
|
||||
[else
|
||||
(set-cdr! a #f)
|
||||
(handler x t a? (fx+ d 1))])]
|
||||
[(not p)
|
||||
(record! vdup x)
|
||||
(let ([n (table-count t)])
|
||||
|
|
@ -148,20 +156,20 @@
|
|||
(reset-dump-graph))
|
||||
|
||||
(define bld
|
||||
(lambda (x t a?)
|
||||
(lambda (x t a? d)
|
||||
(cond
|
||||
[(pair? x) (bld-graph x t a? bld-pair)]
|
||||
[(vector? x) (bld-graph x t a? bld-vector)]
|
||||
[(or (symbol? x) (string? x)) (bld-graph x t a? bld-simple)]
|
||||
[(pair? x) (bld-graph x t a? d #t bld-pair)]
|
||||
[(vector? x) (bld-graph x t a? d #t bld-vector)]
|
||||
[(or (symbol? x) (string? x)) (bld-graph x t a? d #t bld-simple)]
|
||||
[(and (annotation? x) (not a?))
|
||||
(bld (annotation-stripped x) t a?)]
|
||||
[(eq-hashtable? x) (bld-graph x t a? bld-ht)]
|
||||
[(symbol-hashtable? x) (bld-graph x t a? bld-ht)]
|
||||
[($record? x) (bld-graph x t a? bld-record)]
|
||||
[(box? x) (bld-graph x t a? bld-box)]
|
||||
(bld (annotation-stripped x) t a? d)]
|
||||
[(eq-hashtable? x) (bld-graph x t a? d #t bld-ht)]
|
||||
[(symbol-hashtable? x) (bld-graph x t a? d #t bld-ht)]
|
||||
[($record? x) (bld-graph x t a? d #t bld-record)]
|
||||
[(box? x) (bld-graph x t a? d #t bld-box)]
|
||||
[(or (large-integer? x) (ratnum? x) ($inexactnum? x) ($exactnum? x)
|
||||
(fxvector? x) (bytevector? x))
|
||||
(bld-graph x t a? bld-simple)])))
|
||||
(bld-graph x t a? d #t bld-simple)])))
|
||||
|
||||
(module (small-integer? large-integer?)
|
||||
(define least-small-integer (- (expt 2 31)))
|
||||
|
|
@ -566,20 +574,53 @@
|
|||
[($rtd-counts? x) (wrf-immediate (constant sfalse) p)]
|
||||
[else ($oops 'fasl-write "invalid fasl object ~s" x)])))
|
||||
|
||||
(define start
|
||||
(lambda (p t proc)
|
||||
(dump-graph)
|
||||
(let-values ([(bv* size)
|
||||
(let-values ([(p extractor) ($open-bytevector-list-output-port)])
|
||||
(let ([n (table-count t)])
|
||||
(unless (fx= n 0)
|
||||
(put-u8 p (constant fasl-type-graph))
|
||||
(put-uptr p n)))
|
||||
(proc p)
|
||||
(extractor))])
|
||||
(put-u8 p (constant fasl-type-fasl-size))
|
||||
(put-uptr p size)
|
||||
(for-each (lambda (bv) (put-bytevector p bv)) bv*))))
|
||||
(module (start)
|
||||
(define start
|
||||
(lambda (x p t proc)
|
||||
(dump-graph)
|
||||
(let-values ([(bv* size)
|
||||
(let-values ([(p extractor) ($open-bytevector-list-output-port)])
|
||||
(let ([n (table-count t)])
|
||||
(unless (fx= n 0)
|
||||
(put-u8 p (constant fasl-type-graph))
|
||||
(put-uptr p n)))
|
||||
(let ([begins (extract-begins t)])
|
||||
(unless (null? begins)
|
||||
(put-u8 p (constant fasl-type-begin))
|
||||
(put-uptr p (fx+ (length begins) 1))
|
||||
(for-each (lambda (x)
|
||||
(if (eq? 'begin (cdr (eq-hashtable-ref (table-hash t) x #f)))
|
||||
(proc x p)
|
||||
(wrf x p t #t)))
|
||||
begins)))
|
||||
(proc x p)
|
||||
(extractor))])
|
||||
(put-u8 p (constant fasl-type-fasl-size))
|
||||
(put-uptr p size)
|
||||
(for-each (lambda (bv) (put-bytevector p bv)) bv*))))
|
||||
|
||||
(define (extract-begins t)
|
||||
(let ([ht (table-hash t)])
|
||||
(let-values ([(keys vals) (hashtable-entries ht)])
|
||||
(let ([len (vector-length keys)])
|
||||
(let loop ([i 0] [begins '()])
|
||||
(cond
|
||||
[(fx= i len)
|
||||
;; Sort so that higher graph numbers are earlier, which
|
||||
;; achieves the intended effect of limiting recursion.
|
||||
(list-sort (lambda (a b)
|
||||
(> (car (eq-hashtable-ref ht a #f))
|
||||
(car (eq-hashtable-ref ht b #f))))
|
||||
begins)]
|
||||
[else
|
||||
(let ([v (vector-ref vals i)])
|
||||
(cond
|
||||
[(not v) (loop (fx+ i 1) begins)]
|
||||
[(or (eq? 'begin (cdr v))
|
||||
(eq? 'inner-begin (cdr v)))
|
||||
(loop (fx+ i 1)
|
||||
(cons (vector-ref keys i) begins))]
|
||||
[else (loop (fx+ i 1) begins)]))])))))))
|
||||
|
||||
(module (fasl-write fasl-file)
|
||||
; when called from fasl-write or fasl-file, pass #t for a? to preserve annotations;
|
||||
|
|
@ -587,8 +628,8 @@
|
|||
(define fasl-one
|
||||
(lambda (x p)
|
||||
(let ([t (make-table)])
|
||||
(bld x t #t)
|
||||
(start p t (lambda (p) (wrf x p t #t))))))
|
||||
(bld x t #t 0)
|
||||
(start x p t (lambda (x p) (wrf x p t #t))))))
|
||||
|
||||
(define-who fasl-write
|
||||
(lambda (x p)
|
||||
|
|
@ -623,8 +664,8 @@
|
|||
(lambda (x p)
|
||||
(emit-header p (constant machine-type-any))
|
||||
(let ([t (make-table)])
|
||||
(bld-graph x t #f really-bld-record)
|
||||
(start p t (lambda (p) (wrf-graph x p t #f really-wrf-record))))))
|
||||
(bld-graph x t #f 0 #t really-bld-record)
|
||||
(start x p t (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))
|
||||
)
|
||||
|
|
@ -635,10 +676,10 @@
|
|||
(let ([target ($fasl-target)])
|
||||
(assert target)
|
||||
target)))
|
||||
(set! $fasl-bld-graph (lambda (x t a? handler) ((target-fasl-bld-graph (fasl-target)) x t a? handler)))
|
||||
(set! $fasl-enter (lambda (x t a?) ((target-fasl-enter (fasl-target)) x t a?)))
|
||||
(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 proc) ((target-fasl-start (fasl-target)) p t proc)))
|
||||
(set! $fasl-start (lambda (x p t proc) ((target-fasl-start (fasl-target)) x p t proc)))
|
||||
(set! $fasl-table (lambda () ((target-fasl-table (fasl-target)))))
|
||||
(set! $fasl-wrf-graph (lambda (x p t a? handler) ((target-fasl-wrf-graph (fasl-target)) x p t a? handler)))
|
||||
(set! $fasl-base-rtd (lambda (x p) ((target-fasl-base-rtd (fasl-target)) x p)))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user