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

Last change on this file since 11832 was 11832, checked in by gz, 11 years ago

Another declaration tweak

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