Ensure that newspace is the space in front when dumping an image the

prevent relocation on startup.
This commit is contained in:
mainzelm 2002-08-15 16:35:26 +00:00
parent 671f2c0181
commit 8f1dfb6935
5 changed files with 23 additions and 7 deletions

View File

@ -59,6 +59,9 @@
(swap! *newspace-begin* *oldspace-begin*) (swap! *newspace-begin* *oldspace-begin*)
(swap! *newspace-end* *oldspace-end*)) (swap! *newspace-end* *oldspace-end*))
(define (s48-newspace<oldspace?)
(address< s48-*limit* *oldspace-limit*))
;---------------- ;----------------
(define (s48-available? cells) (define (s48-available? cells)

View File

@ -135,6 +135,7 @@
(define-interface heap-interface (define-interface heap-interface
(export s48-available (export s48-available
s48-heap-size s48-heap-size
s48-newspace<oldspace?
s48-find-all s48-find-all
s48-find-all-records s48-find-all-records

View File

@ -19,6 +19,8 @@
(define-structure heap heap-interface (define-structure heap heap-interface
(open prescheme) (open prescheme)
(begin (begin
(define s48-newspace<oldspace?
(external "s48_newspaceLoldspaceP" (=> () boolean)))
(define s48-available (define s48-available
(external "s48_available" (=> () integer))) (external "s48_available" (=> () integer)))
(define s48-heap-size (define s48-heap-size

View File

@ -83,7 +83,7 @@
interpreter-internal interpreter-internal
channel-io vmio channel-io vmio
memory data struct memory data struct
images interpreter-gc images interpreter-gc heap
symbols external-opcodes symbols external-opcodes
stack ;pop stack ;pop
stob) ;immutable stob) ;immutable

View File

@ -414,11 +414,21 @@
(let ((status (write-string (extract-string comment-string) port))) (let ((status (write-string (extract-string comment-string) port)))
(if (error? status) (if (error? status)
(port-lose (enum exception os-error) status port) (port-lose (enum exception os-error) status port)
(let ((status (s48-write-image resume-proc port))) ;; little hack for faster startup:
(if (error? status) ;; trigger a GC to ensure newspace is behind oldspace
(port-lose (enum exception os-error) status port) ;; write-image will also GC and thereby move newspace
(let ((status (close-output-port port))) ;; to the front.
(if (error? status) ;; We can't do this in s48-write-image because it doesn't
;; know collect-saving-temp.
(let ((resume-proc
(if (s48-newspace<oldspace?)
(collect-saving-temp resume-proc)
resume-proc)))
(let ((status (s48-write-image resume-proc port)))
(if (error? status)
(port-lose (enum exception os-error) status port)
(let ((status (close-output-port port)))
(if (error? status)
(lose (enum exception os-error) status) (lose (enum exception os-error) status)
(receive (undumpables undumpable-count) (receive (undumpables undumpable-count)
(s48-undumpable-records) (s48-undumpable-records)
@ -430,7 +440,7 @@
resume-proc resume-proc
comment-string comment-string
undumpables undumpables
(enter-fixnum undumpable-count)))))))))))))))) (enter-fixnum undumpable-count)))))))))))))))))
; READ-IMAGE needs to protect some values against GCs (this can't be with ; READ-IMAGE needs to protect some values against GCs (this can't be with
; READ-IMAGE as that is compiled separately.) ; READ-IMAGE as that is compiled separately.)