Skip to content
Snippets Groups Projects
Commit b1ca967e authored by wlott's avatar wlott
Browse files

Added stuff to fake scavenger hooks in the non-gengc system.

parent 1aea8bc7
No related branches found
No related tags found
No related merge requests found
......@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/scavhook.lisp,v 1.1 1991/07/30 00:40:04 wlott Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/scavhook.lisp,v 1.2 1993/05/20 13:45:06 wlott Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -21,6 +21,9 @@
(export '(scavenger-hook scavenger-hook-p make-scavenger-hook
scavenger-hook-value scavenger-hook-function))
#+gengc
(progn
(defun scavenger-hook-p (object)
"Returns T if OBJECT is a scavenger-hook, and NIL if not."
(scavenger-hook-p object))
......@@ -53,3 +56,78 @@
(type scavenger-hook scavhook))
(setf (scavenger-hook-function scavhook) function))
); #+gengc progn
#-gengc
(progn
(defstruct (scavhook
(:conc-name scavenger-hook-)
(:constructor %make-scavenger-hook (%value function last-addr))
(:print-function %print-scavenger-hook))
;;
;; The value we are monitoring.
(%value nil :type t)
;;
;; The function to invoke when the value gets scavenged (i.e. moved)
(function nil :type function)
;;
;; The address of where it was last time.
(last-addr 0 :type (unsigned-byte #.vm:word-bits)))
(defun %print-scavenger-hook (scavhook stream depth)
(declare (ignore depth))
(print-unreadable-object (scavhook stream :identity t :type t)))
(eval-when (compile eval)
(setf (info type kind 'scavenger-hook) :defined)
(setf (info type builtin 'scavenger-hook) nil))
(deftype scavenger-hook ()
'scavhook)
(defvar *scavenger-hooks* nil)
(defun make-scavenger-hook (&key value (function (required-argument)))
(without-gcing
(let ((scavhook
(%make-scavenger-hook value function
(kernel:get-lisp-obj-address value))))
(push (make-weak-pointer scavhook) *scavenger-hooks*)
scavhook)))
(declaim (inline scavenger-hook-p))
(defun scavenger-hook-p (thing)
(scavhook-p thing))
(declaim (inline scavenger-hook-value))
(defun scavenger-hook-value (scavhook)
(scavenger-hook-%value scavhook))
(defun (setf scavenger-hook-value) (value scavhook)
(without-gcing
(setf (scavenger-hook-%value scavhook) value)
(setf (scavenger-hook-last-addr scavhook)
(kernel:get-lisp-obj-address value)))
value)
(defun scavhook-after-gc-hook ()
(do ((prev nil)
(next *scavenger-hooks* (cdr next)))
((null next))
(multiple-value-bind (scavhook valid) (weak-pointer-value (car next))
(cond (valid
(let* ((value (scavenger-hook-value scavhook))
(addr (kernel:get-lisp-obj-address value)))
(unless (= addr (scavenger-hook-last-addr scavhook))
(setf (scavenger-hook-last-addr scavhook) addr)
(funcall (scavenger-hook-function scavhook))))
(setf prev next))
(prev
(setf (cdr prev) (cdr next)))
(t
(setf *scavenger-hooks* (cdr next)))))))
(pushnew 'scavhook-after-gc-hook *after-gc-hooks*)
); #-gengc progn
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment