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

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

%VALID-REMAINING-TIMESPEC-TIME-P was a buggy workaround for a post-10.4
bug that's since been fixed; if we can assume that #_nanosleep works,
trust the remaining time it returns when interrupted.

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