Ensure that newspace is the space in front when dumping an image the
prevent relocation on startup.
This commit is contained in:
parent
671f2c0181
commit
8f1dfb6935
|
@ -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)
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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.)
|
||||||
|
|
Loading…
Reference in New Issue