source: branches/working-0710/ccl/level-1/l1-lisp-threads.lisp @ 7601

Last change on this file since 7601 was 7601, checked in by gb, 14 years ago

In %nanosleep: don't resume sleep after interrupt if the second timespec
has a negative "seconds" field, or if the remaining time is greater
than the time in the last call.

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