source: branches/qres/ccl/level-1/l1-lisp-threads.lisp @ 15278

Last change on this file since 15278 was 14054, checked in by gz, 9 years ago

Bounds checking for tlb indices (r13745, r13752)

  • 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) 2009 Clozure Associates
4;;;   Copyright (C) 1994-2001 Digitool, Inc
5;;;   This file is part of Clozure CL. 
6;;;
7;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with Clozure CL as the
9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
11;;;   conflict, the preamble takes precedence. 
12;;;
13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17
18;; l1-lisp-threads.lisp
19
20(in-package "CCL")
21
22(defvar *bind-io-control-vars-per-process* nil
23  "If true, bind I/O control variables per process")
24
25
26             
27(defun lisp-thread-p (thing)
28  (istruct-typep thing 'lisp-thread))
29
30(setf (type-predicate 'lisp-thread) 'lisp-thread-p)
31
32(defloadvar *ticks-per-second*
33    #+windows-target 1000
34    #-windows-target
35    (#_sysconf #$_SC_CLK_TCK))
36
37(defloadvar *ns-per-tick*
38    (floor 1000000000 *ticks-per-second*))
39
40#-windows-target
41(defun %nanosleep (seconds nanoseconds)
42  (with-process-whostate ("Sleep")
43    (rlet ((a :timespec)
44           (b :timespec))
45      (setf (pref a :timespec.tv_sec) seconds
46            (pref a :timespec.tv_nsec) nanoseconds)
47      (let* ((aptr a)
48             (bptr b))
49        (loop
50          (let* ((result 
51                  (external-call #+darwin-target "_nanosleep"
52                                 #-darwin-target "nanosleep"
53                                 :address aptr
54                                 :address bptr
55                                 :signed-fullword)))
56            (declare (type (signed-byte 32) result))
57            (if (and (< result 0)
58                     (eql (%get-errno) (- #$EINTR)))
59              ;; x86-64 Leopard bug.
60              (let* ((asec (pref aptr :timespec.tv_sec))
61                     (bsec (pref bptr :timespec.tv_sec)))
62                (if (and (>= bsec 0)
63                         (or (< bsec asec)
64                             (and (= bsec asec)
65                                  (< (pref bptr :timespec.tv_nsec)
66                                     (pref aptr :timespec.tv_nsec)))))
67                  (psetq aptr bptr bptr aptr)
68                  (return)))
69              (return))))))))
70
71
72(defun timeval->ticks (tv)
73  (+ (* *ticks-per-second* (pref tv :timeval.tv_sec))
74     (round (pref tv :timeval.tv_usec) (floor 1000000 *ticks-per-second*))))
75
76
77(defun gettimeofday (ptimeval &optional ptz)
78  (int-errno-ffcall (%kernel-import target::kernel-import-lisp-gettimeofday)
79                    :address ptimeval
80                    :address (or ptz (%null-ptr))
81                    :int))
82
83(defloadvar *lisp-start-timeval*
84    (progn
85      (let* ((r (make-record :timeval)))
86        (gettimeofday r)
87        r)))
88
89
90(defloadvar *internal-real-time-session-seconds* nil)
91
92
93(defun get-internal-real-time ()
94  "Return the real time in the internal time format. (See
95  INTERNAL-TIME-UNITS-PER-SECOND.) This is useful for finding elapsed time."
96  (rlet ((tv :timeval))
97    (gettimeofday tv)
98    (let* ((units (truncate (the fixnum (pref tv :timeval.tv_usec)) (/ 1000000 internal-time-units-per-second)))
99           (initial *internal-real-time-session-seconds*))
100      (if initial
101        (locally
102            (declare (type (unsigned-byte 32) initial))
103          (+ (* internal-time-units-per-second
104                (the (unsigned-byte 32)
105                  (- (the (unsigned-byte 32) (pref tv :timeval.tv_sec))
106                     initial)))
107             units))
108        (progn
109          (setq *internal-real-time-session-seconds*
110                (pref tv :timeval.tv_sec))
111          units)))))
112
113(defun get-tick-count ()
114  (values (floor (get-internal-real-time)
115                 (floor internal-time-units-per-second
116                        *ticks-per-second*))))
117
118
119
120
121(defun %kernel-global-offset (name-or-offset)
122  (if (fixnump name-or-offset)
123    name-or-offset
124    (target::%kernel-global name-or-offset)))
125
126
127(defun %kernel-global-offset-form (name-or-offset-form)
128  (cond ((quoted-form-p name-or-offset-form)
129         `(%target-kernel-global ,name-or-offset-form))
130        ((fixnump name-or-offset-form)
131         name-or-offset-form)
132        (t `(%target-kernel-global ',name-or-offset-form))))
133
134
135
136(defmacro %set-kernel-global (name-or-offset new-value)
137  `(%set-kernel-global-from-offset
138    ,(%kernel-global-offset-form name-or-offset)
139    ,new-value))
140
141
142
143; The number of bytes in a consing (or stack) area
144(defun %area-size (area)
145  (ash (- (%fixnum-ref area target::area.high)
146          (%fixnum-ref area target::area.low))
147       target::fixnumshift))
148
149(defun %stack-area-usable-size (area)
150  (ash (- (%fixnum-ref area target::area.high)
151          (%fixnum-ref area target::area.softlimit))
152       target::fixnum-shift))
153
154(defun %cons-lisp-thread (name &optional tcr)
155  (%istruct 'lisp-thread
156            tcr
157            name
158            0
159            0
160            0
161            nil
162            nil
163            (make-lock)
164            nil
165            :reset
166            (make-lock)))
167
168(defvar *current-lisp-thread*
169  (%cons-lisp-thread "Initial" (%current-tcr)))
170
171(defstatic *initial-lisp-thread* *current-lisp-thread*)
172
173(defun thread-change-state (thread oldstate newstate)
174  (with-lock-grabbed ((lisp-thread.state-change-lock thread))
175    (when (eq (lisp-thread.state thread) oldstate)
176      (setf (lisp-thread.state thread) newstate))))
177
178(thread-change-state *initial-lisp-thread* :reset :run)
179
180(defun thread-state (thread)
181  (with-lock-grabbed ((lisp-thread.state-change-lock thread))
182    (lisp-thread.state thread)))
183 
184(defun thread-make-startup-function (thread tcr)
185  #'(lambda ()
186      (thread-change-state thread :reset :run)
187      (let* ((*current-lisp-thread* thread)
188             (initial-function (lisp-thread.initial-function.args thread)))
189        (tcr-clear-preset-state tcr)
190        (%set-tcr-toplevel-function tcr nil)
191        (setf (interrupt-level) 0)
192        (apply (car initial-function) (cdr initial-function))
193        (cleanup-thread-tcr thread tcr))))
194
195(defun init-thread-from-tcr (tcr thread)
196  (let* ((cs-area (%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 (fixnum 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 %tcr-frame-ptr (tcr)
337  (with-macptrs (p)
338    (%setf-macptr-to-object p tcr)
339    (%fixnum-from-macptr
340     (ff-call (%kernel-import target::kernel-import-tcr-frame-ptr)
341              :address p
342              :address))))
343 
344(defun thread-exhausted-p (thread)
345  (or (null thread)
346      (null (lisp-thread.tcr thread))))
347
348(defun thread-total-run-time (thread)
349  (unless (thread-exhausted-p thread)
350    nil))
351
352(defun %tcr-interrupt (tcr)
353  ;; The other thread's interrupt-pending flag might get cleared
354  ;; right after we look and see it set, but since this is called
355  ;; with the lock on the thread's interrupt queue held, the
356  ;; pending interrupt won't have been taken yet.
357  ;; When a thread dies, it should try to clear its interrupt-pending
358  ;; flag.
359  (if (eql 0 (%fixnum-ref tcr target::tcr.interrupt-pending))
360    (%%tcr-interrupt tcr)
361    0))
362
363
364
365     
366     
367
368(defun thread-interrupt (thread process function &rest args)
369  (with-lock-grabbed ((lisp-thread.state-change-lock thread))
370    (case (lisp-thread.state thread)
371      (:run 
372       (with-lock-grabbed ((lisp-thread.interrupt-lock thread))
373         (let ((tcr (lisp-thread.tcr thread)))
374           (when tcr
375             (push (cons function args)
376                   (lisp-thread.interrupt-functions thread))
377             (eql 0 (%tcr-interrupt tcr))))))
378      (:reset
379       ;; Preset the thread with a function that'll return to the :reset
380       ;; state
381       (let* ((pif (process-initial-form process))
382              (pif-f (car pif))
383              (pif-args (cdr pif)))
384         (process-preset process #'(lambda ()
385                                     (%rplaca pif pif-f)
386                                     (%rplacd pif pif-args)
387                                     (apply function args)
388                                     ;; If function returns normally,
389                                     ;; return to the reset state
390                                     (%process-reset nil)))
391         (thread-enable thread (process-termination-semaphore process) (1- (integer-length (process-allocation-quantum process))) 0)
392         t)))))
393
394(defun thread-handle-interrupts ()
395  (let* ((thread *current-lisp-thread*))
396    (with-process-whostate ("Active")
397      (loop
398        (let* ((f (with-lock-grabbed ((lisp-thread.interrupt-lock thread))
399                    (pop (lisp-thread.interrupt-functions thread)))))
400          (if f
401            (apply (car f) (cdr f))
402            (return)))))))
403
404
405       
406(defun  thread-preset (thread function &rest args)
407  (setf (lisp-thread.initial-function.args thread)
408        (cons function args)))
409
410(defun thread-enable (thread termination-semaphore allocation-quantum &optional (timeout (* 60 60 24)))
411  (let* ((tcr (or (lisp-thread.tcr thread) (new-tcr-for-thread thread))))
412    (with-macptrs (s)
413      (%setf-macptr-to-object s (%fixnum-ref tcr target::tcr.reset-completion))
414      (when (%timed-wait-on-semaphore-ptr s timeout nil)
415        (%set-tcr-toplevel-function
416         tcr
417         (lisp-thread.startup-function thread))
418        (%activate-tcr tcr termination-semaphore allocation-quantum)
419        thread))))
420                             
421
422(defun cleanup-thread-tcr (thread tcr)
423  (let* ((flags (%fixnum-ref tcr target::tcr.flags)))
424    (declare (fixnum flags))
425    (if (logbitp arch::tcr-flag-bit-awaiting-preset flags)
426      (thread-change-state thread :run :reset)
427      (progn
428        (thread-change-state thread :run :exit)
429        (setf (lisp-thread.tcr thread) nil)))))
430
431(defun kill-lisp-thread (thread)
432  (unless (eq thread *initial-lisp-thread*)
433    (let* ((tcr (lisp-thread.tcr thread)))
434      (when tcr
435        (setf (lisp-thread.tcr thread) nil
436              (lisp-thread.state thread) :exit)
437        (%kill-tcr tcr)))))
438
439;;; This returns the underlying pthread, whatever that is, as an
440;;; unsigned integer.
441(defun lisp-thread-os-thread (thread)
442  (with-macptrs (tcrp)
443    (%setf-macptr-to-object tcrp (lisp-thread.tcr thread))
444    (unless (%null-ptr-p tcrp)
445      (let* ((natural (%get-natural tcrp target::tcr.osid)))
446        (unless (zerop natural) natural)))))
447
448
449                         
450;;; This returns something lower-level than the pthread, if that
451;;; concept makes sense.  On current versions of Linux, it returns
452;;; the pid of the clone()d process; on Darwin, it returns a Mach
453;;; thread.  On some (near)future version of Linux, the concept
454;;; may not apply.
455;;; The future is here: on Linux systems using NPTL, this returns
456;;; exactly the same thing that (getpid) does.
457;;; This should probably be retired; even if it does something
458;;; interesting, is the value it returns useful ?
459
460(defun lisp-thread-native-thread (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.native-thread-id))))
466
467(defun lisp-thread-suspend-count (thread)
468  (with-macptrs (tcrp)
469    (%setf-macptr-to-object tcrp (lisp-thread.tcr thread))
470    (unless (%null-ptr-p tcrp)
471      (#+32-bit-target %get-unsigned-long
472       #+64-bit-target %%get-unsigned-longlong tcrp target::tcr.suspend-count))))
473
474(defun tcr-clear-preset-state (tcr)
475  (let* ((flags (%fixnum-ref tcr target::tcr.flags)))
476    (declare (fixnum flags))
477    (setf (%fixnum-ref tcr target::tcr.flags)
478          (bitclr arch::tcr-flag-bit-awaiting-preset flags))))
479
480(defun tcr-set-preset-state (tcr)
481  (let* ((flags (%fixnum-ref tcr target::tcr.flags)))
482    (declare (fixnum flags))
483    (setf (%fixnum-ref tcr target::tcr.flags)
484          (bitset arch::tcr-flag-bit-awaiting-preset flags)))) 
485
486;;; This doesn't quite activate the thread; see PROCESS-TCR-ENABLE.
487(defun %activate-tcr (tcr termination-semaphore allocation-quantum)
488  (declare (ignore termination-semaphore))
489  (if (and tcr (not (eql 0 tcr)))
490    (with-macptrs (tcrp)
491      (%setf-macptr-to-object tcrp tcr)
492      (setf (%get-natural tcrp target::tcr.log2-allocation-quantum)
493            (or allocation-quantum (default-allocation-quantum)))
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(defun %current-exception-frame ()
557  #+ppc-target *fake-stack-frames*
558  #+x86-target (or (let* ((xcf (%current-xcf)))
559                     (if xcf
560                       (%%frame-backlink xcf)))
561                   (%current-frame-ptr)))
562
563
564
565
566
567(defun next-catch (catch)
568  (let ((next-catch (uvref catch target::catch-frame.link-cell)))
569    (unless (eql next-catch 0) next-catch)))
570
571
572
573
574; @@@ this needs to load early so errors can work
575(defun next-lisp-frame (p context)
576  (let ((frame p))
577    (loop
578      (let ((parent (%frame-backlink frame context)))
579        (multiple-value-bind (lisp-frame-p bos-p) (lisp-frame-p parent context)
580          (if lisp-frame-p
581            (return parent)
582            (if bos-p
583              (return nil))))
584        (setq frame parent)))))
585
586(defun parent-frame (p context)
587  (loop
588    (let ((parent (next-lisp-frame p context)))
589      (when (or (null parent)
590                (not (catch-csp-p parent context)))
591        (return parent))
592      (setq p parent))))
593
594
595
596
597
598(defun last-frame-ptr (&optional context origin)
599  (let* ((current (or origin
600                      (if context (bt.current context) (%current-frame-ptr))))
601         (last current))
602    (loop
603      (setq current (parent-frame current context))
604      (if current
605        (setq last current)
606        (return last)))))
607
608
609
610(defun child-frame (p context )
611  (let* ((current (if context (bt.current context) (%current-frame-ptr)))
612         (last nil))
613    (loop
614      (when (null current)
615        (return nil))
616      (when (eq current p) (return last))
617      (setq last current
618            current (parent-frame current context)))))
619
620
621
622
623
624; This returns the current head of the db-link chain.
625(defun db-link (&optional context)
626  (if context
627    (bt.db-link context)
628    (%fixnum-ref (%current-tcr)  target::tcr.db-link)))
629
630(defun previous-db-link (db-link start )
631  (declare (fixnum db-link start))
632  (let ((prev nil))
633    (loop
634      (when (or (eql db-link start) (eql 0 start))
635        (return prev))
636      (setq prev start
637            start (%fixnum-ref start 0)))))
638
639(defun count-db-links-in-frame (vsp parent-vsp &optional context)
640  (declare (fixnum vsp parent-vsp))
641  (let ((db (db-link context))
642        (count 0)
643        (first nil)
644        (last nil))
645    (declare (fixnum db count))
646    (loop
647      (cond ((eql db 0)
648             (return (values count (or first 0) (or last 0))))
649            ((and (>= db vsp) (< db parent-vsp))
650             (unless first (setq first db))
651             (setq last db)
652             (incf count)))
653      (setq db (%fixnum-ref db)))))
654
655;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
656;;;
657;;; bogus-thing-p support
658;;;
659
660(defun %ptr-in-area-p (ptr area)
661  (declare (optimize (speed 3) (safety 0)) (fixnum ptr area))           ; lie, maybe
662  (and (<= (the fixnum (%fixnum-ref area target::area.low)) ptr)
663       (> (the fixnum (%fixnum-ref area target::area.high)) ptr)))
664
665(defun %active-area (area active)
666  (or (do ((a area (%fixnum-ref a target::area.older)))
667          ((eql a 0))
668        (when (%ptr-in-area-p active a)
669          (return a)))
670      (do ((a (%fixnum-ref area target::area.younger) (%fixnum-ref a target::area.younger)))
671          ((eql a 0))
672        (when (%ptr-in-area-p active a)
673          (return a)))))
674
675(defun %ptr-to-vstack-p (tcr idx)
676  (%ptr-in-area-p idx (%fixnum-ref tcr target::tcr.vs-area)))
677
678(defun %on-tsp-stack (tcr object)
679  (%ptr-in-area-p object (%fixnum-ref tcr target::tcr.ts-area)))
680
681(defun %on-csp-stack (tcr object)
682  (%ptr-in-area-p object (%fixnum-ref tcr target::tcr.cs-area)))
683
684(defparameter *aux-tsp-ranges* ())
685(defparameter *aux-vsp-ranges* ())
686(defparameter *aux-csp-ranges* ())
687
688(defun object-in-range-p (object range)
689  (declare (fixnum object))
690  (when range
691    (destructuring-bind (active . high) range
692      (declare (fixnum active high))
693      (and (< active object)
694           (< object high)))))
695
696(defun object-in-some-range (object ranges)
697  (dolist (r ranges)
698    (when (object-in-range-p object r)
699      (return t))))
700
701
702(defun on-any-tsp-stack (object)
703  (or (%on-tsp-stack (%current-tcr) object)
704      (object-in-some-range object *aux-tsp-ranges*)))
705
706(defun on-any-vstack (idx)
707  (or (%ptr-to-vstack-p (%current-tcr) idx)
708      (object-in-some-range idx *aux-vsp-ranges*)))
709
710(defun on-any-csp-stack (object)
711  (or (%on-csp-stack (%current-tcr) object)
712      (object-in-some-range object *aux-csp-ranges*)))
713
714;;; This MUST return either T or NIL.
715(defun temporary-cons-p (x)
716  (and (consp x)
717       (not (null (or (on-any-vstack x)
718                      (on-any-tsp-stack x))))))
719
720
721
722
723
724
725
726(defun %value-cell-header-at-p (cur-vsp)
727  (eql target::value-cell-header (%fixnum-address-of (%fixnum-ref cur-vsp))))
728
729(defun count-stack-consed-value-cells-in-frame (vsp parent-vsp)
730  (let ((cur-vsp vsp)
731        (count 0))
732    (declare (fixnum cur-vsp count))
733    (loop
734      (when (>= cur-vsp parent-vsp) (return))
735      (when (and (evenp cur-vsp) (%value-cell-header-at-p cur-vsp))
736        (incf count)
737        (incf cur-vsp))                 ; don't need to check value after header
738      (incf cur-vsp))
739    count))
740
741;;; stack consed value cells are one of two forms:
742;;; Well, they were of two forms.  When they existed, that is.
743;;;
744;;; nil             ; n-4
745;;; header          ; n = even address (multiple of 8)
746;;; value           ; n+4
747;;;
748;;; header          ; n = even address (multiple of 8)
749;;; value           ; n+4
750;;; nil             ; n+8
751
752(defun in-stack-consed-value-cell-p (arg-vsp vsp parent-vsp)
753  (declare (fixnum arg-vsp vsp parent-vsp))
754  (if (evenp arg-vsp)
755    (%value-cell-header-at-p arg-vsp)
756    (or (and (> arg-vsp vsp)
757             (%value-cell-header-at-p (the fixnum (1- arg-vsp))))
758        (let ((next-vsp (1+ arg-vsp)))
759          (declare (fixnum next-vsp))
760          (and (< next-vsp parent-vsp)
761               (%value-cell-header-at-p next-vsp))))))
762
763
764
765(defun count-values-in-frame (p context &optional child)
766  (declare (ignore child))
767  (multiple-value-bind (vsp parent-vsp) (vsp-limits p context)
768    (values
769     (- parent-vsp 
770        vsp
771        (* 2 (count-db-links-in-frame vsp parent-vsp context))))))
772
773(defun nth-value-in-frame-loc (sp n context lfun pc vsp parent-vsp)
774  (declare (fixnum sp))
775  (setq n (require-type n 'fixnum))
776  (unless (or (null vsp) (fixnump vsp))
777    (setq vsp (require-type vsp '(or null fixnum))))
778  (unless (or (null parent-vsp) (fixnump parent-vsp))
779    (setq parent-vsp (require-type parent-vsp '(or null fixnum))))
780  (unless (and vsp parent-vsp)
781    (multiple-value-setq (vsp parent-vsp) (vsp-limits sp context)))
782  (locally (declare (fixnum n vsp parent-vsp))
783    (multiple-value-bind (db-count first-db last-db)
784                         (count-db-links-in-frame vsp parent-vsp context)
785      (declare (ignore db-count))
786      (declare (fixnum first-db last-db))
787      (let ((arg-vsp (1- parent-vsp))
788            (cnt n)
789            (phys-cell 0)
790            db-link-p)
791        (declare (fixnum arg-vsp cnt phys-cell))
792        (loop
793          (if (eql (the fixnum (- arg-vsp 2)) last-db)
794            (setq db-link-p t
795                  arg-vsp last-db
796                  last-db (previous-db-link last-db first-db)
797                  phys-cell (+ phys-cell 2))
798            (setq db-link-p nil))
799            (when (< (decf cnt) 0)
800              (return
801               (if db-link-p
802                 (values (+ 2 arg-vsp)
803                         :saved-special
804                         (binding-index-symbol (%fixnum-ref (1+ arg-vsp))))
805                 (multiple-value-bind (type name) (find-local-name phys-cell lfun pc)
806                   (values arg-vsp type name)))))
807          (incf phys-cell)
808          (when (< (decf arg-vsp) vsp)
809            (error "~d out of range" n)))))))
810
811
812
813(defun nth-value-in-frame (sp n context &optional lfun pc vsp parent-vsp)
814  (multiple-value-bind (loc type name)
815                       (nth-value-in-frame-loc sp n context lfun pc vsp parent-vsp)
816    (let* ((val (%fixnum-ref loc)))
817      (when (and (eq type :saved-special)
818                 (eq val (%no-thread-local-binding-marker))
819                 name)
820        (setq val (%sym-global-value name)))
821      (values val  type name))))
822
823(defun set-nth-value-in-frame (sp n context new-value &optional vsp parent-vsp)
824  (multiple-value-bind (loc type name)
825      (nth-value-in-frame-loc sp n context nil nil vsp parent-vsp)
826    (let* ((old-value (%fixnum-ref loc)))
827      (if (and (eq type :saved-special)
828               (eq old-value (%no-thread-local-binding-marker))
829               name)
830        ;; Setting the (shallow-bound) value of the outermost
831        ;; thread-local binding of NAME.  Hmm.
832        (%set-sym-global-value name new-value)
833        (setf (%fixnum-ref loc) new-value)))))
834
835(defun nth-raw-frame (n start-frame context)
836  (declare (fixnum n))
837  (do* ((p start-frame (parent-frame p context))
838        (i 0 (1+ i))
839        (q (last-frame-ptr context)))
840       ((or (null p) (eq p q) (%stack< q p context)))
841    (declare (fixnum i))
842    (if (= i n)
843      (return p))))
844
845;;; True if the object is in one of the heap areas
846(defun %in-consing-area-p (x area)
847  (declare (optimize (speed 3) (safety 0)) (fixnum x))       ; lie
848  (let* ((low (%fixnum-ref area target::area.low))
849         (high (%fixnum-ref area target::area.high))
850)
851    (declare (fixnum low high))
852    (and (<= low x) (< x high))))
853
854
855
856(defun in-any-consing-area-p (x)
857  (do-consing-areas (area)
858    (when (%in-consing-area-p x area)
859      (return t))))
860
861
862
863
864
865
866
867
868
869;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
870;;;
871;;; terminate-when-unreachable
872;;;
873
874#|
875Message-Id: <v02130502ad3e6a2f1542@[205.231.144.48]>
876Mime-Version: 1.0
877Content-Type: text/plain; charset="us-ascii"
878Date: Wed, 7 Feb 1996 10:32:55 -0500
879To: pmcldev@digitool.com
880From: bitCraft@taconic.net (Bill St. Clair)
881Subject: terminate-when-unreachable
882
883I propose that we add a general termination mechanism to PPC MCL.
884We need it to properly terminate stack groups, it would be
885a nicer way to do the termination for macptrs than the current
886ad-hoc mechanism (which BTW is not yet part of PPC MCL), and
887it is a nice addition to MCL. I don't think it's hard to make
888the garbage collector support this, and I volunteer to do the
889work unless Gary really wants to.
890
891I see two ways to support termination:
892
8931) Do termination for hash tables. This was our plan for
894   2.0, but Gary got confused about how to mark the objects at
895   the right time (or so I remember).
896
8972) Resurrect weak alists (they're not part of the PPC garbage
898   collector) and add a termination bit to the population type.
899   This allows for termination of weak lists and weak alists,
900   though the termination mechanism really only needs termination
901   for a single weak alist.
902
903I prefer option 2, weak alists, since it avoids the overhead
904necessary to grow and rehash a hash table. It also uses less space,
905since a finalizeable hash table needs to allocate two cons cells
906for each entry so that the finalization code has some place to
907put the deleted entry.
908
909I propose the following interface (slightly modified from what
910Apple Dylan provides):
911
912terminate-when-unreachable object &optional (function 'terminate)
913  When OBJECT becomes unreachable, funcall FUNCTION with OBJECT
914  as a single argument. Each call of terminate-when-unreachable
915  on a single (EQ) object registers a new termination function.
916  All will be called when the object becomes unreachable.
917
918terminate object                                         [generic function]
919  The default termination function
920
921terminate (object t)                                     [method]
922  The default method. Ignores object. Returns nil.
923
924drain-termination-queue                                  [function]
925  Drain the termination queue. I.e. call the termination function
926  for every object that has become unreachable.
927
928*enable-automatic-termination*                           [variable]
929  If true, the default, drain-termination-queue will be automatically
930  called on the first event check after the garbage collector runs.
931  If you set this to false, you are responsible for calling
932  drain-termination-queue.
933
934cancel-terminate-when-unreachable object &optional function
935  Removes the effect of the last call to terminate-when-unreachable
936  for OBJECT & FUNCTION (both tested with EQ). Returns true if
937  it found a match (which it won't if the object has been moved
938  to the termination queue since terminate-when-unreachable was called).
939  If FUNCTION is NIL or unspecified, then it will not be used; the
940  last call to terminate-when-unreachable with the given OBJECT will
941  be undone.
942
943termination-function object
944  Return the function passed to the last call of terminate-when-unreachable
945  for OBJECT. Will be NIL if the object has been put in the
946  termination queue since terminate-when-unreachable was called.
947
948|#
949
950
951(defstatic *termination-population*
952  (%cons-terminatable-alist))
953
954(defstatic *termination-population-lock* (make-lock))
955
956
957(defvar *enable-automatic-termination* t)
958
959(defun terminate-when-unreachable (object &optional (function 'terminate))
960  "The termination mechanism is a way to have the garbage collector run a
961function right before an object is about to become garbage. It is very
962similar to the finalization mechanism which Java has. It is not standard
963Common Lisp, although other Lisp implementations have similar features.
964It is useful when there is some sort of special cleanup, deallocation,
965or releasing of resources which needs to happen when a certain object is
966no longer being used."
967  (let ((new-cell (cons object function))
968        (population *termination-population*))
969    (without-interrupts
970     (with-lock-grabbed (*termination-population-lock*)
971       (atomic-push-uvector-cell population population.data new-cell)))
972    function))
973
974(defmethod terminate ((object t))
975  nil)
976
977(defun drain-termination-queue ()
978  (with-lock-grabbed (*termination-population-lock*)
979    (let* ((population *termination-population*))
980      (loop
981        (multiple-value-bind (cell existed)
982            (atomic-pop-uvector-cell population population.termination-list)
983          (if (not existed)
984            (return)
985          (funcall (cdr cell) (car cell))))))))
986
987(defun cancel-terminate-when-unreachable (object &optional (function nil function-p))
988  (let* ((found nil))
989    (with-lock-grabbed (*termination-population-lock*)
990      ;; We don't really need to be very paranoid here.  Nothing can
991      ;; be added to the termination queue while we hold the lock,
992      ;; and the GC can't splice anything out of the list while
993      ;; we hold a strong reference to that list.
994      (let* ((population *termination-population*)
995             (queue (population.data population)))
996        (do* ((prev nil spine)
997              (spine queue (cdr spine)))
998             ((null spine))
999          (let* ((entry (car spine)))
1000            (destructuring-bind (o . f) entry
1001              (when (and (eq o object)
1002                         (or (null function-p)
1003                             (eq function f)))
1004                (if prev
1005                  (setf (cdr prev) (cdr spine))
1006                  (setf (population.data population) (cdr spine)))
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 (%ensure-tlb-index idx))
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
1113      (remove-from-all-processes proc)
1114      (let* ((ts (process-termination-semaphore proc)))
1115        (when ts (signal-semaphore ts))))))
1116
Note: See TracBrowser for help on using the repository browser.