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

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

Move WITH-SELF-BOUND-IO-CONTROL-VARS to macros.lisp.

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