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

Last change on this file since 6491 was 6491, checked in by gb, 15 years ago

Initial-lisp-thread, initial listener stack sizes now static.

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