source: branches/working-0711/ccl/level-1/l1-lisp-threads.lisp @ 11089

Last change on this file since 11089 was 11089, checked in by gz, 13 years ago

Merge/bootstrap assorted low level stuff from trunk - kernel, syscall stuff, lowmem-bias, formatting tweaks, a few bug fixes included

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