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

Last change on this file since 11242 was 11242, checked in by gb, 11 years ago

In SAVE-BINDING inside %FOREIGN-THREAD-INITIALIZE: don't use %SVREF on
a symbol; use SYMBOL-BINDING-INDEX instead.

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