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

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

when calling into the kernel to create a new thread, treat stack sizes
as unsigned native-word-size integers.

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