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

Last change on this file since 15270 was 15155, checked in by gb, 8 years ago

Keep process-whostate in a (CONS) cell in a slot in the PROCESS
object, not in a thread-local binding (so that we don't have to
suspend a process to print it.)

WITH-PROCESS-WHOSTATE needs to access this slot once and RPLACA it a
couple of times and needs to use UNWIND-PROTECT.

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