source: branches/working-0711-perf/ccl/level-1/l1-lisp-threads.lisp @ 9514

Last change on this file since 9514 was 9514, checked in by gb, 12 years ago

Remove the LISP-THREAD-P type predicate.

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