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

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

%NANOSLEEP binds *WHOSTATE*.
Lose %TCR-EXHAUSTED-P: a tcr is a moving target. If a thread has
a tcr at the time we look, it's not "exhausted"; otherwise, it is.

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