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

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

Windows changes (*ticks-per-second*, no nanosleep, time stuff.)

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