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

Last change on this file since 14619 was 14619, checked in by rme, 9 years ago

Merge shrink-tcr branch. This enables the 32-bit Windows lisp to run
on 64-bit Windows.

On 32-bit x86 ports, we expect to use a segment register to point to a
block of thread-local data called the TCR (thread context record).
This has always been kind of a bother on 32-bit Windows: we have been
using a kludge that allows us to use the %es segment register
(conditionalized on WIN32_ES_HACK).

Unfortunately, 64-bit Windows doesn't support using an LDT. This is
why the 32-bit lisp wouldn't run on 64-bit Windows.

The new scheme is to use some of the TlsSlots? (part of the Windows
TEB) for the most important parts of the TCR, and to introduce an "aux
vector" for the remaining TCR slots. Since %fs points to the TEB, we
can make this work. We reserve the last 34 (of 64) slots for our use,
and will die if we don't get them.

Microsoft's documentation says not to access the TlsSlots? directly
(you're supposed to use TlsGetValue/TlsSetValue?), so we're treading on
undocumented ground. Frankly, we've done worse.

This change introduces some ugliness. In lisp kernel C files, there's
a TCR_AUX(tcr) macro that expands to "tcr->aux" on win32, and to "tcr"
elsewhere.

If lisp or lap code has a pointer to a TCR, it's necessary to subtract
off target::tcr-bias (which on Windows/x86 is #xe10, the offset from
%fs to the TlsSlots? in the Windows TEB). We also sometimes have to load
target::tcr.aux to get at data which has been moved there.

These changes should only affect Windows/x86. The story on the other
platforms is just the same as before.

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