| 1 | ;;;-*- Mode: Lisp; Package: WOOD -*-
|
|---|
| 2 |
|
|---|
| 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|---|
| 4 | ;;
|
|---|
| 5 | ;; wood-gc.lisp
|
|---|
| 6 | ;;
|
|---|
| 7 | ;; A copying garbage collector for Wood
|
|---|
| 8 | ;;
|
|---|
| 9 | ;; Copyright © 1996 Digitool, Inc.
|
|---|
| 10 | ;; Copyright © 1992-1995 Apple Computer, Inc.
|
|---|
| 11 | ;; All rights reserved.
|
|---|
| 12 | ;; Permission is given to use, copy, and modify this software provided
|
|---|
| 13 | ;; that Digitool is given credit in all derivative works.
|
|---|
| 14 | ;; This software is provided "as is". Digitool makes no warranty or
|
|---|
| 15 | ;; representation, either express or implied, with respect to this software,
|
|---|
| 16 | ;; its quality, accuracy, merchantability, or fitness for a particular
|
|---|
| 17 | ;; purpose.
|
|---|
| 18 | ;;
|
|---|
| 19 |
|
|---|
| 20 | ;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|---|
| 21 | ;;
|
|---|
| 22 | ;; Modification History
|
|---|
| 23 | ;; 09/05/98 akh add another argument to gc-pheap-file. :delay-gvector-copy
|
|---|
| 24 | ;; If true gvectors are forwarded and copying the contents is enqueued.
|
|---|
| 25 | ;; Avoid blowing the stack for databases of recursively connected small objects.
|
|---|
| 26 | ;; May blow the queue for databases containing just a few very large objects.
|
|---|
| 27 | ;; 08/28/98 akh remove declare (optimize debug) from gc-copy-cons-internal ??
|
|---|
| 28 | ;; ------------- 0.96
|
|---|
| 29 | ;; ------------- 0.95
|
|---|
| 30 | ;; ------------- 0.94
|
|---|
| 31 | ;; 03/21/96 bill (make-string ... :element-type 'base-character)
|
|---|
| 32 | ;; ------------- 0.93
|
|---|
| 33 | ;; 05/25/95 bill gc-pheap-file-internal takes a new :page-size arg, which is used
|
|---|
| 34 | ;; as the page-size for the new, compacted, pheap. It returns true
|
|---|
| 35 | ;; if the new page size is different than the old one.
|
|---|
| 36 | ;; gc-pheap-file's args, except the first one, are now keywords instead
|
|---|
| 37 | ;; of optional. This is an incompatible change.
|
|---|
| 38 | ;; It takes a new :page-size arg which is passes on to gc-pheap-file-internal.
|
|---|
| 39 | ;; The new file replaces the old if either the page size changed or it is smaller.
|
|---|
| 40 | ;; ------------ 0.9
|
|---|
| 41 | ;; 11/02/94 ows gc-pheap-file-internal takes keyword argument modify-input-file;
|
|---|
| 42 | ;; when true, calls make-forwarding-table instead of open-dc-log.
|
|---|
| 43 | ;; gc-pheap-file-internal copies the mac-file-creator from the input
|
|---|
| 44 | ;; file to the output file.
|
|---|
| 45 | ;; gc-pheap-file takes optional argument modify-input-file
|
|---|
| 46 | ;; gc-pheap-file only swaps files when the size is smaller.
|
|---|
| 47 | ;; new fns make-forwarding-table, forwarding-table-p
|
|---|
| 48 | ;; gc-write-forwarding-pointer, address-forwarded-p check whether
|
|---|
| 49 | ;; the log is a forwarding table.
|
|---|
| 50 | ;; new fns address-forwarded-p, read-forwarded-pointer replace
|
|---|
| 51 | ;; inlined versions of this code in callers.
|
|---|
| 52 | ;; gc-copy-pkg-symbols, gc-copy-ptr, gc-copy-cons-internal
|
|---|
| 53 | ;; call address-forwarded-p, read-forwarded-pointer.
|
|---|
| 54 | ;; 09/26/94 bill gc-copy-bytes uses addr+ instead of incf.
|
|---|
| 55 | ;; Thanx to Christopher T. Wisdo for finding this.
|
|---|
| 56 | ;; ------------- 0.8
|
|---|
| 57 | ;; 03/27/93 bill New file. Doesn't yet deal with consing areas.
|
|---|
| 58 | ;; Also doesn't delete anything from weak hash tables.
|
|---|
| 59 | ;;
|
|---|
| 60 |
|
|---|
| 61 | (in-package :wood)
|
|---|
| 62 |
|
|---|
| 63 | (defvar *delay-gvector-copy* nil)
|
|---|
| 64 |
|
|---|
| 65 | (defun gc-pheap-file (filename &key
|
|---|
| 66 | (external-format :WOOD)
|
|---|
| 67 | (modify-input-file nil)
|
|---|
| 68 | (delay-gvector-copy nil)
|
|---|
| 69 | (page-size nil))
|
|---|
| 70 | (let ((output-filename (ccl::gen-file-name filename))
|
|---|
| 71 | (*delay-gvector-copy* delay-gvector-copy))
|
|---|
| 72 | (unwind-protect
|
|---|
| 73 | (let ((page-size-changed?
|
|---|
| 74 | (gc-pheap-file-internal filename output-filename
|
|---|
| 75 | :external-format external-format
|
|---|
| 76 | :modify-input-file modify-input-file
|
|---|
| 77 | :page-size page-size)))
|
|---|
| 78 | (flet ((file-size (file)
|
|---|
| 79 | (with-open-file (stream file) (file-length stream))))
|
|---|
| 80 | (when (or page-size-changed? (< (file-size output-filename) (file-size filename)))
|
|---|
| 81 | (unless (eql 0 (ccl::exchange-files filename output-filename))
|
|---|
| 82 | (rename-file output-filename filename :if-exists :overwrite)))))
|
|---|
| 83 | (delete-file output-filename))))
|
|---|
| 84 |
|
|---|
| 85 | (defun gc-pheap-file-internal (input-filename output-filename &key
|
|---|
| 86 | temp-filename
|
|---|
| 87 | (external-format :WOOD)
|
|---|
| 88 | (modify-input-file t)
|
|---|
| 89 | page-size
|
|---|
| 90 | &aux page-size-changed?)
|
|---|
| 91 | (when (probe-file output-filename)
|
|---|
| 92 | (error "~s already exists" output-filename))
|
|---|
| 93 | (when temp-filename
|
|---|
| 94 | (when (probe-file temp-filename)
|
|---|
| 95 | (error "~s already exists" temp-filename)))
|
|---|
| 96 | (with-open-pheap (input-pheap input-filename :external-format external-format)
|
|---|
| 97 | (let ((old-page-size (disk-cache-page-size (pheap-disk-cache input-pheap))))
|
|---|
| 98 | (if page-size
|
|---|
| 99 | (unless (eql page-size old-page-size)
|
|---|
| 100 | (setq page-size-changed? t))
|
|---|
| 101 | (setq page-size old-page-size)))
|
|---|
| 102 | (with-open-pheap (output-pheap output-filename
|
|---|
| 103 | :mac-file-creator (mac-file-creator input-filename)
|
|---|
| 104 | :external-format external-format
|
|---|
| 105 | :page-size page-size
|
|---|
| 106 | :if-does-not-exist :create)
|
|---|
| 107 | (if modify-input-file
|
|---|
| 108 | (progn
|
|---|
| 109 | (unless temp-filename
|
|---|
| 110 | (setq temp-filename (ccl::gen-file-name input-filename)))
|
|---|
| 111 | (let ((log (open-dc-log temp-filename (pheap-disk-cache input-pheap)))
|
|---|
| 112 | (q (make-q)))
|
|---|
| 113 | (log-position log 0)
|
|---|
| 114 | (unwind-protect
|
|---|
| 115 | (do-wood-gc input-pheap output-pheap log q)
|
|---|
| 116 | (without-interrupts
|
|---|
| 117 | (restore-from-log-after-gc input-pheap log))
|
|---|
| 118 | (close-dc-log log)
|
|---|
| 119 | (delete-file temp-filename))))
|
|---|
| 120 | (let ((forwarding-table (make-forwarding-table))
|
|---|
| 121 | (q (make-q)))
|
|---|
| 122 | (do-wood-gc input-pheap output-pheap forwarding-table q)))))
|
|---|
| 123 | page-size-changed?)
|
|---|
| 124 |
|
|---|
| 125 | ;; new type
|
|---|
| 126 | (deftype forwarding-table ()
|
|---|
| 127 | ;; The car is a hash-table mapping address -> immediate-value.
|
|---|
| 128 | ;; The cdr is a hash-table mapping address -> pointer-value.
|
|---|
| 129 | 'cons)
|
|---|
| 130 |
|
|---|
| 131 | ;; new macro
|
|---|
| 132 | (defmacro forwarding-table-immediates (forwarding-table)
|
|---|
| 133 | `(car ,forwarding-table))
|
|---|
| 134 |
|
|---|
| 135 | ;; new macro
|
|---|
| 136 | (defmacro forwarding-table-pointers (forwarding-table)
|
|---|
| 137 | `(cdr ,forwarding-table))
|
|---|
| 138 |
|
|---|
| 139 | ;; new function
|
|---|
| 140 | (defun make-forwarding-table ()
|
|---|
| 141 | (cons (make-hash-table :test 'eql)
|
|---|
| 142 | (make-hash-table :test 'eql)))
|
|---|
| 143 |
|
|---|
| 144 | ;; new function
|
|---|
| 145 | (defun forwarding-table-p (log-or-table)
|
|---|
| 146 | (typep log-or-table 'forwarding-table))
|
|---|
| 147 |
|
|---|
| 148 | (defun gc-write-forwarding-pointer (address ptr imm? input-dc log)
|
|---|
| 149 | (if (forwarding-table-p log)
|
|---|
| 150 | (if imm?
|
|---|
| 151 | (setf (gethash address (forwarding-table-immediates log)) ptr)
|
|---|
| 152 | (setf (gethash address (forwarding-table-pointers log)) ptr))
|
|---|
| 153 | (progn
|
|---|
| 154 | (log-write-long log address)
|
|---|
| 155 | (multiple-value-bind (p i) (read-pointer input-dc address)
|
|---|
| 156 | (log-write-pointer log p i)
|
|---|
| 157 | (multiple-value-setq (p i) (read-pointer input-dc (+ address 4)))
|
|---|
| 158 | (log-write-pointer log p i))
|
|---|
| 159 | (setf (read-long input-dc address) $forwarding-pointer-header
|
|---|
| 160 | (read-pointer input-dc (+ address 4) imm?) ptr)))
|
|---|
| 161 | (values ptr imm?))
|
|---|
| 162 |
|
|---|
| 163 | (defun restore-from-log-after-gc (pheap log)
|
|---|
| 164 | (let ((log-eof (log-position log))
|
|---|
| 165 | (dc (pheap-disk-cache pheap)))
|
|---|
| 166 | (log-position log 0)
|
|---|
| 167 | (loop
|
|---|
| 168 | (when (eql log-eof (log-position log))
|
|---|
| 169 | (return))
|
|---|
| 170 | (let ((address (log-read-long log)))
|
|---|
| 171 | (multiple-value-bind (ptr imm?) (log-read-pointer log)
|
|---|
| 172 | (setf (read-pointer dc address imm?) ptr)
|
|---|
| 173 | (multiple-value-setq (ptr imm?) (log-read-pointer log))
|
|---|
| 174 | (setf (read-pointer dc (+ address 4) imm?) ptr))))))
|
|---|
| 175 |
|
|---|
| 176 | (defun do-wood-gc (input-pheap output-pheap log q)
|
|---|
| 177 | (let ((input-dc (pheap-disk-cache input-pheap))
|
|---|
| 178 | (output-dc (pheap-disk-cache output-pheap)))
|
|---|
| 179 | (multiple-value-bind (ptr imm?)
|
|---|
| 180 | (dc-root-object input-dc)
|
|---|
| 181 | (multiple-value-setq (ptr imm?)
|
|---|
| 182 | (gc-copy-ptr ptr imm? input-dc output-dc log q))
|
|---|
| 183 | (setf (dc-root-object output-dc imm?) ptr)
|
|---|
| 184 | (gc-clear-q input-dc output-dc log q)
|
|---|
| 185 | ; Copy any symbols that have bindings
|
|---|
| 186 | (let ((pkg-btree (dc-package-btree input-dc nil))
|
|---|
| 187 | (mapper #'(lambda (input-dc name pkg pkg-imm?)
|
|---|
| 188 | (declare (ignore name pkg-imm?))
|
|---|
| 189 | (gc-copy-pkg-symbols pkg input-dc output-dc log q))))
|
|---|
| 190 | (declare (dynamic-extent mapper))
|
|---|
| 191 | (when pkg-btree
|
|---|
| 192 | (dc-map-btree input-dc pkg-btree mapper))))))
|
|---|
| 193 |
|
|---|
| 194 | (defun gc-copy-pkg-symbols (pkg input-dc output-dc log q)
|
|---|
| 195 | (let ((mapper #'(lambda (input-dc name sym imm?)
|
|---|
| 196 | (declare (ignore name imm?))
|
|---|
| 197 | (unless (pointer-tagp sym $t_symbol)
|
|---|
| 198 | (error "Not a symbol: #x~x" sym))
|
|---|
| 199 | (let ((addr (- sym $t_symbol)))
|
|---|
| 200 | (unless (address-forwarded-p input-dc addr log)
|
|---|
| 201 | (when (dc-symbol-values-list input-dc sym)
|
|---|
| 202 | (gc-copy-symbol sym addr input-dc output-dc log q)
|
|---|
| 203 | (gc-clear-q input-dc output-dc log q)))))))
|
|---|
| 204 | (declare (dynamic-extent mapper))
|
|---|
| 205 | (dc-map-btree input-dc (dc-%svref input-dc pkg $pkg.btree) mapper)))
|
|---|
| 206 |
|
|---|
| 207 | ; gc-copy-ptr allocates space in the output pheap and leaves
|
|---|
| 208 | ; a forwarding pointer in the input pheap.
|
|---|
| 209 | ; It writes an entry to the log to restore the word written over by
|
|---|
| 210 | ; the forwarding pointer, and pushes the output object on the Q to
|
|---|
| 211 | ; be passed later to gc-copy-object
|
|---|
| 212 | (defun gc-copy-ptr (ptr imm? input-dc output-dc log q)
|
|---|
| 213 | (when imm?
|
|---|
| 214 | (return-from gc-copy-ptr (values ptr t)))
|
|---|
| 215 | (when (eql ptr $pheap-nil)
|
|---|
| 216 | (return-from gc-copy-ptr ptr))
|
|---|
| 217 | (let ((address (pointer-address ptr)))
|
|---|
| 218 | (when (address-forwarded-p input-dc address log)
|
|---|
| 219 | (return-from gc-copy-ptr (read-forwarded-pointer input-dc address log)))
|
|---|
| 220 | (funcall (svref #(gc-copy-err ; $t_fixnum
|
|---|
| 221 | gc-copy-vector ; $t_vector
|
|---|
| 222 | gc-copy-symbol ; $t_symbol
|
|---|
| 223 | gc-copy-dfloat ; $t_dfloat
|
|---|
| 224 | gc-copy-cons ; $t_cons
|
|---|
| 225 | gc-copy-err ; $t_sfloat
|
|---|
| 226 | gc-copy-lfun ; $t_lfun
|
|---|
| 227 | gc-copy-err) ; $t_imm
|
|---|
| 228 | (pointer-tag ptr))
|
|---|
| 229 | ptr address input-dc output-dc log q)))
|
|---|
| 230 |
|
|---|
| 231 | (defun address-forwarded-p (input-dc address log)
|
|---|
| 232 | (if (forwarding-table-p log)
|
|---|
| 233 | (or (gethash address (forwarding-table-immediates log))
|
|---|
| 234 | (gethash address (forwarding-table-pointers log)))
|
|---|
| 235 | (and (eql (read-word input-dc (+ address 2))
|
|---|
| 236 | (logand #xffff $forwarding-pointer-header))
|
|---|
| 237 | (eql (read-word input-dc address)
|
|---|
| 238 | (ash $forwarding-pointer-header -16)))))
|
|---|
| 239 |
|
|---|
| 240 | (defun read-forwarded-pointer (input-dc address log)
|
|---|
| 241 | (if (forwarding-table-p log)
|
|---|
| 242 | ;; Return a second value t iff the address maps to an
|
|---|
| 243 | ;; immediate value. OR only returns multiple values of
|
|---|
| 244 | ;; its last form, so it does this for free.
|
|---|
| 245 | (or (gethash address (forwarding-table-pointers log))
|
|---|
| 246 | (gethash address (forwarding-table-immediates log)))
|
|---|
| 247 | (read-pointer input-dc (+ address 4))))
|
|---|
| 248 |
|
|---|
| 249 | (defun gc-copy-err (ptr address input-dc output-dc log q)
|
|---|
| 250 | (declare (ignore ptr address input-dc output-dc log q))
|
|---|
| 251 | (error "Dispatched on an immediate"))
|
|---|
| 252 |
|
|---|
| 253 | ; The definitions for these are at the end of this file.
|
|---|
| 254 | (declaim (special *subtype-node-p* *subtype-special-copy-function*))
|
|---|
| 255 |
|
|---|
| 256 | (defun gc-copy-vector (vector address input-dc output-dc log q)
|
|---|
| 257 | (let* ((size (dc-%vector-size input-dc vector))
|
|---|
| 258 | (subtype (dc-%vector-subtype input-dc vector)))
|
|---|
| 259 | (if (svref *subtype-node-p* subtype)
|
|---|
| 260 | (let ((copyer (or (cdr (assq subtype *subtype-special-copy-function*))
|
|---|
| 261 | 'gc-copy-gvector)))
|
|---|
| 262 | (funcall copyer vector address size input-dc output-dc log q))
|
|---|
| 263 | (let ((p (+ (gc-copy-bytes address (+ $vector-header-size (normalize-size size))
|
|---|
| 264 | input-dc output-dc)
|
|---|
| 265 | $t_vector)))
|
|---|
| 266 | (gc-write-forwarding-pointer address p nil input-dc log)
|
|---|
| 267 | p))))
|
|---|
| 268 |
|
|---|
| 269 | (defun gc-copy-gvector (vector address size input-dc output-dc log q)
|
|---|
| 270 | (let ((p (+ (gc-copy-bytes address (+ $vector-header-size (normalize-size size))
|
|---|
| 271 | input-dc output-dc)
|
|---|
| 272 | $t_vector)))
|
|---|
| 273 | (gc-write-forwarding-pointer address p nil input-dc log)
|
|---|
| 274 | (if *delay-gvector-copy*
|
|---|
| 275 | (enq q (cons vector p))
|
|---|
| 276 | (dotimes (i (ash size -2))
|
|---|
| 277 | (multiple-value-bind (ptr imm?) (dc-%svref input-dc vector i)
|
|---|
| 278 | (multiple-value-setq (ptr imm?)
|
|---|
| 279 | (gc-copy-ptr ptr imm? input-dc output-dc log q))
|
|---|
| 280 | (setf (dc-%svref output-dc p i imm?) ptr))))
|
|---|
| 281 | p))
|
|---|
| 282 |
|
|---|
| 283 | ; Just cons a package. We'll copy symbols later
|
|---|
| 284 | (defun gc-copy-pkg (pkg address size input-dc output-dc log q)
|
|---|
| 285 | (declare (ignore size q))
|
|---|
| 286 | (let* ((names (pointer-load (disk-cache-pheap input-dc)
|
|---|
| 287 | (dc-%svref input-dc pkg $pkg.names)
|
|---|
| 288 | :default
|
|---|
| 289 | input-dc))
|
|---|
| 290 | (res (dc-make-package output-dc (car names) (cdr names))))
|
|---|
| 291 | (gc-write-forwarding-pointer address res nil input-dc log)
|
|---|
| 292 | res))
|
|---|
| 293 |
|
|---|
| 294 | (defun gc-copy-area (area address size input-dc output-dc log q)
|
|---|
| 295 | (declare (ignore area address size input-dc output-dc log q))
|
|---|
| 296 | (error "Wood's GC doesn't deal with areas yet!"))
|
|---|
| 297 |
|
|---|
| 298 | (defun gc-copy-error (vector address size input-dc output-dc log q)
|
|---|
| 299 | (declare (ignore address size output-dc log q))
|
|---|
| 300 | (let ((subtype (dc-%vector-subtype input-dc vector)))
|
|---|
| 301 | (error "Can't copy vectors of subtype: ~s" subtype)))
|
|---|
| 302 |
|
|---|
| 303 | (defun gc-copy-btree (btree address size input-dc output-dc log q)
|
|---|
| 304 | (declare (ignore size))
|
|---|
| 305 | (let ((p (dc-make-btree output-dc nil (dc-%svref input-dc btree $btree.type))))
|
|---|
| 306 | (gc-write-forwarding-pointer address p nil input-dc log)
|
|---|
| 307 | (enq q (cons btree p)) ; delay the copying
|
|---|
| 308 | p))
|
|---|
| 309 |
|
|---|
| 310 | ; Currently, btrees are the only things that are not copied immediately.
|
|---|
| 311 | ; Now optionally gvectors are also not copied immediately
|
|---|
| 312 | ; Eventually, we may want to use an algorithm that improves locality better.
|
|---|
| 313 | (defun gc-clear-q (input-dc output-dc log q)
|
|---|
| 314 | (loop
|
|---|
| 315 | (when (q-empty-p q) (return))
|
|---|
| 316 | (destructuring-bind (in . out) (deq q)
|
|---|
| 317 | ;(break)
|
|---|
| 318 | (if *delay-gvector-copy*
|
|---|
| 319 | (let ((subtype (dc-%vector-subtype output-dc out)))
|
|---|
| 320 | (if (eq subtype $v_btree)
|
|---|
| 321 | (gc-map-btree in out input-dc output-dc log q)
|
|---|
| 322 | (gc-finish-gvector in out input-dc output-dc log q)))
|
|---|
| 323 | (gc-map-btree in out input-dc output-dc log q)))))
|
|---|
| 324 |
|
|---|
| 325 | (defun gc-finish-gvector (in out input-dc output-dc log q)
|
|---|
| 326 | (let ((size (dc-%vector-size output-dc out)))
|
|---|
| 327 | ;(break)
|
|---|
| 328 | (dotimes (i (ash size -2))
|
|---|
| 329 | (multiple-value-bind (ptr imm?) (dc-%svref input-dc in i)
|
|---|
| 330 | (multiple-value-setq (ptr imm?)
|
|---|
| 331 | (gc-copy-ptr ptr imm? input-dc output-dc log q))
|
|---|
| 332 | (setf (dc-%svref output-dc out i imm?) ptr)))))
|
|---|
| 333 |
|
|---|
| 334 | (defun gc-map-btree (in out input-dc output-dc log q)
|
|---|
| 335 | (let ((type (dc-%svref output-dc out $btree.type))
|
|---|
| 336 | (*forwarded-btree* in)) ; prevent type error due to forwarding pointer
|
|---|
| 337 | (if (logbitp $btree-type_eqhash-bit type)
|
|---|
| 338 | ; Doesn't handle weak hash tables weakly yet.
|
|---|
| 339 | (let ((mapper #'(lambda (input-dc key-string value value-imm?)
|
|---|
| 340 | (multiple-value-bind (key key-imm?) (dc-hash-key-value key-string)
|
|---|
| 341 | (multiple-value-setq (key key-imm?)
|
|---|
| 342 | (gc-copy-ptr key key-imm? input-dc output-dc log q))
|
|---|
| 343 | (multiple-value-setq (value value-imm?)
|
|---|
| 344 | (gc-copy-ptr value value-imm? input-dc output-dc log q))
|
|---|
| 345 | (dc-puthash output-dc key key-imm? out value value-imm?)))))
|
|---|
| 346 | (declare (dynamic-extent mapper))
|
|---|
| 347 | (dc-map-btree input-dc in mapper))
|
|---|
| 348 | (let ((mapper #'(lambda (input-dc key-string value value-imm?)
|
|---|
| 349 | (multiple-value-setq (value value-imm?)
|
|---|
| 350 | (gc-copy-ptr value value-imm? input-dc output-dc log q))
|
|---|
| 351 | (dc-btree-store output-dc out key-string value value-imm?))))
|
|---|
| 352 | (declare (dynamic-extent mapper))
|
|---|
| 353 | (dc-map-btree input-dc in mapper)))))
|
|---|
| 354 |
|
|---|
| 355 | (defun gc-copy-class (class address size input-dc output-dc log q)
|
|---|
| 356 | (declare (ignore size))
|
|---|
| 357 | (let* ((hash (dc-class-hash output-dc t))
|
|---|
| 358 | (res (dc-make-uvector output-dc $class-size $v_class)))
|
|---|
| 359 | (multiple-value-bind (name name-imm?) (dc-%svref input-dc class $class.name)
|
|---|
| 360 | (multiple-value-bind (wrapper wrapper-imm?) (dc-%svref input-dc class $class.own-wrapper)
|
|---|
| 361 | (gc-write-forwarding-pointer address res nil input-dc log)
|
|---|
| 362 | (multiple-value-setq (name name-imm?)
|
|---|
| 363 | (gc-copy-ptr name name-imm? input-dc output-dc log q))
|
|---|
| 364 | (multiple-value-setq (wrapper wrapper-imm?)
|
|---|
| 365 | (gc-copy-ptr wrapper wrapper-imm? input-dc output-dc log q))
|
|---|
| 366 | (setf (dc-%svref output-dc res $class.name name-imm?) name
|
|---|
| 367 | (dc-%svref output-dc res $class.own-wrapper wrapper-imm?) wrapper)
|
|---|
| 368 | (dc-puthash output-dc name name-imm? hash res)))
|
|---|
| 369 | res))
|
|---|
| 370 |
|
|---|
| 371 | (defun gc-copy-symbol (symbol address input-dc output-dc log q)
|
|---|
| 372 | (let* ((pkg (gc-copy-ptr (dc-symbol-package input-dc symbol) nil
|
|---|
| 373 | input-dc output-dc log q))
|
|---|
| 374 | (print-name (gc-copy-ptr (dc-symbol-name input-dc symbol) nil
|
|---|
| 375 | input-dc output-dc log q))
|
|---|
| 376 | (values-list (dc-symbol-values-list input-dc symbol))
|
|---|
| 377 | (len (dc-%vector-size output-dc print-name))
|
|---|
| 378 | (str (make-string len :element-type 'base-character)))
|
|---|
| 379 | (declare (dynamic-extent str))
|
|---|
| 380 | (read-string output-dc (+ print-name $v_data) len str)
|
|---|
| 381 | (let ((p (dc-%make-symbol output-dc str pkg nil nil nil print-name)))
|
|---|
| 382 | (gc-write-forwarding-pointer address p nil input-dc log)
|
|---|
| 383 | (when values-list
|
|---|
| 384 | (setf (read-pointer output-dc (+ p $sym_values))
|
|---|
| 385 | (gc-copy-ptr values-list nil input-dc output-dc log q)))
|
|---|
| 386 | p)))
|
|---|
| 387 |
|
|---|
| 388 | (defun gc-copy-dfloat (dfloat address input-dc output-dc log q)
|
|---|
| 389 | (declare (ignore dfloat q))
|
|---|
| 390 | (let* ((p (gc-copy-bytes address 8 input-dc output-dc))
|
|---|
| 391 | (res (+ p $t_dfloat)))
|
|---|
| 392 | (gc-write-forwarding-pointer address res nil input-dc log)
|
|---|
| 393 | res))
|
|---|
| 394 |
|
|---|
| 395 | (defun gc-copy-cons (cons address input-dc output-dc log q)
|
|---|
| 396 | (declare (ignore cons))
|
|---|
| 397 | (let* ((p (gc-copy-bytes address 8 input-dc output-dc))
|
|---|
| 398 | (res (+ p $t_cons)))
|
|---|
| 399 | (gc-write-forwarding-pointer address res nil input-dc log)
|
|---|
| 400 | (gc-copy-cons-internal res input-dc output-dc log q)
|
|---|
| 401 | res))
|
|---|
| 402 |
|
|---|
| 403 | (defun gc-copy-cons-internal (cons input-dc output-dc log q)
|
|---|
| 404 | ;(declare (optimize debug))
|
|---|
| 405 | (multiple-value-bind (ptr imm?) (dc-car output-dc cons)
|
|---|
| 406 | (unless imm?
|
|---|
| 407 | (multiple-value-setq (ptr imm?)
|
|---|
| 408 | (gc-copy-ptr ptr imm? input-dc output-dc log q)))
|
|---|
| 409 | (setf (dc-car output-dc cons imm?) ptr)
|
|---|
| 410 | (multiple-value-setq (ptr imm?) (dc-cdr output-dc cons))
|
|---|
| 411 | (cond (imm? (setf (dc-cdr output-dc cons t) ptr))
|
|---|
| 412 | ((not (pointer-tagp ptr $t_cons))
|
|---|
| 413 | (setq ptr (gc-copy-ptr ptr nil input-dc output-dc log q))
|
|---|
| 414 | (setf (dc-cdr output-dc cons) ptr))
|
|---|
| 415 | ((eql ptr $pheap-nil)
|
|---|
| 416 | (setf (dc-cdr output-dc cons) $pheap-nil))
|
|---|
| 417 | (t (let* ((addr (- ptr $t_cons)))
|
|---|
| 418 | (if (address-forwarded-p input-dc addr log)
|
|---|
| 419 | (setf (dc-cdr output-dc cons) (read-forwarded-pointer input-dc addr log))
|
|---|
| 420 | (let ((cdr (+ (gc-copy-bytes addr 8 input-dc output-dc)
|
|---|
| 421 | $t_cons)))
|
|---|
| 422 | (setf (dc-cdr output-dc cons) cdr)
|
|---|
| 423 | (gc-write-forwarding-pointer addr cdr nil input-dc log)
|
|---|
| 424 | ; Must be a tail-call
|
|---|
| 425 | (gc-copy-cons-internal cdr input-dc output-dc log q))))))))
|
|---|
| 426 |
|
|---|
| 427 | (defun gc-copy-lfun (lfun address input-dc output-dc log q)
|
|---|
| 428 | (declare (ignore lfun))
|
|---|
| 429 | (+ (gc-copy-vector (+ address $t_vector) address input-dc output-dc log q)
|
|---|
| 430 | (- $t_lfun $t_vector)))
|
|---|
| 431 |
|
|---|
| 432 | ; Here's where most of the storage gets allocated.
|
|---|
| 433 | ; We copy the storage from input-dc to output-dc. It will be
|
|---|
| 434 | ; furthur translated as necessary by our caller(s).
|
|---|
| 435 | ; This should eventually handle consing areas.
|
|---|
| 436 | (defun gc-copy-bytes (address bytes input-dc output-dc)
|
|---|
| 437 | (let* ((res (- (%allocate-storage output-dc nil bytes) $t_cons))
|
|---|
| 438 | (string (make-string 512 :element-type 'base-character))
|
|---|
| 439 | (from address)
|
|---|
| 440 | (to res)
|
|---|
| 441 | (bytes-to-go bytes))
|
|---|
| 442 | (declare (dynamic-extent string))
|
|---|
| 443 | (loop
|
|---|
| 444 | (when (< bytes-to-go 512)
|
|---|
| 445 | (load-byte-array input-dc from bytes-to-go string 0 t)
|
|---|
| 446 | (store-byte-array string output-dc to bytes-to-go 0 t)
|
|---|
| 447 | (return))
|
|---|
| 448 | (load-byte-array input-dc from 512 string 0 t)
|
|---|
| 449 | (store-byte-array string output-dc to 512 0 t)
|
|---|
| 450 | (setq from (addr+ input-dc from 512))
|
|---|
| 451 | (setq to (addr+ output-dc to 512))
|
|---|
| 452 | (decf bytes-to-go 512))
|
|---|
| 453 | res))
|
|---|
| 454 |
|
|---|
| 455 | ;;;;;;;;;;;;;;;;;;;;;;;
|
|---|
| 456 | ;;
|
|---|
| 457 | ;; Tables
|
|---|
| 458 | ;;
|
|---|
| 459 |
|
|---|
| 460 | (defparameter *subtype-node-p*
|
|---|
| 461 | #(nil ; 0 - unused
|
|---|
| 462 | nil ; 1 - $v_bignum
|
|---|
| 463 | nil ; 2 - $v_macptr not implemented
|
|---|
| 464 | nil ; 3 - $v_badptr not implemented
|
|---|
| 465 | t ; 4 - $v_nlfunv
|
|---|
| 466 | nil ; 5 - unused
|
|---|
| 467 | nil ; 6 - unused
|
|---|
| 468 | nil ; 7 - $v_ubytev - unsigned byte vector
|
|---|
| 469 | nil ; 8 - $v_uwordv - unsigned word vector
|
|---|
| 470 | nil ; 9 - $v_floatv - float vector
|
|---|
| 471 | nil ; 10 - $v_slongv - Signed long vector
|
|---|
| 472 | nil ; 11 - $v_ulongv - Unsigned long vector
|
|---|
| 473 | nil ; 12 - $v_bitv - Bit vector
|
|---|
| 474 | nil ; 13 - $v_sbytev - Signed byte vector
|
|---|
| 475 | nil ; 14 - $v_swordv - Signed word vector
|
|---|
| 476 | nil ; 15 - $v_sstr - simple string
|
|---|
| 477 | t ; 16 - $v_genv - simple general vector
|
|---|
| 478 | t ; 17 - $v_arrayh - complex array header
|
|---|
| 479 | t ; 18 - $v_struct - structure
|
|---|
| 480 | t ; 19 - $v_mark - buffer mark unimplemented
|
|---|
| 481 | t ; 20 - $v_pkg
|
|---|
| 482 | nil ; 21 - unused
|
|---|
| 483 | t ; 22 - $v_istruct - type in first element
|
|---|
| 484 | t ; 23 - $v_ratio
|
|---|
| 485 | t ; 24 - $v_complex
|
|---|
| 486 | t ; 25 - $v_instance - clos instance
|
|---|
| 487 | nil ; 26 - unused
|
|---|
| 488 | nil ; 27 - unused
|
|---|
| 489 | nil ; 28 - unused
|
|---|
| 490 | t ; 29 - $v_weakh - weak list header
|
|---|
| 491 | t ; 30 - $v_poolfreelist - free pool header
|
|---|
| 492 | t ; 31 - $v_nhash unused
|
|---|
| 493 | t ; 32 - $v_area - area descriptor
|
|---|
| 494 | t ; 33 - $v_segment - area segment
|
|---|
| 495 | nil ; 34 - $v_random-bits - vectors of random bits, e.g. resources
|
|---|
| 496 | t ; 35 - $v_dbheader - database header
|
|---|
| 497 | nil ; 36 - $v_segment-headers - specially allocated
|
|---|
| 498 | t ; 37 - $v_btree
|
|---|
| 499 | nil ; 38 - $v_btree-node - specially allocated
|
|---|
| 500 | t ; 39 - $v_class
|
|---|
| 501 | t ; 40 - $v_load-function
|
|---|
| 502 | ))
|
|---|
| 503 |
|
|---|
| 504 | (defparameter *subtype-special-copy-function*
|
|---|
| 505 | '((#.$v_pkg . gc-copy-pkg)
|
|---|
| 506 | (#.$v_area . gc-copy-area)
|
|---|
| 507 | (#.$v_segment . gc-copy-error)
|
|---|
| 508 | (#.$v_dbheader . gc-copy-error)
|
|---|
| 509 | (#.$v_segment-headers . gc-copy-error)
|
|---|
| 510 | (#.$v_btree . gc-copy-btree)
|
|---|
| 511 | (#.$v_btree-node . gc-copy-error)
|
|---|
| 512 | (#.$v_class . gc-copy-class)))
|
|---|
| 513 | ;;; 1 3/10/94 bill 1.8d247
|
|---|
| 514 | ;;; 2 7/26/94 Derek 1.9d027
|
|---|
| 515 | ;;; 3 10/04/94 bill 1.9d071
|
|---|
| 516 | ;;; 4 11/05/94 kab 1.9d087
|
|---|
| 517 | ;;; 2 3/23/95 bill 1.11d010
|
|---|
| 518 | ;;; 3 6/02/95 bill 1.11d040
|
|---|
![(please configure the [header_logo] section in trac.ini)](/wood/chrome/site/your_project_logo.png){kind=logo}
