source: branches/experimentation/devel/source/level-1/l1-lisp-threads.lisp @ 8045

Last change on this file since 8045 was 7948, checked in by gb, 13 years ago

INTERNAL-TIME-UNITS-PER-SECOND, whostate tweaks.

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