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

Last change on this file was 16776, checked in by rme, 3 years ago

Try again to make *ticks-per-second* at least 1000.

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