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

Last change on this file since 14153 was 14119, checked in by gb, 9 years ago

Changes from ARM branch. Need testing ...

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