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

Last change on this file since 12798 was 12798, checked in by gb, 10 years ago

Don't copy a thread's termination semaphore to the TCR (so don't
signal it in the last stages of thread termination, possibly after
the lisp pointer to the semaphore has been GCed.)

Do try to signal it from lisp code, at least in cases where the thread
terminates normally (in PROCESS-INITIAL-FORM-EXITED).

Seems to fix ticket:598.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 37.0 KB
Line 
1;;; -*- Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17;; l1-lisp-threads.lisp
18
19(in-package "CCL")
20
21(defvar *bind-io-control-vars-per-process* nil
22  "If true, bind I/O control variables per process")
23
24
25             
26(defun lisp-thread-p (thing)
27  (istruct-typep thing 'lisp-thread))
28
29(setf (type-predicate 'lisp-thread) 'lisp-thread-p)
30
31(defloadvar *ticks-per-second*
32    #+windows-target 1000
33    #-windows-target
34    (#_sysconf #$_SC_CLK_TCK))
35
36(defloadvar *ns-per-tick*
37    (floor 1000000000 *ticks-per-second*))
38
39#-windows-target
40(defun %nanosleep (seconds nanoseconds)
41  (with-process-whostate ("Sleep")
42    (rlet ((a :timespec)
43           (b :timespec))
44      (setf (pref a :timespec.tv_sec) seconds
45            (pref a :timespec.tv_nsec) nanoseconds)
46      (let* ((aptr a)
47             (bptr b))
48        (loop
49          (let* ((result 
50                  (external-call #+darwin-target "_nanosleep"
51                                 #-darwin-target "nanosleep"
52                                 :address aptr
53                                 :address bptr
54                                 :signed-fullword)))
55            (declare (type (signed-byte 32) result))
56            (if (and (< result 0)
57                     (eql (%get-errno) (- #$EINTR)))
58              ;; x86-64 Leopard bug.
59              (let* ((asec (pref aptr :timespec.tv_sec))
60                     (bsec (pref bptr :timespec.tv_sec)))
61                (if (and (>= bsec 0)
62                         (or (< bsec asec)
63                             (and (= bsec asec)
64                                  (< (pref bptr :timespec.tv_nsec)
65                                     (pref aptr :timespec.tv_nsec)))))
66                  (psetq aptr bptr bptr aptr)
67                  (return)))
68              (return))))))))
69
70
71(defun timeval->ticks (tv)
72  (+ (* *ticks-per-second* (pref tv :timeval.tv_sec))
73     (round (pref tv :timeval.tv_usec) (floor 1000000 *ticks-per-second*))))
74
75
76(defun gettimeofday (ptimeval &optional ptz)
77  (int-errno-ffcall (%kernel-import target::kernel-import-lisp-gettimeofday)
78                    :address ptimeval
79                    :address (or ptz (%null-ptr))
80                    :int))
81
82(defloadvar *lisp-start-timeval*
83    (progn
84      (let* ((r (make-record :timeval)))
85        (gettimeofday r)
86        r)))
87
88
89(defloadvar *internal-real-time-session-seconds* nil)
90
91
92(defun get-internal-real-time ()
93  "Return the real time in the internal time format. (See
94  INTERNAL-TIME-UNITS-PER-SECOND.) This is useful for finding elapsed time."
95  (rlet ((tv :timeval))
96    (gettimeofday tv)
97    (let* ((units (truncate (the fixnum (pref tv :timeval.tv_usec)) (/ 1000000 internal-time-units-per-second)))
98           (initial *internal-real-time-session-seconds*))
99      (if initial
100        (locally
101            (declare (type (unsigned-byte 32) initial))
102          (+ (* internal-time-units-per-second
103                (the (unsigned-byte 32)
104                  (- (the (unsigned-byte 32) (pref tv :timeval.tv_sec))
105                     initial)))
106             units))
107        (progn
108          (setq *internal-real-time-session-seconds*
109                (pref tv :timeval.tv_sec))
110          units)))))
111
112(defun get-tick-count ()
113  (values (floor (get-internal-real-time)
114                 (floor internal-time-units-per-second
115                        *ticks-per-second*))))
116
117
118
119
120(defun %kernel-global-offset (name-or-offset)
121  (if (fixnump name-or-offset)
122    name-or-offset
123    (target::%kernel-global name-or-offset)))
124
125
126(defun %kernel-global-offset-form (name-or-offset-form)
127  (cond ((quoted-form-p name-or-offset-form)
128         `(%target-kernel-global ,name-or-offset-form))
129        ((fixnump name-or-offset-form)
130         name-or-offset-form)
131        (t `(%target-kernel-global ',name-or-offset-form))))
132
133
134
135(defmacro %set-kernel-global (name-or-offset new-value)
136  `(%set-kernel-global-from-offset
137    ,(%kernel-global-offset-form name-or-offset)
138    ,new-value))
139
140
141
142; The number of bytes in a consing (or stack) area
143(defun %area-size (area)
144  (ash (- (%fixnum-ref area target::area.high)
145          (%fixnum-ref area target::area.low))
146       target::fixnumshift))
147
148(defun %stack-area-usable-size (area)
149  (ash (- (%fixnum-ref area target::area.high)
150          (%fixnum-ref area target::area.softlimit))
151       target::fixnum-shift))
152
153(defun %cons-lisp-thread (name &optional tcr)
154  (%istruct 'lisp-thread
155            tcr
156            name
157            0
158            0
159            0
160            nil
161            nil
162            (make-lock)
163            nil
164            :reset
165            (make-lock)))
166
167(defvar *current-lisp-thread*
168  (%cons-lisp-thread "Initial" (%current-tcr)))
169
170(defstatic *initial-lisp-thread* *current-lisp-thread*)
171
172(defun thread-change-state (thread oldstate newstate)
173  (with-lock-grabbed ((lisp-thread.state-change-lock thread))
174    (when (eq (lisp-thread.state thread) oldstate)
175      (setf (lisp-thread.state thread) newstate))))
176
177(thread-change-state *initial-lisp-thread* :reset :run)
178
179(defun thread-state (thread)
180  (with-lock-grabbed ((lisp-thread.state-change-lock thread))
181    (lisp-thread.state thread)))
182 
183(defun thread-make-startup-function (thread tcr)
184  #'(lambda ()
185      (thread-change-state thread :reset :run)
186      (let* ((*current-lisp-thread* thread)
187             (initial-function (lisp-thread.initial-function.args thread)))
188        (tcr-clear-preset-state tcr)
189        (%set-tcr-toplevel-function tcr nil)
190        (setf (interrupt-level) 0)
191        (apply (car initial-function) (cdr initial-function))
192        (cleanup-thread-tcr thread tcr))))
193
194(defun init-thread-from-tcr (tcr thread)
195  (let* ((cs-area (%fixnum-ref tcr target::tcr.cs-area))
196         (vs-area (%fixnum-ref tcr target::tcr.vs-area))
197         (ts-area (%fixnum-ref tcr target::tcr.ts-area)))
198    (when (or (zerop cs-area)
199              (zerop vs-area)
200              (zerop ts-area))
201      (error "Can't allocate new thread"))
202    (setf (lisp-thread.tcr thread) tcr
203          (lisp-thread.cs-size thread)
204          (%stack-area-usable-size cs-area)
205          (lisp-thread.vs-size thread)
206          (%stack-area-usable-size vs-area)
207          (lisp-thread.ts-size thread)
208          (%stack-area-usable-size ts-area)
209          (lisp-thread.startup-function thread)
210          (thread-make-startup-function thread tcr)))
211  (thread-change-state thread :exit :reset)
212  thread)
213
214(defun default-allocation-quantum ()
215  (ash 1 (%get-kernel-global 'default-allocation-quantum)))
216
217(defun new-lisp-thread-from-tcr (tcr name)
218  (let* ((thread (%cons-lisp-thread name tcr)))   
219    (init-thread-from-tcr tcr thread)
220    (push thread (population-data *lisp-thread-population*))
221    thread))
222
223(def-ccl-pointers initial-thread ()
224  (init-thread-from-tcr (%current-tcr) *initial-lisp-thread*))
225
226(defmethod print-object ((thread lisp-thread) stream)
227  (print-unreadable-object (thread stream :type t :identity t)
228    (format stream "~a" (lisp-thread.name thread))
229    (let* ((tcr (lisp-thread.tcr thread)))
230      (if (and tcr (not (eql 0 tcr)))
231        (format stream " [tcr @ #x~x]" (ash tcr target::fixnumshift))))))
232
233
234(defvar *lisp-thread-population*
235  (%cons-population (list *initial-lisp-thread*) $population_weak-list nil))
236
237
238
239
240
241(defparameter *default-control-stack-size*
242  #+32-bit-target (ash 1 20)
243  #+64-bit-target (ash 2 20))
244(defparameter *default-value-stack-size*
245  #+32-bit-target (ash 1 20)
246  #+64-bit-target (ash 2 20))
247(defparameter *default-temp-stack-size*
248  #+32-bit-target (ash 1 19)
249  #+64-bit-target (ash 2 19))
250
251
252(defstatic *initial-listener-default-control-stack-size* *default-control-stack-size*)
253(defstatic *initial-listener-default-value-stack-size* *default-value-stack-size*)
254(defstatic *initial-listener-default-temp-stack-size* *default-temp-stack-size*)
255
256
257(def-ccl-pointers listener-stack-sizes ()
258  (let* ((size (%get-kernel-global 'stack-size))) ; set by --thread-stack-size
259    (declare (fixnum size))
260    (when (> size 0)
261      (setq *initial-listener-default-control-stack-size* size
262            *initial-listener-default-value-stack-size* size
263            *initial-listener-default-temp-stack-size* (floor size 2)))))
264
265
266(defmacro with-area-macptr ((var area) &body body)
267  `(with-macptrs (,var)
268     (%setf-macptr-to-object ,var ,area)
269     ,@body))
270
271
272(defun gc-area.return-sp (area)
273  (%fixnum-ref area target::area.gc-count))
274
275
276(defun (setf gc-area.return-sp) (return-sp area)
277  (setf (%fixnum-ref area target::area.gc-count) return-sp))
278
279
280
281(defun shutdown-lisp-threads ()
282  )
283
284(defun %current-xp ()
285  (let ((xframe (%fixnum-ref (%current-tcr) target::tcr.xframe)))
286    (when (eql xframe 0)
287      (error "No current exception frame"))
288    (%fixnum-ref xframe
289                 (get-field-offset :xframe-list.this))))
290
291(defun new-tcr (cs-size vs-size ts-size)
292  (let* ((tcr (macptr->fixnum
293               (ff-call
294                (%kernel-import target::kernel-import-newthread)
295                #+64-bit-target :unsigned-doubleword
296                #+32-bit-target :unsigned-fullword cs-size
297                #+64-bit-target :unsigned-doubleword
298                #+32-bit-target :unsigned-fullword vs-size
299                #+64-bit-target :unsigned-doubleword
300                #+32-bit-target :unsigned-fullword ts-size
301                :address))))
302    (declare (fixnum tcr))
303    (if (zerop tcr)
304      (error "Can't create thread")
305      tcr)))
306
307(defun new-thread (name cstack-size vstack-size tstack-size)
308  (new-lisp-thread-from-tcr (new-tcr cstack-size vstack-size tstack-size) name))
309
310(defun new-tcr-for-thread (thread)
311  (let* ((tcr (new-tcr
312               (lisp-thread.cs-size thread)
313               (lisp-thread.vs-size thread)
314               (lisp-thread.ts-size thread))))
315    (setf (lisp-thread.tcr thread) tcr
316          (lisp-thread.startup-function thread)
317          (thread-make-startup-function thread tcr))
318    (thread-change-state thread :exit :reset)
319    tcr))
320 
321         
322
323
324
325(defconstant cstack-hardprot (ash 100 10))
326(defconstant cstack-softprot (ash 100 10))
327
328
329
330(defun tcr-flags (tcr)
331  (%fixnum-ref tcr target::tcr.flags))
332
333
334
335(defun %tcr-frame-ptr (tcr)
336  (with-macptrs (p)
337    (%setf-macptr-to-object p tcr)
338    (%fixnum-from-macptr
339     (ff-call (%kernel-import target::kernel-import-tcr-frame-ptr)
340              :address p
341              :address))))
342 
343(defun thread-exhausted-p (thread)
344  (or (null thread)
345      (null (lisp-thread.tcr thread))))
346
347(defun thread-total-run-time (thread)
348  (unless (thread-exhausted-p thread)
349    nil))
350
351(defun %tcr-interrupt (tcr)
352  ;; The other thread's interrupt-pending flag might get cleared
353  ;; right after we look and see it set, but since this is called
354  ;; with the lock on the thread's interrupt queue held, the
355  ;; pending interrupt won't have been taken yet.
356  ;; When a thread dies, it should try to clear its interrupt-pending
357  ;; flag.
358  (if (eql 0 (%fixnum-ref tcr target::tcr.interrupt-pending))
359    (%%tcr-interrupt tcr)
360    0))
361
362
363
364     
365     
366
367(defun thread-interrupt (thread process function &rest args)
368  (with-lock-grabbed ((lisp-thread.state-change-lock thread))
369    (case (lisp-thread.state thread)
370      (:run 
371       (with-lock-grabbed ((lisp-thread.interrupt-lock thread))
372         (let ((tcr (lisp-thread.tcr thread)))
373           (when tcr
374             (push (cons function args)
375                   (lisp-thread.interrupt-functions thread))
376             (eql 0 (%tcr-interrupt tcr))))))
377      (:reset
378       ;; Preset the thread with a function that'll return to the :reset
379       ;; state
380       (let* ((pif (process-initial-form process))
381              (pif-f (car pif))
382              (pif-args (cdr pif)))
383         (process-preset process #'(lambda ()
384                                     (%rplaca pif pif-f)
385                                     (%rplacd pif pif-args)
386                                     (apply function args)
387                                     ;; If function returns normally,
388                                     ;; return to the reset state
389                                     (%process-reset nil)))
390         (thread-enable thread (process-termination-semaphore process) (1- (integer-length (process-allocation-quantum process))) 0)
391         t)))))
392
393(defun thread-handle-interrupts ()
394  (let* ((thread *current-lisp-thread*))
395    (with-process-whostate ("Active")
396      (loop
397        (let* ((f (with-lock-grabbed ((lisp-thread.interrupt-lock thread))
398                    (pop (lisp-thread.interrupt-functions thread)))))
399          (if f
400            (apply (car f) (cdr f))
401            (return)))))))
402
403
404       
405(defun  thread-preset (thread function &rest args)
406  (setf (lisp-thread.initial-function.args thread)
407        (cons function args)))
408
409(defun thread-enable (thread termination-semaphore allocation-quantum &optional (timeout (* 60 60 24)))
410  (let* ((tcr (or (lisp-thread.tcr thread) (new-tcr-for-thread thread))))
411    (with-macptrs (s)
412      (%setf-macptr-to-object s (%fixnum-ref tcr target::tcr.reset-completion))
413      (when (%timed-wait-on-semaphore-ptr s timeout nil)
414        (%set-tcr-toplevel-function
415         tcr
416         (lisp-thread.startup-function thread))
417        (%activate-tcr tcr termination-semaphore allocation-quantum)
418        thread))))
419                             
420
421(defun cleanup-thread-tcr (thread tcr)
422  (let* ((flags (%fixnum-ref tcr target::tcr.flags)))
423    (declare (fixnum flags))
424    (if (logbitp arch::tcr-flag-bit-awaiting-preset flags)
425      (thread-change-state thread :run :reset)
426      (progn
427        (thread-change-state thread :run :exit)
428        (setf (lisp-thread.tcr thread) nil)))))
429
430(defun kill-lisp-thread (thread)
431  (unless (eq thread *initial-lisp-thread*)
432    (let* ((tcr (lisp-thread.tcr thread)))
433      (when tcr
434        (setf (lisp-thread.tcr thread) nil
435              (lisp-thread.state thread) :exit)
436        (%kill-tcr tcr)))))
437
438;;; This returns the underlying pthread, whatever that is, as an
439;;; unsigned integer.
440(defun lisp-thread-os-thread (thread)
441  (with-macptrs (tcrp)
442    (%setf-macptr-to-object tcrp (lisp-thread.tcr thread))
443    (unless (%null-ptr-p tcrp)
444      (let* ((natural (%get-natural tcrp target::tcr.osid)))
445        (unless (zerop natural) natural)))))
446
447
448                         
449;;; This returns something lower-level than the pthread, if that
450;;; concept makes sense.  On current versions of Linux, it returns
451;;; the pid of the clone()d process; on Darwin, it returns a Mach
452;;; thread.  On some (near)future version of Linux, the concept
453;;; may not apply.
454;;; The future is here: on Linux systems using NPTL, this returns
455;;; exactly the same thing that (getpid) does.
456;;; This should probably be retired; even if it does something
457;;; interesting, is the value it returns useful ?
458
459(defun lisp-thread-native-thread (thread)
460  (with-macptrs (tcrp)
461    (%setf-macptr-to-object tcrp (lisp-thread.tcr thread))
462    (unless (%null-ptr-p tcrp)
463      (#+32-bit-target %get-unsigned-long
464       #+64-bit-target %%get-unsigned-longlong tcrp target::tcr.native-thread-id))))
465
466(defun lisp-thread-suspend-count (thread)
467  (with-macptrs (tcrp)
468    (%setf-macptr-to-object tcrp (lisp-thread.tcr thread))
469    (unless (%null-ptr-p tcrp)
470      (#+32-bit-target %get-unsigned-long
471       #+64-bit-target %%get-unsigned-longlong tcrp target::tcr.suspend-count))))
472
473(defun tcr-clear-preset-state (tcr)
474  (let* ((flags (%fixnum-ref tcr target::tcr.flags)))
475    (declare (fixnum flags))
476    (setf (%fixnum-ref tcr target::tcr.flags)
477          (bitclr arch::tcr-flag-bit-awaiting-preset flags))))
478
479(defun tcr-set-preset-state (tcr)
480  (let* ((flags (%fixnum-ref tcr target::tcr.flags)))
481    (declare (fixnum flags))
482    (setf (%fixnum-ref tcr target::tcr.flags)
483          (bitset arch::tcr-flag-bit-awaiting-preset flags)))) 
484
485;;; This doesn't quite activate the thread; see PROCESS-TCR-ENABLE.
486(defun %activate-tcr (tcr termination-semaphore allocation-quantum)
487  (declare (ignore termination-semaphore))
488  (if (and tcr (not (eql 0 tcr)))
489    (with-macptrs (tcrp)
490      (%setf-macptr-to-object tcrp tcr)
491      (setf (%get-natural tcrp target::tcr.log2-allocation-quantum)
492            (or allocation-quantum (default-allocation-quantum)))
493      t)))
494                         
495(defvar *canonical-error-value*
496  '(*canonical-error-value*))
497
498
499(defun symbol-value-in-tcr (sym tcr)
500  (if (eq tcr (%current-tcr))
501    (%sym-value sym)
502    (unwind-protect
503         (progn
504           (%suspend-tcr tcr)
505           (let* ((loc (%tcr-binding-location tcr sym)))
506             (if loc
507               (%fixnum-ref loc)
508               (%sym-global-value sym))))
509      (%resume-tcr tcr))))
510
511(defun (setf symbol-value-in-tcr) (value sym tcr)
512  (if (eq tcr (%current-tcr))
513    (%set-sym-value sym value)
514    (unwind-protect
515         (progn
516           (%suspend-tcr tcr)
517           (let* ((loc (%tcr-binding-location tcr sym)))
518             (if loc
519               (setf (%fixnum-ref loc) value)
520               (%set-sym-global-value sym value))))
521      (%resume-tcr tcr))))
522
523;;; Backtrace support
524;;;
525
526
527
528(defmacro do-db-links ((db-link &optional var value) &body body)
529  (let ((thunk (gensym))
530        (var-var (or var (gensym)))
531        (value-var (or value (gensym))))
532    `(block nil
533       (let ((,thunk #'(lambda (,db-link ,var-var ,value-var)
534                         (declare (ignorable ,db-link))
535                         ,@(unless var (list `(declare (ignore ,var-var))))
536                         ,@(unless value (list `(declare (ignore ,value-var))))
537                         ,@body)))
538         (declare (dynamic-extent ,thunk))
539         (map-db-links ,thunk)))))
540
541
542
543
544(defun map-db-links (f)
545  (without-interrupts
546   (let ((db-link (%current-db-link)))
547     (loop
548       (when (eql 0 db-link) (return))
549       (funcall f db-link (%fixnum-ref db-link (* 1 target::node-size)) (%fixnum-ref db-link (* 2 target::node-size)))
550       (setq db-link (%fixnum-ref db-link))))))
551
552(defun %get-frame-ptr ()
553  (%current-frame-ptr))
554
555(defun %current-exception-frame ()
556  #+ppc-target *fake-stack-frames*
557  #+x86-target (or (let* ((xcf (%current-xcf)))
558                     (if xcf
559                       (%%frame-backlink xcf)))
560                   (%current-frame-ptr)))
561
562
563
564
565
566(defun next-catch (catch)
567  (let ((next-catch (uvref catch target::catch-frame.link-cell)))
568    (unless (eql next-catch 0) next-catch)))
569
570
571
572
573; @@@ this needs to load early so errors can work
574(defun next-lisp-frame (p context)
575  (let ((frame p))
576    (loop
577      (let ((parent (%frame-backlink frame context)))
578        (multiple-value-bind (lisp-frame-p bos-p) (lisp-frame-p parent context)
579          (if lisp-frame-p
580            (return parent)
581            (if bos-p
582              (return nil))))
583        (setq frame parent)))))
584
585(defun parent-frame (p context)
586  (loop
587    (let ((parent (next-lisp-frame p context)))
588      (when (or (null parent)
589                (not (catch-csp-p parent context)))
590        (return parent))
591      (setq p parent))))
592
593
594
595
596
597(defun last-frame-ptr (&optional context origin)
598  (let* ((current (or origin
599                      (if context (bt.current context) (%current-frame-ptr))))
600         (last current))
601    (loop
602      (setq current (parent-frame current context))
603      (if current
604        (setq last current)
605        (return last)))))
606
607
608
609(defun child-frame (p context )
610  (let* ((current (if context (bt.current context) (%current-frame-ptr)))
611         (last nil))
612    (loop
613      (when (null current)
614        (return nil))
615      (when (eq current p) (return last))
616      (setq last current
617            current (parent-frame current context)))))
618
619
620
621
622
623; This returns the current head of the db-link chain.
624(defun db-link (&optional context)
625  (if context
626    (bt.db-link context)
627    (%fixnum-ref (%current-tcr)  target::tcr.db-link)))
628
629(defun previous-db-link (db-link start )
630  (declare (fixnum db-link start))
631  (let ((prev nil))
632    (loop
633      (when (or (eql db-link start) (eql 0 start))
634        (return prev))
635      (setq prev start
636            start (%fixnum-ref start 0)))))
637
638(defun count-db-links-in-frame (vsp parent-vsp &optional context)
639  (declare (fixnum vsp parent-vsp))
640  (let ((db (db-link context))
641        (count 0)
642        (first nil)
643        (last nil))
644    (declare (fixnum db count))
645    (loop
646      (cond ((eql db 0)
647             (return (values count (or first 0) (or last 0))))
648            ((and (>= db vsp) (< db parent-vsp))
649             (unless first (setq first db))
650             (setq last db)
651             (incf count)))
652      (setq db (%fixnum-ref db)))))
653
654;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
655;;;
656;;; bogus-thing-p support
657;;;
658
659(defun %ptr-in-area-p (ptr area)
660  (declare (optimize (speed 3) (safety 0)) (fixnum ptr area))           ; lie, maybe
661  (and (<= (the fixnum (%fixnum-ref area target::area.low)) ptr)
662       (> (the fixnum (%fixnum-ref area target::area.high)) ptr)))
663
664(defun %active-area (area active)
665  (or (do ((a area (%fixnum-ref a target::area.older)))
666          ((eql a 0))
667        (when (%ptr-in-area-p active a)
668          (return a)))
669      (do ((a (%fixnum-ref area target::area.younger) (%fixnum-ref a target::area.younger)))
670          ((eql a 0))
671        (when (%ptr-in-area-p active a)
672          (return a)))))
673
674(defun %ptr-to-vstack-p (tcr idx)
675  (%ptr-in-area-p idx (%fixnum-ref tcr target::tcr.vs-area)))
676
677(defun %on-tsp-stack (tcr object)
678  (%ptr-in-area-p object (%fixnum-ref tcr target::tcr.ts-area)))
679
680(defun %on-csp-stack (tcr object)
681  (%ptr-in-area-p object (%fixnum-ref tcr target::tcr.cs-area)))
682
683(defparameter *aux-tsp-ranges* ())
684(defparameter *aux-vsp-ranges* ())
685(defparameter *aux-csp-ranges* ())
686
687(defun object-in-range-p (object range)
688  (declare (fixnum object))
689  (when range
690    (destructuring-bind (active . high) range
691      (declare (fixnum active high))
692      (and (< active object)
693           (< object high)))))
694
695(defun object-in-some-range (object ranges)
696  (dolist (r ranges)
697    (when (object-in-range-p object r)
698      (return t))))
699
700
701(defun on-any-tsp-stack (object)
702  (or (%on-tsp-stack (%current-tcr) object)
703      (object-in-some-range object *aux-tsp-ranges*)))
704
705(defun on-any-vstack (idx)
706  (or (%ptr-to-vstack-p (%current-tcr) idx)
707      (object-in-some-range idx *aux-vsp-ranges*)))
708
709(defun on-any-csp-stack (object)
710  (or (%on-csp-stack (%current-tcr) object)
711      (object-in-some-range object *aux-csp-ranges*)))
712
713;;; This MUST return either T or NIL.
714(defun temporary-cons-p (x)
715  (and (consp x)
716       (not (null (or (on-any-vstack x)
717                      (on-any-tsp-stack x))))))
718
719
720
721
722
723
724
725(defun %value-cell-header-at-p (cur-vsp)
726  (eql target::value-cell-header (%fixnum-address-of (%fixnum-ref cur-vsp))))
727
728(defun count-stack-consed-value-cells-in-frame (vsp parent-vsp)
729  (let ((cur-vsp vsp)
730        (count 0))
731    (declare (fixnum cur-vsp count))
732    (loop
733      (when (>= cur-vsp parent-vsp) (return))
734      (when (and (evenp cur-vsp) (%value-cell-header-at-p cur-vsp))
735        (incf count)
736        (incf cur-vsp))                 ; don't need to check value after header
737      (incf cur-vsp))
738    count))
739
740;;; stack consed value cells are one of two forms:
741;;; Well, they were of two forms.  When they existed, that is.
742;;;
743;;; nil             ; n-4
744;;; header          ; n = even address (multiple of 8)
745;;; value           ; n+4
746;;;
747;;; header          ; n = even address (multiple of 8)
748;;; value           ; n+4
749;;; nil             ; n+8
750
751(defun in-stack-consed-value-cell-p (arg-vsp vsp parent-vsp)
752  (declare (fixnum arg-vsp vsp parent-vsp))
753  (if (evenp arg-vsp)
754    (%value-cell-header-at-p arg-vsp)
755    (or (and (> arg-vsp vsp)
756             (%value-cell-header-at-p (the fixnum (1- arg-vsp))))
757        (let ((next-vsp (1+ arg-vsp)))
758          (declare (fixnum next-vsp))
759          (and (< next-vsp parent-vsp)
760               (%value-cell-header-at-p next-vsp))))))
761
762
763
764(defun count-values-in-frame (p context &optional child)
765  (declare (ignore child))
766  (multiple-value-bind (vsp parent-vsp) (vsp-limits p context)
767    (values
768     (- parent-vsp 
769        vsp
770        (* 2 (count-db-links-in-frame vsp parent-vsp context))))))
771
772(defun nth-value-in-frame-loc (sp n context lfun pc vsp parent-vsp)
773  (declare (fixnum sp))
774  (setq n (require-type n 'fixnum))
775  (unless (or (null vsp) (fixnump vsp))
776    (setq vsp (require-type vsp '(or null fixnum))))
777  (unless (or (null parent-vsp) (fixnump parent-vsp))
778    (setq parent-vsp (require-type parent-vsp '(or null fixnum))))
779  (unless (and vsp parent-vsp)
780    (multiple-value-setq (vsp parent-vsp) (vsp-limits sp context)))
781  (locally (declare (fixnum n vsp parent-vsp))
782    (multiple-value-bind (db-count first-db last-db)
783                         (count-db-links-in-frame vsp parent-vsp context)
784      (declare (ignore db-count))
785      (declare (fixnum first-db last-db))
786      (let ((arg-vsp (1- parent-vsp))
787            (cnt n)
788            (phys-cell 0)
789            db-link-p)
790        (declare (fixnum arg-vsp cnt phys-cell))
791        (loop
792          (if (eql (the fixnum (- arg-vsp 2)) last-db)
793            (setq db-link-p t
794                  arg-vsp last-db
795                  last-db (previous-db-link last-db first-db)
796                  phys-cell (+ phys-cell 2))
797            (setq db-link-p nil))
798            (when (< (decf cnt) 0)
799              (return
800               (if db-link-p
801                 (values (+ 2 arg-vsp)
802                         :saved-special
803                         (binding-index-symbol (%fixnum-ref (1+ arg-vsp))))
804                 (multiple-value-bind (type name) (find-local-name phys-cell lfun pc)
805                   (values arg-vsp type name)))))
806          (incf phys-cell)
807          (when (< (decf arg-vsp) vsp)
808            (error "~d out of range" n)))))))
809
810
811
812(defun nth-value-in-frame (sp n context &optional lfun pc vsp parent-vsp)
813  (multiple-value-bind (loc type name)
814                       (nth-value-in-frame-loc sp n context lfun pc vsp parent-vsp)
815    (let* ((val (%fixnum-ref loc)))
816      (when (and (eq type :saved-special)
817                 (eq val (%no-thread-local-binding-marker))
818                 name)
819        (setq val (%sym-global-value name)))
820      (values val  type name))))
821
822(defun set-nth-value-in-frame (sp n context new-value &optional vsp parent-vsp)
823  (multiple-value-bind (loc type name)
824      (nth-value-in-frame-loc sp n context nil nil vsp parent-vsp)
825    (let* ((old-value (%fixnum-ref loc)))
826      (if (and (eq type :saved-special)
827               (eq old-value (%no-thread-local-binding-marker))
828               name)
829        ;; Setting the (shallow-bound) value of the outermost
830        ;; thread-local binding of NAME.  Hmm.
831        (%set-sym-global-value name new-value)
832        (setf (%fixnum-ref loc) new-value)))))
833
834(defun nth-raw-frame (n start-frame context)
835  (declare (fixnum n))
836  (do* ((p start-frame (parent-frame p context))
837        (i 0 (1+ i))
838        (q (last-frame-ptr context)))
839       ((or (null p) (eq p q) (%stack< q p context)))
840    (declare (fixnum i))
841    (if (= i n)
842      (return p))))
843
844;;; True if the object is in one of the heap areas
845(defun %in-consing-area-p (x area)
846  (declare (optimize (speed 3) (safety 0)) (fixnum x))       ; lie
847  (let* ((low (%fixnum-ref area target::area.low))
848         (high (%fixnum-ref area target::area.high))
849)
850    (declare (fixnum low high))
851    (and (<= low x) (< x high))))
852
853
854
855(defun in-any-consing-area-p (x)
856  (do-consing-areas (area)
857    (when (%in-consing-area-p x area)
858      (return t))))
859
860
861
862
863
864
865
866
867
868;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
869;;;
870;;; terminate-when-unreachable
871;;;
872
873#|
874Message-Id: <v02130502ad3e6a2f1542@[205.231.144.48]>
875Mime-Version: 1.0
876Content-Type: text/plain; charset="us-ascii"
877Date: Wed, 7 Feb 1996 10:32:55 -0500
878To: pmcldev@digitool.com
879From: bitCraft@taconic.net (Bill St. Clair)
880Subject: terminate-when-unreachable
881
882I propose that we add a general termination mechanism to PPC MCL.
883We need it to properly terminate stack groups, it would be
884a nicer way to do the termination for macptrs than the current
885ad-hoc mechanism (which BTW is not yet part of PPC MCL), and
886it is a nice addition to MCL. I don't think it's hard to make
887the garbage collector support this, and I volunteer to do the
888work unless Gary really wants to.
889
890I see two ways to support termination:
891
8921) Do termination for hash tables. This was our plan for
893   2.0, but Gary got confused about how to mark the objects at
894   the right time (or so I remember).
895
8962) Resurrect weak alists (they're not part of the PPC garbage
897   collector) and add a termination bit to the population type.
898   This allows for termination of weak lists and weak alists,
899   though the termination mechanism really only needs termination
900   for a single weak alist.
901
902I prefer option 2, weak alists, since it avoids the overhead
903necessary to grow and rehash a hash table. It also uses less space,
904since a finalizeable hash table needs to allocate two cons cells
905for each entry so that the finalization code has some place to
906put the deleted entry.
907
908I propose the following interface (slightly modified from what
909Apple Dylan provides):
910
911terminate-when-unreachable object &optional (function 'terminate)
912  When OBJECT becomes unreachable, funcall FUNCTION with OBJECT
913  as a single argument. Each call of terminate-when-unreachable
914  on a single (EQ) object registers a new termination function.
915  All will be called when the object becomes unreachable.
916
917terminate object                                         [generic function]
918  The default termination function
919
920terminate (object t)                                     [method]
921  The default method. Ignores object. Returns nil.
922
923drain-termination-queue                                  [function]
924  Drain the termination queue. I.e. call the termination function
925  for every object that has become unreachable.
926
927*enable-automatic-termination*                           [variable]
928  If true, the default, drain-termination-queue will be automatically
929  called on the first event check after the garbage collector runs.
930  If you set this to false, you are responsible for calling
931  drain-termination-queue.
932
933cancel-terminate-when-unreachable object &optional function
934  Removes the effect of the last call to terminate-when-unreachable
935  for OBJECT & FUNCTION (both tested with EQ). Returns true if
936  it found a match (which it won't if the object has been moved
937  to the termination queue since terminate-when-unreachable was called).
938  If FUNCTION is NIL or unspecified, then it will not be used; the
939  last call to terminate-when-unreachable with the given OBJECT will
940  be undone.
941
942termination-function object
943  Return the function passed to the last call of terminate-when-unreachable
944  for OBJECT. Will be NIL if the object has been put in the
945  termination queue since terminate-when-unreachable was called.
946
947|#
948
949
950(defstatic *termination-population*
951  (%cons-terminatable-alist))
952
953(defstatic *termination-population-lock* (make-lock))
954
955
956(defvar *enable-automatic-termination* t)
957
958(defun terminate-when-unreachable (object &optional (function 'terminate))
959  "The termination mechanism is a way to have the garbage collector run a
960function right before an object is about to become garbage. It is very
961similar to the finalization mechanism which Java has. It is not standard
962Common Lisp, although other Lisp implementations have similar features.
963It is useful when there is some sort of special cleanup, deallocation,
964or releasing of resources which needs to happen when a certain object is
965no longer being used."
966  (let ((new-cell (cons object function))
967        (population *termination-population*))
968    (without-interrupts
969     (with-lock-grabbed (*termination-population-lock*)
970       (atomic-push-uvector-cell population population.data new-cell)))
971    function))
972
973(defmethod terminate ((object t))
974  nil)
975
976(defun drain-termination-queue ()
977  (with-lock-grabbed (*termination-population-lock*)
978    (let* ((population *termination-population*))
979      (loop
980        (multiple-value-bind (cell existed)
981            (atomic-pop-uvector-cell population population.termination-list)
982          (if (not existed)
983            (return)
984          (funcall (cdr cell) (car cell))))))))
985
986(defun cancel-terminate-when-unreachable (object &optional (function nil function-p))
987  (let* ((found nil))
988    (with-lock-grabbed (*termination-population-lock*)
989      ;; Have to defer GCing, e.g., defer responding to a GC
990      ;; suspend request here (that also defers interrupts)
991      ;; We absolutely, positively can't take an exception
992      ;; in here, so don't even bother to typecheck on
993      ;; car/cdr etc.
994      (with-deferred-gc
995          (do ((spine (population-data *termination-population*) (cdr spine))
996               (prev nil spine))
997              ((null spine))
998            (declare (optimize (speed 3) (safety 0)))
999            (let* ((head (car spine))
1000                   (tail (cdr spine))
1001                   (o (car head))
1002                   (f (cdr head)))
1003              (when (and (eq o object)
1004                         (or (null function-p)
1005                             (eq function f)))
1006                (if prev
1007                  (setf (cdr prev) tail)
1008                  (setf (population-data *termination-population*) tail))
1009                (setq found t)
1010                (return)))))
1011      found)))
1012
1013
1014(defun termination-function (object)
1015  (without-interrupts
1016   (with-lock-grabbed (*termination-population-lock*)
1017     (cdr (assq object (population-data *termination-population*))))))
1018
1019(defun do-automatic-termination ()
1020  (when *enable-automatic-termination*
1021    (drain-termination-queue)))
1022
1023(queue-fixup
1024 (add-gc-hook 'do-automatic-termination :post-gc))
1025
1026;;; A callback to handle foreign thread preparation, initialization,
1027;;; and termination.
1028;;; "preparation" involves telling the kernel to reserve space for
1029;;; some initial thread-specific special bindings.  The kernel
1030;;; needs to reserve this space on the foreign thread's vstack;
1031;;; it needs us to tell it how much space to reserve (enough
1032;;; for bindings of *current-thread*, *current-process*, and
1033;;; the default initial bindings of *PACKAGE*, etc.)
1034;;;
1035;;; "initialization" involves making those special bindings in
1036;;; the vstack space reserved by the kernel, and setting the
1037;;; values of *current-thread* and *current-process* to newly
1038;;; created values.
1039;;;
1040;;; "termination" involves removing the current thread and
1041;;; current process from the global thread/process lists.
1042;;; "preparation" and "initialization" happen when the foreign
1043;;; thread first tries to call lisp code.  "termination" happens
1044;;; via the pthread thread-local-storage cleanup mechanism.
1045(defcallback %foreign-thread-control (:without-interrupts t :int param :int)
1046  (declare (fixnum param))
1047  (cond ((< param 0) (%foreign-thread-prepare))
1048        ((= param 0) (%foreign-thread-initialize) 0)
1049        (t (%foreign-thread-terminate) 0)))
1050
1051
1052
1053(defun %foreign-thread-prepare ()
1054  (let* ((initial-bindings (standard-initial-bindings)))
1055    (%save-standard-binding-list initial-bindings)
1056    (* 3 (+ 2 (length initial-bindings)))))
1057
1058
1059(defun %foreign-thread-initialize ()
1060  ;; Recover the initial-bindings alist.
1061  (let* ((bsp (%saved-bindings-address))
1062         (initial-bindings (%fixnum-ref bsp )))
1063    (declare (fixnum bsp))
1064    ;; Um, this is a little more complicated now that we use
1065    ;; thread-local shallow binding
1066    (flet ((save-binding (new-value sym prev)
1067             (let* ((idx (symbol-binding-index sym))
1068                    (byte-idx (ash idx target::fixnum-shift))
1069                    (binding-vector (%fixnum-ref (%current-tcr) target::tcr.tlb-pointer))
1070                    (old-value (%fixnum-ref  binding-vector byte-idx)))
1071             (setf (%fixnum-ref binding-vector byte-idx) new-value
1072                   (%fixnum-ref bsp (ash -1 target::word-shift)) old-value
1073                   (%fixnum-ref bsp (ash -2 target::word-shift)) idx
1074                   (%fixnum-ref bsp (ash -3 target::word-shift)) prev
1075                   bsp (- bsp 3)))))
1076      (save-binding nil '*current-lisp-thread* 0)
1077      (save-binding nil '*current-process* bsp)
1078      (dolist (pair initial-bindings)
1079        (save-binding (funcall (cdr pair)) (car pair) bsp))
1080      ;; These may (or may not) be the most recent special bindings.
1081      ;; If they are, just set the current tcr's db-link to point
1082      ;; to BSP; if not, "append" them to the end of the current
1083      ;; linked list.
1084      (let* ((current-db-link (%fixnum-ref (%current-tcr) target::tcr.db-link)))
1085        (declare (fixnum current-db-link))
1086        (if (zerop current-db-link)
1087          (setf (%fixnum-ref (%current-tcr) target::tcr.db-link) bsp)
1088          (do* ((binding current-db-link)
1089                (next (%fixnum-ref binding 0)
1090                      (%fixnum-ref binding 0)))
1091               ()
1092            (if (zerop next)
1093              (return (setf (%fixnum-ref binding 0) bsp))
1094              (setq binding next)))))
1095      ;; Ensure that pending unwind-protects (for WITHOUT-INTERRUPTS
1096      ;; on the callback) don't try to unwind the binding stack beyond
1097      ;; where it was just set.
1098      (do* ((catch (%fixnum-ref (%current-tcr) target::tcr.catch-top)
1099                   (%fixnum-ref catch target::catch-frame.link)))
1100           ((zerop catch))
1101        (declare (fixnum catch))
1102        (when (eql 0 (%fixnum-ref catch target::catch-frame.db-link))
1103          (setf (%fixnum-ref catch target::catch-frame.db-link) bsp)))))
1104  (let* ((thread (new-lisp-thread-from-tcr (%current-tcr) "foreign")))
1105    (setq *current-lisp-thread* thread
1106          *current-process*
1107          (make-process "foreign" :thread thread)
1108          *whostate* "Foreign thread callback")))
1109   
1110;;; Remove the foreign thread's lisp-thread and lisp process from
1111;;; the global lists.
1112(defun %foreign-thread-terminate ()
1113  (let* ((proc *current-process*))
1114    (when proc
1115      (remove-from-all-processes proc)
1116      (let* ((ts (process-termination-semaphore proc)))
1117        (when ts (signal-semaphore ts))))))
1118
Note: See TracBrowser for help on using the repository browser.