From b1ca967ecb9a0691a05c0d236ba956b209e3cbe7 Mon Sep 17 00:00:00 2001 From: wlott <wlott> Date: Thu, 20 May 1993 13:45:06 +0000 Subject: [PATCH] Added stuff to fake scavenger hooks in the non-gengc system. --- code/scavhook.lisp | 80 +++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 79 insertions(+), 1 deletion(-) diff --git a/code/scavhook.lisp b/code/scavhook.lisp index 78851b051..2b57d1221 100644 --- a/code/scavhook.lisp +++ b/code/scavhook.lisp @@ -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 -- GitLab