source: trunk/ccl/level-1/l1-lisp-threads.lisp @ 465

Last change on this file since 465 was 465, checked in by gb, 16 years ago

Disable interrupts when accessing the termination queue; may need to
inhibit GC as well.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 43.0 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of Opensourced MCL.
5;;;
6;;;   Opensourced MCL is free software; you can redistribute it and/or
7;;;   modify it under the terms of the GNU Lesser General Public
8;;;   License as published by the Free Software Foundation; either
9;;;   version 2.1 of the License, or (at your option) any later version.
10;;;
11;;;   Opensourced MCL is distributed in the hope that it will be useful,
12;;;   but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;;   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
14;;;   Lesser General Public License for more details.
15;;;
16;;;   You should have received a copy of the GNU Lesser General Public
17;;;   License along with this library; if not, write to the Free Software
18;;;   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
19;;;
20
21;; l1-lisp-threads.lisp
22
23(cl:in-package "CCL")
24
25(defvar *bind-io-control-vars-per-process* nil
26  "If true, bind I/O control variables per process")
27
28(eval-when (:compile-toplevel :execute)
29  (macrolet ((thread-accessor (name)
30               `(defmacro ,(intern
31                            (concatenate 'string "LISP-THREAD." (string name)))
32                 (thread)
33                 `(%svref ,thread ,,(intern
34                                     (concatenate
35                                      'string
36                                      "LISP-THREAD."
37                                      (string name)
38                                      "-CELL")
39                                     "TARGET")))))
40    (progn
41      (thread-accessor tcr)
42      (thread-accessor name)
43      (thread-accessor cs-size)
44      (thread-accessor vs-size)
45      (thread-accessor ts-size)
46      (thread-accessor initial-function.args)
47      (thread-accessor interrupt-functions)
48      (thread-accessor interrupt-lock)
49      (thread-accessor startup-function)
50      (thread-accessor state)
51      (thread-accessor state-change-lock))))
52             
53(defun lisp-thread-p (thing)
54  (eq (typecode thing) ppc32::subtag-lisp-thread))
55
56(setf (type-predicate 'lisp-thread) 'lisp-thread-p)
57
58(defloadvar *ticks-per-second*
59    (#_sysconf #$_SC_CLK_TCK))
60
61(defloadvar *ns-per-tick*
62    (floor 1000000000 *ticks-per-second*))
63
64(defun %nanosleep (seconds nanoseconds)
65  (rlet ((a :timespec)
66         (b :timespec))
67    (setf (pref a :timespec.tv_sec) seconds
68          (pref a :timespec.tv_nsec) nanoseconds)
69    (let* ((aptr a)
70           (bptr b))
71      (loop
72        (let* ((result 
73                (external-call #+darwinppc-target "_nanosleep"
74                               #-darwinppc-target "nanosleep"
75                               :address aptr
76                               :address bptr
77                               :signed-fullword)))
78          (if (and (< result 0)
79                   (eql (%get-errno) (- #$EINTR))
80                   (not (or (eql (pref bptr :timespec.tv_sec) 0)
81                            (eql (pref bptr :timespec.tv_nsec) 0))))
82                (psetq aptr bptr bptr aptr)
83                (return)))))))
84
85
86(defun timeval->ticks (tv)
87  (+ (* *ticks-per-second* (pref tv :timeval.tv_sec))
88     (round (pref tv :timeval.tv_usec) (floor 1000000 *ticks-per-second*))))
89
90(defloadvar *lisp-start-timeval*
91    (progn
92      (let* ((r (make-record :timeval)))
93        (#_gettimeofday r (%null-ptr))
94        r)))
95
96(defun get-tick-count ()
97  (rlet ((now :timeval)
98         (since :timeval))
99    (#_gettimeofday now (%null-ptr))
100    (%sub-timevals since now *lisp-start-timeval*)
101    (timeval->ticks since)))
102 
103
104; Allocate a tstack area with at least useable-bytes
105; Returns a fixnum encoding the address of an area structure.
106(defun allocate-tstack (useable-bytes)
107  (with-macptrs ((tstack (ff-call (%kernel-import ppc32::kernel-import-allocate_tstack)
108                                      :unsigned-fullword (logand (+ useable-bytes 4095) -4096)
109                                      :address)))
110    (when (%null-ptr-p tstack)
111      (error "Can't allocate tstack"))
112    (%fixnum-from-macptr tstack)))
113
114
115
116; Allocate a vstack area with at least useable-bytes
117; Returns a fixnum encoding the address of an area structure.
118(defun allocate-vstack (useable-bytes)
119  (with-macptrs ((vstack (ff-call (%kernel-import ppc32::kernel-import-allocate_vstack)
120                                      :unsigned-fullword (logand (+ useable-bytes 4095) -4096)
121                                      :address)))
122    (when (%null-ptr-p vstack)
123      (error "Can't allocate vstack"))
124    (%fixnum-from-macptr vstack)))
125
126
127
128; Create a new, empty control stack area
129; Returns a fixnum encoding the address of an area structure.
130(defun new-cstack-area ()
131  (with-macptrs ((cstack (ff-call (%kernel-import ppc32::kernel-import-register_cstack)
132                                      :unsigned-fullword 0   ; address
133                                      :unsigned-fullword 0   ; size
134                                      :address)))
135    (when (%null-ptr-p cstack)
136      (error "Can't allocate cstack"))
137    ; Prevent stack overflow of infant stack group
138    ; (Actually, I don't think this is necessary)
139    (setf (pref cstack :gc-area.softlimit) (%null-ptr)
140          (pref cstack :gc-area.hardlimit) (%null-ptr))
141    (%fixnum-from-macptr cstack)))
142
143
144; Free the result of allocate-tstack, allocate-vstack, or register-cstack
145(defun free-stack-area (stack-area)
146  (with-macptrs ((area-ptr (%null-ptr)))
147    (%setf-macptr-to-object area-ptr stack-area)
148    (ff-call (%kernel-import ppc32::kernel-import-condemn-area)
149                 :address area-ptr
150                 :void))
151  nil)
152
153
154
155(defun %kernel-global-offset (name-or-offset)
156  (if (fixnump name-or-offset)
157    name-or-offset
158    (ppc32::%kernel-global name-or-offset)))
159
160(defun %kernel-global-offset-form (name-or-offset-form)
161  (cond ((and (listp name-or-offset-form)
162              (eq 'quote (car name-or-offset-form))
163              (listp (cdr name-or-offset-form))
164              (symbolp (cadr name-or-offset-form))
165              (null (cddr name-or-offset-form)))
166         (ppc32::%kernel-global (cadr name-or-offset-form)))
167        ((fixnump name-or-offset-form)
168         name-or-offset-form)
169        (t `(%kernel-global-offset ,name-or-offset-form))))
170
171; This behaves like a function, but looks up the kernel global
172; at compile time if possible. Probably should be done as a function
173; and a compiler macro, but we can't define compiler macros yet,
174; and I don't want to add it to "ccl:compiler;optimizers.lisp"
175(defmacro %get-kernel-global (name-or-offset)
176  `(%fixnum-ref 0 (+ ppc32::nil-value  ,(%kernel-global-offset-form name-or-offset))))
177
178(defmacro %get-kernel-global-ptr (name-or-offset dest)
179  `(%setf-macptr ,dest
180    (%fixnum-ref-u32 0 (+ ppc32::nil-value  ,(%kernel-global-offset-form name-or-offset)))))
181
182(defmacro %set-kernel-global (name-or-offset new-value)
183  `(%set-kernel-global-from-offset
184    ,(%kernel-global-offset-form name-or-offset)
185    ,new-value))
186
187
188
189; The number of bytes in a consing (or stack) area
190(defun %area-size (area)
191  (ash (- (%fixnum-ref area ppc32::area.high)
192          (%fixnum-ref area ppc32::area.low))
193       2))
194
195(defun %stack-area-usable-size (area)
196  (ash (- (%fixnum-ref area ppc32::area.high)
197          (%fixnum-ref area ppc32::area.softlimit))
198       2))
199
200(defun %cons-lisp-thread (name &optional tcr)
201  (%gvector ppc32::subtag-lisp-thread
202            tcr
203            name
204            0
205            0
206            0
207            nil
208            nil
209            (make-lock)
210            nil
211            :reset
212            (make-lock)
213            nil))
214
215(defvar *current-lisp-thread*
216  (%cons-lisp-thread "Initial" (%current-tcr)))
217
218(defvar *initial-lisp-thread* *current-lisp-thread*)
219
220(defun thread-change-state (thread oldstate newstate)
221  (with-lock-grabbed ((lisp-thread.state-change-lock thread))
222    (when (eq (lisp-thread.state thread) oldstate)
223      (setf (lisp-thread.state thread) newstate))))
224
225(thread-change-state *initial-lisp-thread* :reset :run)
226
227(defun thread-state (thread)
228  (with-lock-grabbed ((lisp-thread.state-change-lock thread))
229    (lisp-thread.state thread)))
230 
231(defun thread-make-startup-function (thread tcr)
232  #'(lambda ()
233      (thread-change-state thread :reset :run)
234      (let* ((*current-lisp-thread* thread)
235             (initial-function (lisp-thread.initial-function.args thread)))
236        (tcr-clear-preset-state tcr)
237        (%set-tcr-toplevel-function tcr nil)
238        (setf (interrupt-level) 0)
239        (apply (car initial-function) (cdr initial-function))
240        (cleanup-thread-tcr thread tcr))))
241
242(defun init-thread-from-tcr (tcr thread)
243  (setf (lisp-thread.tcr thread) tcr
244        (lisp-thread.cs-size thread)
245        (%stack-area-usable-size (%fixnum-ref tcr ppc32::tcr.cs-area))
246        (lisp-thread.vs-size thread)
247        (%stack-area-usable-size (%fixnum-ref tcr ppc32::tcr.vs-area))
248        (lisp-thread.ts-size thread)
249        (%stack-area-usable-size (%fixnum-ref tcr ppc32::tcr.ts-area))
250        (lisp-thread.startup-function thread)
251        (thread-make-startup-function thread tcr))
252  thread)
253
254(defun new-lisp-thread-from-tcr (tcr name)
255  (let* ((thread (%cons-lisp-thread name tcr)))   
256    (init-thread-from-tcr tcr thread)
257    (push thread (population-data *lisp-thread-population*))
258    thread))
259
260(def-ccl-pointers initial-thread ()
261  (init-thread-from-tcr (%current-tcr) *initial-lisp-thread*))
262
263(defmethod print-object ((thread lisp-thread) stream)
264  (print-unreadable-object (thread stream :type t :identity t)
265    (format stream "~a" (lisp-thread.name thread))
266    (let* ((tcr (lisp-thread.tcr thread)))
267      (if (and tcr (not (eql 0 tcr)))
268        (format stream " [tcr @ #x~x]" (ash tcr ppc32::fixnumshift))))))
269
270
271(defvar *lisp-thread-population*
272  (%cons-population (list *initial-lisp-thread*) $population_weak-list t))
273
274
275
276; Don't free stack oreas that contain part of the db_link chain.
277(defun delete-unused-stack-areas ()
278  #+later
279  (without-interrupts
280   (do-unexhausted-stack-groups (sg)
281     (macrolet ((do-area (sg.area &optional check-db-link)
282                  `(let* ((current-p (eq sg *current-stack-group*))
283                          area younger ,@(and check-db-link '(a)))
284                     ; It's important that if sg is the current stack group,
285                     ; then this code does no vsp or tsp pushes until the free-stack-area call.
286                     (when current-p
287                       (%normalize-areas))
288                     (setq area (,sg.area sg)
289                           younger (%fixnum-ref area ppc32::area.younger))
290                     (unless (eql younger 0)
291                       (unless ,(when check-db-link
292                                  `(progn
293                                     (setq a younger)
294                                     (loop
295                                       (when (if current-p
296                                               (%db-link-chain-in-current-sg-area a)
297                                               (%db-link-chain-in-area-p a sg))
298                                         (return t))
299                                       (setq a (%fixnum-ref a ppc32::area.younger))
300                                       (when (eql a 0)
301                                         (return nil)))))
302                         (%fixnum-set area ppc32::area.younger 0)
303                         (%fixnum-set younger ppc32::area.older 0)
304                         (free-stack-area younger))))))
305       (do-area sg.ts-area)
306       (do-area sg.vs-area t)
307       (%free-younger-cs-areas (sg.cs-area sg))
308       ))))
309
310(defparameter *default-control-stack-size* (ash 1 20))
311(defparameter *default-value-stack-size* (ash 1 20))
312(defparameter *default-temp-stack-size* (ash 1 19))
313
314
315(defmacro with-area-macptr ((var area) &body body)
316  `(with-macptrs (,var)
317     (%setf-macptr-to-object ,var ,area)
318     ,@body))
319
320
321(defun gc-area.return-sp (area)
322  (%fixnum-ref area ppc32::area.gc-count))
323
324
325(defun (setf gc-area.return-sp) (return-sp area)
326  (setf (%fixnum-ref area ppc32::area.gc-count) return-sp))
327
328#+later
329(defun %free-younger-cs-areas (cs-area &optional (free-cs-area-too nil))
330  (let (younger-cs-area)
331    (loop
332      (setf younger-cs-area (%fixnum-ref cs-area ppc32::area.younger)
333            (%fixnum-ref cs-area ppc32::area.younger) 0)
334      (when free-cs-area-too
335        (progn (ff-call
336                 (%kernel-import ppc32::kernel-import-disposethread)
337                 :unsigned-fullword (gc-area.threadID cs-area)
338                 :address (%null-ptr)
339                 :unsigned-fullword 0
340                 :signed-halfword))
341        (setf (%fixnum-ref cs-area ppc32::area.older) 0)          ; free-stack-area frees the whole younger/older chain
342        (free-stack-area cs-area))
343      (when (eql 0 younger-cs-area) (return))
344      (setq cs-area younger-cs-area)
345      (setq free-cs-area-too t))))
346
347(defun shutdown-lisp-threads ()
348  )
349
350(defun %current-xp ()
351  (let ((xframe (%fixnum-ref (%current-tcr) ppc32::tcr.xframe)))
352    (when (eql xframe 0)
353      (error "No current exception frame"))
354    (%fixnum-ref xframe
355                 (get-field-offset :xframe-list.this))))
356
357(defun new-tcr (cs-size vs-size ts-size)
358  (ash
359   (%ptr-to-int
360    (ff-call
361     (%kernel-import ppc32::kernel-import-newthread)
362     :unsigned-fullword cs-size
363     :unsigned-fullword vs-size
364     :unsigned-fullword ts-size
365     :address))
366   -2))
367
368(defun new-thread (name cstack-size vstack-size tstack-size)
369  (new-lisp-thread-from-tcr (new-tcr cstack-size vstack-size tstack-size) name))
370
371(defun new-tcr-for-thread (thread)
372  (let* ((tcr (new-tcr
373               (lisp-thread.cs-size thread)
374               (lisp-thread.vs-size thread)
375               (lisp-thread.ts-size thread))))
376    (setf (lisp-thread.tcr thread) tcr
377          (lisp-thread.startup-function thread)
378          (thread-make-startup-function thread tcr))
379    tcr))
380 
381         
382(defmacro with-self-bound-io-control-vars (&body body)
383  `(let (; from CLtL2, table 22-7:
384         (*package* *package*)
385         (*print-array* *print-array*)
386         (*print-base* *print-base*)
387         (*print-case* *print-case*)
388         (*print-circle* *print-circle*)
389         (*print-escape* *print-escape*)
390         (*print-gensym* *print-gensym*)
391         (*print-length* *print-length*)
392         (*print-level* *print-level*)
393         (*print-lines* *print-lines*)
394         (*print-miser-width* *print-miser-width*)
395         (*print-pprint-dispatch* *print-pprint-dispatch*)
396         (*print-pretty* *print-pretty*)
397         (*print-radix* *print-radix*)
398         (*print-readably* *print-readably*)
399         (*print-right-margin* *print-right-margin*)
400         (*read-base* *read-base*)
401         (*read-default-float-format* *read-default-float-format*)
402         (*read-eval* *read-eval*)
403         (*read-suppress* *read-suppress*)
404         (*readtable* *readtable*))
405     ,@body))
406
407
408(defconstant cstack-hardprot (ash 100 10))
409(defconstant cstack-softprot (ash 100 10))
410
411
412
413(defun tcr-flags (tcr)
414  (%fixnum-ref tcr ppc32::tcr.flags))
415
416(defun tcr-exhausted-p (tcr)
417  (or (null tcr)
418      (eql tcr 0)
419      (unless (logbitp arch::tcr-flag-bit-awaiting-preset
420                       (the fixnum (tcr-flags tcr)))
421        (let* ((vs-area (%fixnum-ref tcr ppc32::tcr.vs-area)))
422          (declare (fixnum vs-area))
423          (or (zerop vs-area)
424              (eq (%fixnum-ref vs-area ppc32::area.high)
425                  (%fixnum-ref tcr ppc32::tcr.save-vsp)))))))
426
427(defun thread-exhausted-p (thread)
428  (or (null thread)
429      (tcr-exhausted-p (lisp-thread.tcr thread))))
430
431(defun thread-total-run-time (thread)
432  (unless (thread-exhausted-p thread)
433    nil))
434
435
436(defun thread-interrupt (thread process function &rest args)
437  (with-lock-grabbed ((lisp-thread.state-change-lock thread))
438    (case (lisp-thread.state thread)
439      (:run 
440       (with-lock-grabbed ((lisp-thread.interrupt-lock thread))
441         (let* ((pthread (lisp-thread-os-thread thread)))
442           (when pthread
443             (push (cons function args)
444                   (lisp-thread.interrupt-functions thread))
445             (#_pthread_kill pthread (%get-kernel-global 'ppc32::interrupt-signal))))))
446      (:reset
447       ;; Preset the thread with a function that'll return to the :reset
448       ;; state
449       (let* ((pif (process-initial-form process))
450              (pif-f (car pif))
451              (pif-args (cdr pif)))
452         (process-preset process #'(lambda ()
453                                     (%rplaca pif pif-f)
454                                     (%rplacd pif pif-args)
455                                     (apply function args)
456                                     ;; If function returns normally,
457                                     ;; return to the reset state
458                                     (%process-reset nil)))
459         (thread-enable thread 0)))))
460  nil)
461
462(defun thread-handle-interrupts ()
463  (let* ((thread *current-lisp-thread*))
464    (loop
465      (let* ((f (with-lock-grabbed ((lisp-thread.interrupt-lock thread))
466                  (pop (lisp-thread.interrupt-functions thread)))))
467        (if f
468          (apply (car f) (cdr f))
469          (return))))))
470
471
472       
473(defun thread-preset (thread function &rest args)
474  (setf (lisp-thread.initial-function.args thread)
475        (cons function args)))
476
477(defun thread-enable (thread &optional (timeout most-positive-fixnum))
478  (let* ((tcr (or (lisp-thread.tcr thread) (new-tcr-for-thread thread))))
479    (multiple-value-bind (seconds nanos) (nanoseconds timeout)
480      (with-macptrs (s)
481        (%setf-macptr-to-object s (%fixnum-ref tcr ppc32::tcr.reset-completion))
482        (when (%wait-on-semaphore-ptr s seconds nanos)
483          (%set-tcr-toplevel-function
484           tcr
485           (lisp-thread.startup-function thread))
486          (%activate-tcr tcr)
487          thread)))))
488                             
489
490(defun cleanup-thread-tcr (thread tcr)
491  (let* ((flags (%fixnum-ref tcr ppc32::tcr.flags)))
492    (declare (fixnum flags))
493    (if (logbitp arch::tcr-flag-bit-awaiting-preset flags)
494      (thread-change-state thread :run :reset)
495      (progn
496        (thread-change-state thread :run :exit)
497        (setf (lisp-thread.tcr thread) nil)))))
498
499(defun kill-lisp-thread (thread)
500  (let* ((pthread (lisp-thread-os-thread thread)))
501    (when pthread
502      (setf (lisp-thread.tcr thread) nil
503            (lisp-thread.state thread) :exit)
504      (#_pthread_cancel pthread))))
505
506;;; This returns the underlying pthread, whatever that is.
507(defun lisp-thread-os-thread (thread)
508  (with-macptrs (tcrp)
509    (%setf-macptr-to-object tcrp (lisp-thread.tcr thread))
510    (unless (%null-ptr-p tcrp)
511      (#+linuxppc-target %get-unsigned-long #-linuxppc-target %get-ptr
512                         tcrp ppc32::tcr.osid))))
513                         
514;;; This returns something lower-level than the pthread, if that
515;;; concept makes sense.  On current versions of Linux, it returns
516;;; the pid of the clone()d process; on Darwin, it returns a Mach
517;;; thread.  On some (near)future version of Linux, the concept
518;;; may not apply.
519
520(defun lisp-thread-native-thread (thread)
521  (with-macptrs (tcrp)
522    (%setf-macptr-to-object tcrp (lisp-thread.tcr thread))
523    (unless (%null-ptr-p tcrp)
524      (%get-unsigned-long tcrp ppc32::tcr.native-thread-id))))
525
526(defun lisp-thread-suspend-count (thread)
527  (with-macptrs (tcrp)
528    (%setf-macptr-to-object tcrp (lisp-thread.tcr thread))
529    (unless (%null-ptr-p tcrp)
530      (%get-unsigned-long tcrp ppc32::tcr.suspend-count))))
531
532(defun tcr-clear-preset-state (tcr)
533  (let* ((flags (%fixnum-ref tcr ppc32::tcr.flags)))
534    (declare (fixnum flags))
535    (setf (%fixnum-ref tcr ppc32::tcr.flags)
536          (bitclr arch::tcr-flag-bit-awaiting-preset flags))))
537
538(defun tcr-set-preset-state (tcr)
539  (let* ((flags (%fixnum-ref tcr ppc32::tcr.flags)))
540    (declare (fixnum flags))
541    (setf (%fixnum-ref tcr ppc32::tcr.flags)
542          (bitset arch::tcr-flag-bit-awaiting-preset flags)))) 
543
544(defun %activate-tcr (tcr)
545  (if (and tcr (not (eql 0 tcr)))
546    (with-macptrs (s)
547      (%setf-macptr-to-object s (%fixnum-ref tcr ppc32::tcr.activate))
548      (unless (%null-ptr-p s)
549        (%signal-semaphore-ptr s)
550        t))))
551                         
552(defvar *canonical-error-value*
553  '(*canonical-error-value*))
554
555
556(defun symbol-value-in-tcr (sym tcr)
557  (let ((loc (%symbol-value-locative-in-tcr sym tcr)))
558    (if (null loc)
559      (symbol-value sym)
560      (let ((val (%fixnum-ref loc)))
561        (when (eq val (%unbound-marker-8))
562          (error "~s is unbound in context ~s" sym tcr))
563        val))))
564
565(defun (setf symbol-value-in-tcr) (value sym tcr)
566  (let ((loc (%symbol-value-locative-in-tcr sym tcr)))
567    (if (null loc)
568      (setf (symbol-value sym) value)
569      (setf (%fixnum-ref loc) value))))
570
571(defun %symbol-value-locative-in-tcr (sym tcr)
572  (if (eq tcr (%current-tcr))
573    nil
574    (or (%last-symbol-value-locative-in-db-chain
575         sym (db-link tcr))
576        (%last-symbol-value-locative-in-db-chain
577         sym (db-link tcr)))))
578
579(defun %last-symbol-value-locative-in-db-chain (sym db)
580  (let ((last-found nil))
581    (loop
582      (when (eql 0 db) (return))
583      (when (eq sym (%fixnum-ref db 4))
584        (setq last-found db))
585      (setq db (%fixnum-ref db 0)))
586    (and last-found (%i+ last-found 2))))
587
588
589
590;;; Backtrace support
591;;;
592
593; Linked list of fake stack frames.
594; %frame-backlink looks here
595(defvar *fake-stack-frames* nil)
596
597(def-accessors (fake-stack-frame) %svref
598  nil                           ; 'fake-stack-frame
599  %fake-stack-frame.sp          ; fixnum. The stack pointer where this frame "should" be
600  %fake-stack-frame.next-sp     ; Either sp or another fake-stack-frame
601  %fake-stack-frame.fn          ; The current function
602  %fake-stack-frame.lr          ; fixnum offset from fn (nil if fn is not functionp)
603  %fake-stack-frame.vsp         ; The value stack pointer
604  %fake-stack-frame.link        ; next in *fake-stack-frames* list
605  )
606 
607(defmacro %cons-fake-stack-frame (&optional sp next-sp fn lr vsp link)
608  `(%istruct 'fake-stack-frame ,sp ,next-sp ,fn ,lr ,vsp ,link))
609
610
611
612(defun fake-stack-frame-p (x)
613  (istruct-typep x 'fake-stack-frame))
614
615
616(defmacro do-db-links ((db-link &optional var value) &body body)
617  (let ((thunk (gensym))
618        (var-var (or var (gensym)))
619        (value-var (or value (gensym))))
620    `(block nil
621       (let ((,thunk #'(lambda (,db-link ,var-var ,value-var)
622                         (declare (ignorable ,db-link))
623                         ,@(unless var (list `(declare (ignore ,var-var))))
624                         ,@(unless value (list `(declare (ignore ,value-var))))
625                         ,@body)))
626         (declare (dynamic-extent ,thunk))
627         (map-db-links ,thunk)))))
628
629
630
631
632(defun map-db-links (f)
633  (without-interrupts
634   (let ((db-link (%fixnum-ref (%current-db-link))))         ; skip the without-interrupts binding
635     (loop
636       (when (eql 0 db-link) (return))
637       (funcall f db-link (%fixnum-ref db-link 4) (%fixnum-ref db-link 8))
638       (setq db-link (%fixnum-ref db-link))))))
639
640(defun %get-frame-ptr (&optional (tcr (%current-tcr)))
641  (if (eq tcr (%current-tcr))
642    (%current-frame-ptr)
643    (%fixnum-ref (%fixnum-ref tcr ppc32::tcr.cs-area) ppc32::area.active)))
644
645
646(defun %stack< (index1 index2 &optional (tcr (%current-tcr)))
647  (cond ((fake-stack-frame-p index1)
648         (let ((sp1 (%fake-stack-frame.sp index1)))
649           (declare (fixnum sp1))
650           (if (fake-stack-frame-p index2)
651             (or (%stack< sp1 (%fake-stack-frame.sp index2) tcr)
652                 (eq index2 (%fake-stack-frame.next-sp index1)))
653             (%stack< sp1 (%i+ index2 1) tcr))))
654        ((fake-stack-frame-p index2)
655         (%stack< index1 (%fake-stack-frame.sp index2)))
656        (t (let* ((cs-area (%fixnum-ref tcr ppc32::tcr.cs-area)))
657             (loop
658               (when (%ptr-in-area-p index1 cs-area)
659                 (return))
660               (setq cs-area (%fixnum-ref cs-area ppc32::area.older))
661               (when (eql 0 cs-area)
662                 ; Should we signal an error here?
663                 (return-from %stack< nil)))
664             (if (%ptr-in-area-p index2 cs-area)
665               (%i< index1 index2)
666               (loop
667                 (setq cs-area (%fixnum-ref cs-area ppc32::area.older))
668                 (when (eql 0 cs-area)
669                   (return nil))
670                 (when (%ptr-in-area-p index2 cs-area)
671                   (return t))))))))
672
673(defun %frame-savefn (p)
674  (if (fake-stack-frame-p p)
675    (%fake-stack-frame.fn p)
676    (%%frame-savefn p)))
677
678(defun %frame-savevsp (p)
679  (if (fake-stack-frame-p p)
680    (%fake-stack-frame.vsp p)
681    (%%frame-savevsp p)))
682
683(defun frame-vsp (frame)
684  (%frame-savevsp frame))
685
686(defun bottom-of-stack-p (p tcr)
687  (and (fixnump p)
688       (locally (declare (fixnum p))
689         (let* ((cs-area (%fixnum-ref tcr ppc32::tcr.cs-area)))
690           (loop
691               (when (%ptr-in-area-p p cs-area)
692                 (return nil))
693               (setq cs-area (%fixnum-ref cs-area ppc32::area.older))
694             (when (eql 0 cs-area)
695               (return t)))))))
696
697(defun next-catch (catch)
698  (let ((next-catch (uvref catch ppc32::catch-frame.link-cell)))
699    (unless (eql next-catch 0) next-catch)))
700
701(defun catch-frame-sp (catch)
702  (uvref catch ppc32::catch-frame.csp-cell))
703
704(defun catch-csp-p (p tcr)
705  (let ((catch (%catch-top tcr)))
706    (loop
707      (when (null catch) (return nil))
708      (let ((sp (catch-frame-sp catch)))
709        (when (eql sp p)
710          (return t)))
711      (setq catch (next-catch catch)))))
712
713; @@@ this needs to load early so errors can work
714(defun next-lisp-frame (p tcr)
715  (let ((frame p))
716    (loop
717      (let ((parent (%frame-backlink frame tcr)))
718        (multiple-value-bind (lisp-frame-p bos-p) (lisp-frame-p parent tcr)
719          (if lisp-frame-p
720            (return parent)
721            (if bos-p
722              (return nil))))
723        (setq frame parent)))))
724
725(defun parent-frame (p tcr)
726  (loop
727    (let ((parent (next-lisp-frame p tcr)))
728      (when (or (null parent)
729                (not (catch-csp-p parent tcr)))
730        (return parent))
731      (setq p parent))))
732
733
734; @@@ this needs to load early so errors can work
735(defun cfp-lfun (p)
736  (if (fake-stack-frame-p p)
737    (let ((fn (%fake-stack-frame.fn p))
738          (lr (%fake-stack-frame.lr p)))
739      (when (and (functionp fn) (fixnump lr))
740        (values fn (%fake-stack-frame.lr p))))
741    (%cfp-lfun p)))
742
743(defun last-frame-ptr (&optional (tcr (%current-tcr)))
744  (let* ((current (%get-frame-ptr tcr))
745         (last current))
746    (loop
747      (setq current (parent-frame current tcr))
748      (if current
749        (setq last current)
750        (return last)))))
751
752
753
754(defun child-frame (p tcr)
755  (let* ((current (%get-frame-ptr tcr))
756         (last nil))
757    (loop
758      (when (null current)
759        (return nil))
760      (when (eq current p) (return last))
761      (setq last current
762            current (parent-frame current tcr)))))
763
764
765
766; Used for printing only.
767(defun index->address (p)
768  (when (fake-stack-frame-p p)
769    (setq p (%fake-stack-frame.sp p)))
770  (ldb (byte 32 0)  (ash p ppc32::fixnumshift)))
771
772; This returns the current head of the db-link chain.
773(defun db-link (&optional (tcr (%current-tcr)))
774  (%fixnum-ref tcr ppc32::tcr.db-link))
775
776(defun previous-db-link (db-link start &optional (tcr (%current-tcr)))
777  (declare (fixnum db-link start))
778  (if (eq tcr (%current-tcr))
779    (let ((prev nil))
780      (loop
781        (when (or (eql db-link start) (eql 0 start))
782          (return prev))
783        (setq prev start
784              start (%fixnum-ref start 0))))
785    (let ((prev (%fixnum-ref db-link)))
786      (unless (eql prev 0) prev))))
787
788(defun count-db-links-in-frame (vsp parent-vsp &optional (tcr (%current-tcr)))
789  (declare (fixnum vsp parent-vsp))
790  (let ((db (db-link tcr))
791        (count 0)
792        (first nil)
793        (last nil)
794        (current? (eq tcr (%current-tcr))))
795    (declare (fixnum db count))
796    (loop
797      (cond ((eql db 0)
798             (unless current?
799               (rotatef first last))
800             (return (values count (or first 0) (or last 0))))
801            ((and (>= db vsp) (< db parent-vsp))
802             (unless first (setq first db))
803             (setq last db)
804             (incf count)))
805      (setq db (%fixnum-ref db)))))
806
807;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
808;;;
809;;; bogus-thing-p support
810;;;
811
812(defun %ptr-in-area-p (ptr area)
813  (declare (fixnum ptr area))
814  (and (<= (the fixnum (%fixnum-ref area ppc32::area.low)) ptr)
815       (>= (the fixnum (%fixnum-ref area ppc32::area.high)) ptr)))
816
817(defun %active-area (area active)
818  (or (do ((a area (%fixnum-ref a ppc32::area.older)))
819          ((eql a 0))
820        (when (%ptr-in-area-p active a)
821          (return a)))
822      (do ((a (%fixnum-ref area ppc32::area.younger) (%fixnum-ref a ppc32::area.younger)))
823          ((eql a 0))
824        (when (%ptr-in-area-p active a)
825          (return a)))))
826
827(defun %ptr-to-vstack-p (tcr idx)
828  (declare (fixnum idx))
829  (let* ((vs-area (%active-area (%fixnum-ref tcr ppc32::tcr.vs-area) idx)))
830    (when vs-area
831      (let ((active (if (and (eq tcr (%current-tcr))
832                             (%ptr-in-area-p (%current-vsp) vs-area))
833                      (%current-vsp)
834                      (%fixnum-ref vs-area ppc32::area.active)))
835            (high (%fixnum-ref vs-area ppc32::area.high)))
836        (declare (fixnum active high))
837        (and (< active idx)
838             (< idx high))))))
839
840(defun %on-tsp-stack (tcr object)
841  (declare (fixnum object))             ; lie
842  (let* ((ts-area (%active-area (%fixnum-ref tcr ppc32::tcr.ts-area) object)))
843    (when ts-area
844      (let ((active (if (and (eq tcr (%current-tcr))
845                             (%ptr-in-area-p (%current-tsp) ts-area))
846                      (%current-tsp)
847                      (%fixnum-ref ts-area ppc32::area.active)))
848            (high (%fixnum-ref ts-area ppc32::area.high)))
849        (declare (fixnum active high))
850        (and (< active object)
851             (< object high))))))
852
853(defun on-any-tsp-stack (object)
854  (or (%on-tsp-stack (%current-tcr) object)))
855
856(defun on-any-vstack (idx)
857  (or (%ptr-to-vstack-p (%current-tcr) idx)))
858
859; This MUST return either T or NIL.
860(defun temporary-cons-p (x)
861  (and (consp x)
862       (not (null (or (on-any-vstack x)
863                      (on-any-tsp-stack x))))))
864
865(defmacro do-gc-areas ((area) &body body)
866  (let ((initial-area (gensym)))
867    `(let* ((,initial-area (%get-kernel-global 'all-areas))
868            (,area ,initial-area))
869       (declare (fixnum ,initial-area ,area))
870       (loop
871         (setq ,area (%fixnum-ref ,area ppc32::area.succ))
872         (when (eql ,area ,initial-area)
873           (return))
874         ,@body))))
875
876(defmacro do-consing-areas ((area) &body body)
877  (let ((code (gensym)))
878  `(do-gc-areas (,area)
879     (let ((,code (%fixnum-ref ,area ppc32::area.code)))
880       (when (or (eql ,code ppc32::area-readonly)
881                 (eql ,code ppc32::area-staticlib)
882                 (eql ,code ppc32::area-static)
883                 (eql ,code ppc32::area-dynamic))
884         ,@body)))))
885
886
887
888(defun %value-cell-header-at-p (cur-vsp)
889  (eql ppc32::value-cell-header (%fixnum-address-of (%fixnum-ref cur-vsp))))
890
891(defun count-stack-consed-value-cells-in-frame (vsp parent-vsp)
892  (let ((cur-vsp vsp)
893        (count 0))
894    (declare (fixnum cur-vsp count))
895    (loop
896      (when (>= cur-vsp parent-vsp) (return))
897      (when (and (evenp cur-vsp) (%value-cell-header-at-p cur-vsp))
898        (incf count)
899        (incf cur-vsp))                 ; don't need to check value after header
900      (incf cur-vsp))
901    count))
902
903; stack consed value cells are one of two forms:
904;
905; nil             ; n-4
906; header          ; n = even address (multiple of 8)
907; value           ; n+4
908;
909; header          ; n = even address (multiple of 8)
910; value           ; n+4
911; nil             ; n+8
912
913(defun in-stack-consed-value-cell-p (arg-vsp vsp parent-vsp)
914  (declare (fixnum arg-vsp vsp parent-vsp))
915  (if (evenp arg-vsp)
916    (%value-cell-header-at-p arg-vsp)
917    (or (and (> arg-vsp vsp)
918             (%value-cell-header-at-p (the fixnum (1- arg-vsp))))
919        (let ((next-vsp (1+ arg-vsp)))
920          (declare (fixnum next-vsp))
921          (and (< next-vsp parent-vsp)
922               (%value-cell-header-at-p next-vsp))))))
923
924; Return two values: the vsp of p and the vsp of p's "parent" frame.
925; The "parent" frame vsp might actually be the end of p's segment,
926; if the real "parent" frame vsp is in another segment.
927(defun vsp-limits (p tcr)
928  (let* ((vsp (%frame-savevsp p))
929         parent)
930    (when (eql vsp 0)
931      ; This frame is where the code continues after an unwind-protect cleanup form
932      (setq vsp (%frame-savevsp (child-frame p tcr))))
933    (flet ((grand-parent (frame)
934             (let ((parent (parent-frame frame tcr)))
935               (when (and parent (eq parent (%frame-backlink frame)))
936                 (let ((grand-parent (parent-frame parent tcr)))
937                   (when (and grand-parent (eq grand-parent (%frame-backlink parent)))
938                     grand-parent))))))
939      (declare (dynamic-extent #'grand-parent))
940      (let* ((frame p)
941             grand-parent)
942        (loop
943          (setq grand-parent (grand-parent frame))
944          (when (or (null grand-parent) (not (eql 0 (%frame-savevsp grand-parent))))
945            (return))
946          (setq frame grand-parent))
947        (setq parent (parent-frame frame tcr)))
948      (let ((parent-vsp (if parent (%frame-savevsp parent) vsp))
949            (vsp-area (%active-area (%fixnum-ref tcr ppc32::tcr.vs-area) vsp)))
950        (if (eql 0 parent-vsp)
951          (values vsp vsp)              ; p is the kernel frame pushed by an unwind-protect cleanup form
952          (progn
953            (unless vsp-area
954              (error "~s is not a stack frame pointer for context ~s" p tcr))
955            (unless (%ptr-in-area-p parent-vsp vsp-area)
956              (setq parent-vsp (%fixnum-ref vsp-area ppc32::area.high)))
957            (values vsp parent-vsp)))))))
958
959(defun count-values-in-frame (p tcr &optional child)
960  (declare (ignore child))
961  (multiple-value-bind (vsp parent-vsp) (vsp-limits p tcr)
962    (values
963     (- parent-vsp 
964        vsp
965        (* 2 (count-db-links-in-frame vsp parent-vsp tcr))
966        (* 3 (count-stack-consed-value-cells-in-frame vsp parent-vsp))))))
967
968(defun nth-value-in-frame-loc (sp n tcr lfun pc child-frame vsp parent-vsp)
969  (declare (ignore child-frame))        ; no ppc function info yet
970  (declare (fixnum sp))
971  (setq n (require-type n 'fixnum))
972  (unless (or (null vsp) (fixnump vsp))
973    (setq vsp (require-type vsp '(or null fixnum))))
974  (unless (or (null parent-vsp) (fixnump parent-vsp))
975    (setq parent-vsp (require-type parent-vsp '(or null fixnum))))
976  (unless (and vsp parent-vsp)
977    (multiple-value-setq (vsp parent-vsp) (vsp-limits sp tcr)))
978  (locally (declare (fixnum n vsp parent-vsp))
979    (multiple-value-bind (db-count first-db last-db)
980                         (count-db-links-in-frame vsp parent-vsp tcr)
981      (declare (ignore db-count))
982      (declare (fixnum first-db last-db))
983      (let ((arg-vsp (1- parent-vsp))
984            (cnt n)
985            (phys-cell 0)
986            db-link-p)
987        (declare (fixnum arg-vsp cnt phys-cell))
988        (loop
989          (if (eql (the fixnum (- arg-vsp 2)) last-db)
990            (setq db-link-p t
991                  arg-vsp last-db
992                  last-db (previous-db-link last-db first-db tcr)
993                  phys-cell (+ phys-cell 2))
994            (setq db-link-p nil))
995          (unless (in-stack-consed-value-cell-p arg-vsp vsp parent-vsp)
996            (when (< (decf cnt) 0)
997              (return
998               (if db-link-p
999                 ;; Really ought to find the next binding if not the
1000                 ;; current tcr, but noone has complained about this
1001                 ;; bug before, so why fix it?
1002                 (values (+ 2 arg-vsp)
1003                         :saved-special
1004                         (let* ((svar (index-svar (%fixnum-ref (1+ arg-vsp)))))
1005                           (if svar
1006                             (%svref svar ppc32::svar.symbol-cell)
1007                             nil)))
1008                 (multiple-value-bind (type name) (find-local-name phys-cell lfun pc)
1009                   (values arg-vsp type name))))))
1010          (incf phys-cell)
1011          (when (< (decf arg-vsp) vsp)
1012            (error "n out of range")))))))
1013
1014
1015
1016(defun nth-value-in-frame (sp n tcr &optional lfun pc child-frame vsp parent-vsp)
1017  (multiple-value-bind (loc type name)
1018                       (nth-value-in-frame-loc sp n tcr lfun pc child-frame vsp parent-vsp)
1019    (let* ((val (%fixnum-ref loc)))
1020      (when (and (eq type :saved-special)
1021                 (eq val (%no-thread-local-binding-marker))
1022                 name)
1023        (setq val (%sym-global-value name)))
1024      (values val  type name))))
1025
1026(defun set-nth-value-in-frame (sp n tcr new-value &optional child-frame vsp parent-vsp)
1027  (multiple-value-bind (loc type name)
1028      (nth-value-in-frame-loc sp n tcr nil nil child-frame vsp parent-vsp)
1029    (let* ((old-value (%fixnum-ref loc)))
1030      (if (and (eq type :saved-special)
1031               (eq old-value (%no-thread-local-binding-marker))
1032               name)
1033        ;; Setting the (shallow-bound) value of the outermost
1034        ;; thread-local binding of NAME.  Hmm.
1035        (%set-sym-global-value name new-value)
1036        (setf (%fixnum-ref loc) new-value)))))
1037
1038(defun nth-raw-frame (n start-frame tcr)
1039  (declare (fixnum n))
1040  (do* ((p start-frame (parent-frame p tcr))
1041        (i 0 (1+ i))
1042        (q (last-frame-ptr tcr)))
1043       ((or (null p) (eq p q) (%stack< q p tcr)))
1044    (declare (fixnum i))
1045    (if (= i n)
1046      (return p))))
1047
1048; True if the object is in one of the heap areas
1049(defun %in-consing-area-p (x area)
1050  (declare (fixnum x))                  ; lie
1051  (let* ((low (%fixnum-ref area ppc32::area.low))
1052         (high (%fixnum-ref area ppc32::area.high))
1053)
1054    (declare (fixnum low high))
1055    (and (<= low x) (< x high))))
1056
1057
1058
1059(defun in-any-consing-area-p (x)
1060  (do-consing-areas (area)
1061    (when (%in-consing-area-p x area)
1062      (return t))))
1063
1064(defun valid-subtag-p (subtag)
1065  (declare (fixnum subtag))
1066  (let* ((tagval (ldb (byte (- ppc32::num-subtag-bits ppc32::ntagbits) ppc32::ntagbits) subtag)))
1067    (declare (fixnum tagval))
1068    (case (logand subtag ppc32::fulltagmask)
1069      (#. ppc32::fulltag-immheader (not (eq (%svref *immheader-types* tagval) 'bogus)))
1070      (#. ppc32::fulltag-nodeheader (not (eq (%svref *nodeheader-types* tagval) 'bogus)))
1071      (t nil))))
1072
1073
1074
1075(defun valid-header-p (thing)
1076  (let* ((fulltag (fulltag thing)))
1077    (declare (fixnum fulltag))
1078    (case fulltag
1079      (#.ppc32::fulltag-misc (valid-subtag-p (typecode thing)))
1080      ((#.ppc32::fulltag-immheader #.ppc32::fulltag-nodeheader) nil)
1081      (t t))))
1082
1083
1084
1085
1086(defun bogus-thing-p (x)
1087  (when x
1088    (or (not (valid-header-p x))
1089        (let ((tag (lisptag x)))
1090          (unless (or (eql tag ppc32::tag-fixnum)
1091                      (eql tag ppc32::tag-imm)
1092                      (in-any-consing-area-p x))
1093            ;; This is terribly complicated, should probably write some LAP
1094            (let ((typecode (typecode x)))
1095                  (not (or (memq x *heap-ivectors*)
1096                           (case typecode
1097                             (#.ppc32::tag-list
1098                              (temporary-cons-p x))
1099                             ((#.ppc32::subtag-symbol #.ppc32::subtag-code-vector)
1100                              t)              ; no stack-consed symbols or code vectors
1101                             (#.ppc32::subtag-value-cell
1102                              (on-any-vstack x))
1103                             (t
1104                              (on-any-tsp-stack x)))))))))))
1105
1106;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1107;;;
1108;;; terminate-when-unreachable
1109;;;
1110
1111#|
1112Message-Id: <v02130502ad3e6a2f1542@[205.231.144.48]>
1113Mime-Version: 1.0
1114Content-Type: text/plain; charset="us-ascii"
1115Date: Wed, 7 Feb 1996 10:32:55 -0500
1116To: pmcldev@digitool.com
1117From: bitCraft@taconic.net (Bill St. Clair)
1118Subject: terminate-when-unreachable
1119
1120I propose that we add a general termination mechanism to PPC MCL.
1121We need it to properly terminate stack groups, it would be
1122a nicer way to do the termination for macptrs than the current
1123ad-hoc mechanism (which BTW is not yet part of PPC MCL), and
1124it is a nice addition to MCL. I don't think it's hard to make
1125the garbage collector support this, and I volunteer to do the
1126work unless Gary really wants to.
1127
1128I see two ways to support termination:
1129
11301) Do termination for hash tables. This was our plan for
1131   2.0, but Gary got confused about how to mark the objects at
1132   the right time (or so I remember).
1133
11342) Resurrect weak alists (they're not part of the PPC garbage
1135   collector) and add a termination bit to the population type.
1136   This allows for termination of weak lists and weak alists,
1137   though the termination mechanism really only needs termination
1138   for a single weak alist.
1139
1140I prefer option 2, weak alists, since it avoids the overhead
1141necessary to grow and rehash a hash table. It also uses less space,
1142since a finalizeable hash table needs to allocate two cons cells
1143for each entry so that the finalization code has some place to
1144put the deleted entry.
1145
1146I propose the following interface (slightly modified from what
1147Apple Dylan provides):
1148
1149terminate-when-unreachable object &optional (function 'terminate)
1150  When OBJECT becomes unreachable, funcall FUNCTION with OBJECT
1151  as a single argument. Each call of terminate-when-unreachable
1152  on a single (EQ) object registers a new termination function.
1153  All will be called when the object becomes unreachable.
1154
1155terminate object                                         [generic function]
1156  The default termination function
1157
1158terminate (object t)                                     [method]
1159  The default method. Ignores object. Returns nil.
1160
1161drain-termination-queue                                  [function]
1162  Drain the termination queue. I.e. call the termination function
1163  for every object that has become unreachable.
1164
1165*enable-automatic-termination*                           [variable]
1166  If true, the default, drain-termination-queue will be automatically
1167  called on the first event check after the garbage collector runs.
1168  If you set this to false, you are responsible for calling
1169  drain-termination-queue.
1170
1171cancel-terminate-when-unreachable object &optional function
1172  Removes the effect of the last call to terminate-when-unreachable
1173  for OBJECT & FUNCTION (both tested with EQ). Returns true if
1174  it found a match (which it won't if the object has been moved
1175  to the termination queue since terminate-when-unreachable was called).
1176  If FUNCTION is NIL or unspecified, then it will not be used; the
1177  last call to terminate-when-unreachable with the given OBJECT will
1178  be undone.
1179
1180termination-function object
1181  Return the function passed to the last call of terminate-when-unreachable
1182  for OBJECT. Will be NIL if the object has been put in the
1183  termination queue since terminate-when-unreachable was called.
1184
1185|#
1186
1187
1188(defvar *termination-population*
1189  (%cons-terminatable-alist))
1190
1191(defvar *termination-population-lock* (make-lock))
1192
1193
1194(defvar *enable-automatic-termination* t)
1195
1196(defun terminate-when-unreachable (object &optional (function 'terminate))
1197  (let ((new-cell (list (cons object function)))
1198        (population *termination-population*))
1199    (without-interrupts
1200     (with-lock-grabbed (*termination-population-lock*)
1201       (setf (cdr new-cell) (population-data population)
1202             (population-data population) new-cell)))
1203    function))
1204
1205(defmethod terminate ((object t))
1206  nil)
1207
1208(defun drain-termination-queue ()
1209  (let ((cell nil)
1210        (population *termination-population*))
1211    (loop
1212    (without-interrupts
1213      (with-lock-grabbed (*termination-population-lock*)
1214       (let ((list (population-termination-list population)))
1215         (unless list (return))
1216         (setf cell (car list)
1217               (population-termination-list population) (cdr list)))))
1218      (funcall (cdr cell) (car cell)))))
1219
1220(defun cancel-terminate-when-unreachable (object &optional (function nil function-p))
1221  (let ((found-it? nil))
1222    (flet ((test (object cell)
1223             (and (eq object (car cell))
1224                  (or (not function-p)
1225                      (eq function (cdr cell)))
1226                  (setq found-it? t))))
1227      (declare (dynamic-extent #'test))
1228      (without-interrupts
1229       (with-lock-grabbed (*termination-population-lock*)
1230         (setf (population-data *termination-population*)
1231               (delete object (population-data *termination-population*)
1232                       :test #'test
1233                       :count 1))))
1234      found-it?)))
1235
1236(defun termination-function (object)
1237  (without-interrupts
1238   (with-lock-grabbed (*termination-population-lock*)
1239     (cdr (assq object (population-data *termination-population*))))))
1240
1241(defun do-automatic-termination ()
1242  (when *enable-automatic-termination*
1243    (drain-termination-queue)))
1244
1245(queue-fixup
1246 (add-gc-hook 'do-automatic-termination :post-gc))
1247
Note: See TracBrowser for help on using the repository browser.