From: Daniel Barlow Date: Wed, 2 Apr 2003 11:15:10 +0000 (+0000) Subject: 0.pre8.28 X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=e365f2f7a9c66d307b48fee70778f4eaa84bdcc0;p=sbcl.git 0.pre8.28 === Threads merge, 100 metres === This is the first commit of experimental native threads for SBCL. Note that thread support is by default not compiled in - you need to add :sb-thread to target features. Note also that non-x86 probably doesn't build in this version - that will be fixed imminently See log messages for dan_native_threads_branch, dan_native_threads_2_branch, dan_native_threads_3_branch for more information. I'm not going to type it all in again --- diff --git a/build-order.lisp-expr b/build-order.lisp-expr index f9edeaf..ed002e7 100644 --- a/build-order.lisp-expr +++ b/build-order.lisp-expr @@ -427,7 +427,8 @@ ;; (and so that they don't cause lots of annoying compiler warnings ;; about undefined types). ("src/compiler/generic/core") - + ("src/code/cross-thread" :not-target) + ("src/code/thread") ("src/code/load") ("src/code/fop") ; needs macros from code/load.lisp @@ -507,6 +508,7 @@ ("src/compiler/early-aliencomp") ("src/compiler/target/c-call") ("src/compiler/target/cell") + ("src/code/late-symbol" :not-host) ("src/compiler/target/values") ("src/compiler/target/alloc") ("src/compiler/target/call") @@ -602,6 +604,10 @@ ; from "code/pathname" ("src/code/sharpm" :not-host) ; uses stuff from "code/reader" + #!+sb-thread + ("src/code/target-thread" :not-host) + #!-sb-thread + ("src/code/target-unithread" :not-host) ;; defines SB!DI:DO-DEBUG-FUN-BLOCKS, needed by target-disassem.lisp ("src/code/debug-int" :not-host) diff --git a/src/assembly/x86/assem-rtns.lisp b/src/assembly/x86/assem-rtns.lisp index 108acb4..c006ebe 100644 --- a/src/assembly/x86/assem-rtns.lisp +++ b/src/assembly/x86/assem-rtns.lisp @@ -197,7 +197,7 @@ (declare (ignore start count)) - (load-symbol-value catch *current-catch-block*) + (load-tl-symbol-value catch *current-catch-block*) LOOP @@ -232,7 +232,7 @@ (inst or block block) ; check for NULL pointer (inst jmp :z error)) - (load-symbol-value uwp *current-unwind-protect-block*) + (load-tl-symbol-value uwp *current-unwind-protect-block*) ;; Does *CURRENT-UNWIND-PROTECT-BLOCK* match the value stored in ;; argument's CURRENT-UWP-SLOT? @@ -247,7 +247,9 @@ (move block uwp) ;; Set next unwind protect context. (loadw uwp uwp unwind-block-current-uwp-slot) - (store-symbol-value uwp *current-unwind-protect-block*) + ;; we're about to reload ebp anyway, so let's borrow it here as a + ;; temporary. Hope this works + (store-tl-symbol-value uwp *current-unwind-protect-block* ebp-tn) DO-EXIT diff --git a/src/code/cross-thread.lisp b/src/code/cross-thread.lisp new file mode 100644 index 0000000..eafb3fb --- /dev/null +++ b/src/code/cross-thread.lisp @@ -0,0 +1,7 @@ +(in-package :sb!thread) + +(defun make-mutex (&key name value) nil) + +(defmacro with-recursive-lock ((mutex) &body body) + `(progn ,@body)) + diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index fb1af04..44aa628 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -527,15 +527,20 @@ #!-sb-fluid (declaim (inline control-stack-pointer-valid-p)) (defun control-stack-pointer-valid-p (x) (declare (type system-area-pointer x)) + (let* ((control-stack-start + (descriptor-sap sb!vm::*control-stack-start*)) + (control-stack-end + (sap+ + (descriptor-sap sb!vm::*binding-stack-start*) -4))) #!-stack-grows-downward-not-upward (and (sap< x (current-sp)) - (sap<= (int-sap control-stack-start) + (sap<= control-stack-start x) (zerop (logand (sap-int x) #b11))) #!+stack-grows-downward-not-upward (and (sap>= x (current-sp)) - (sap> (int-sap control-stack-end) x) - (zerop (logand (sap-int x) #b11)))) + (sap> control-stack-end x) + (zerop (logand (sap-int x) #b11))))) #!+x86 (sb!alien:define-alien-routine component-ptr-from-pc (system-area-pointer) @@ -711,7 +716,7 @@ (when (control-stack-pointer-valid-p fp) #!+x86 (multiple-value-bind (ra ofp) (x86-call-context fp) - (compute-calling-frame ofp ra frame)) + (and ra (compute-calling-frame ofp ra frame))) #!-x86 (compute-calling-frame #!-alpha @@ -883,14 +888,20 @@ escaped))))) #!+x86 +(defun nth-interrupt-context (n) + (declare (type (unsigned-byte 32) n) + (optimize (speed 3) (safety 0))) + (sb!alien:sap-alien (sb!vm::current-thread-offset-sap + (+ sb!vm::thread-interrupt-contexts-offset n)) + (* os-context-t))) + +#!+x86 (defun find-escaped-frame (frame-pointer) (declare (type system-area-pointer frame-pointer)) (/noshow0 "entering FIND-ESCAPED-FRAME") (dotimes (index *free-interrupt-context-index* (values nil 0 nil)) - (sb!alien:with-alien - ((lisp-interrupt-contexts (array (* os-context-t) nil) :extern)) (/noshow0 "at head of WITH-ALIEN") - (let ((context (sb!alien:deref lisp-interrupt-contexts index))) + (let ((context (nth-interrupt-context index))) (/noshow0 "got CONTEXT") (when (= (sap-int frame-pointer) (sb!vm:context-register context sb!vm::cfp-offset)) @@ -922,7 +933,7 @@ pc-offset code)) (/noshow0 "returning from FIND-ESCAPED-FRAME") (return - (values code pc-offset context)))))))))) + (values code pc-offset context))))))))) #!-x86 (defun find-escaped-frame (frame-pointer) diff --git a/src/code/debug.lisp b/src/code/debug.lisp index 0e33618..bc64c3b 100644 --- a/src/code/debug.lisp +++ b/src/code/debug.lisp @@ -71,6 +71,7 @@ "Should the debugger display beginner-oriented help messages?") (defun debug-prompt (stream) + (sb!thread::get-foreground) (format stream "~%~W~:[~;[~W~]] " (sb!di:frame-number *current-frame*) @@ -650,6 +651,9 @@ Other commands: (let ((*debugger-hook* nil)) (funcall old-hook condition old-hook)))) + ;; If we're a background thread and *background-threads-wait-for-debugger* + ;; is NIL, this will invoke a restart + ;; Note: CMU CL had (SB-UNIX:UNIX-SIGSETMASK 0) here. I deleted it ;; around sbcl-0.7.8.5 (by which time it had mutated to have a ;; #!-SUNOS prefix and a FIXME note observing that it wasn't needed @@ -703,6 +707,7 @@ reset to ~S." (*readtable* *debug-readtable*) (*print-readably* nil) (*package* original-package) + (background-p nil) (*print-pretty* original-print-pretty)) ;; Before we start our own output, finish any pending output. @@ -747,6 +752,10 @@ reset to ~S." ;; older debugger code which was written to do i/o on whatever ;; stream was in fashion at the time, and not all of it has ;; been converted to behave this way. -- WHN 2000-11-16) + + (setf background-p + (sb!thread::debugger-wait-until-foreground-thread *debug-io*)) + (unwind-protect (let (;; FIXME: Rebinding *STANDARD-OUTPUT* here seems wrong, ;; violating the principle of least surprise, and making ;; it impossible for the user to do reasonable things @@ -773,7 +782,8 @@ reset to ~S." '*debug-condition* '*debug-beginner-help-p*)) (show-restarts *debug-restarts* *debug-io*)) - (internal-debug)))))) + (internal-debug)) + (when background-p (sb!thread::release-foreground))))))) (defun show-restarts (restarts s) (cond ((null restarts) diff --git a/src/code/early-impl.lisp b/src/code/early-impl.lisp index 4e974f2..9d49849 100644 --- a/src/code/early-impl.lisp +++ b/src/code/early-impl.lisp @@ -22,6 +22,9 @@ *current-catch-block* *current-unwind-protect-block* sb!vm::*alien-stack* + #!+sb-thread sb!thread::*foreground-thread-stack* + sb!vm::*control-stack-start* + sb!vm::*binding-stack-start* ;; FIXME: The pseudo-atomic variable stuff should be ;; conditional on :SB-PSEUDO-ATOMIC-SYMBOLS, which ;; should be conditional on :X86, instead of the diff --git a/src/code/exhaust.lisp b/src/code/exhaust.lisp index e3ce6ef..7de2f00 100644 --- a/src/code/exhaust.lisp +++ b/src/code/exhaust.lisp @@ -11,6 +11,11 @@ ;;;; files for more information. (in-package "SB!KERNEL") -(define-alien-routine "protect_control_stack_guard_page" - sb!alien:int (protect-p sb!alien:int)) +(define-alien-routine ("protect_control_stack_guard_page" + %protect-control-stack-guard-page) + sb!alien:int (thread-id sb!alien:int) (protect-p sb!alien:int)) +(defun protect-control-stack-guard-page (n) + (%protect-control-stack-guard-page + (sb!thread:current-thread-id) (if n 1 0))) + diff --git a/src/code/gc.lisp b/src/code/gc.lisp index 2389750..5cfa8b0 100644 --- a/src/code/gc.lisp +++ b/src/code/gc.lisp @@ -280,10 +280,21 @@ function should notify the user that the system has finished GC'ing.") (sb!alien:define-alien-routine clear-auto-gc-trigger sb!alien:void) +#!+sb-thread +(def-c-var-frob gc-thread-pid "gc_thread_pid") +#!+sb-thread +(defun other-thread-collect-garbage (gen) + (setf (sb!alien:extern-alien "maybe_gc_pending" (sb!alien:unsigned 32)) + (1+ gen)) + (sb!unix:unix-kill (gc-thread-pid) :SIGALRM)) + ;;; This variable contains the function that does the real GC. This is ;;; for low-level GC experimentation. Do not touch it if you do not ;;; know what you are doing. -(defvar *internal-gc* #'collect-garbage) +(defvar *internal-gc* + #!+sb-thread #'other-thread-collect-garbage + #!-sb-thread #'collect-garbage) + ;;;; SUB-GC diff --git a/src/code/load.lisp b/src/code/load.lisp index a818cbf..1b552ae 100644 --- a/src/code/load.lisp +++ b/src/code/load.lisp @@ -16,6 +16,12 @@ (in-package "SB!FASL") +;;;; There looks to be an exciting amount of state being modified +;;;; here: certainly enough that I (dan, 2003.1.22) don't want to mess +;;;; around deciding how to thread-safetify it. So we use a Big Lock. +;;;; Because this code is mutually recursive with the compiler, we use +;;;; the *big-compiler-lock* + ;;;; miscellaneous load utilities ;;; Output the current number of semicolons after a fresh-line. @@ -327,25 +333,21 @@ (when (zerop (file-length stream)) (error "attempt to load an empty FASL file:~% ~S" (namestring stream))) (maybe-announce-load stream verbose) - (let* ((*fasl-input-stream* stream) - (*current-fop-table* (or (pop *free-fop-tables*) (make-array 1000))) - (*current-fop-table-size* (length *current-fop-table*)) - (*fop-stack-pointer-on-entry* *fop-stack-pointer*)) - (unwind-protect - ;; FIXME: This should probably become - ;; (LOOP WHILE (LOAD-FASL-GROUP-STREAM)) - ;; but as a LOOP newbie I don't want to do that until I can - ;; test it. - (do ((loaded-group (load-fasl-group stream) (load-fasl-group stream))) - ((not loaded-group))) - (setq *fop-stack-pointer* *fop-stack-pointer-on-entry*) - (push *current-fop-table* *free-fop-tables*) - ;; NIL out the stack and table, so that we don't hold onto garbage. - ;; - ;; FIXME: Couldn't we just get rid of the free fop table pool so - ;; that some of this NILing out would go away? - (fill *fop-stack* nil :end *fop-stack-pointer-on-entry*) - (fill *current-fop-table* nil))) + (sb!thread:with-recursive-lock (sb!c::*big-compiler-lock*) + (let* ((*fasl-input-stream* stream) + (*current-fop-table* (or (pop *free-fop-tables*) (make-array 1000))) + (*current-fop-table-size* (length *current-fop-table*)) + (*fop-stack-pointer-on-entry* *fop-stack-pointer*)) + (unwind-protect + (loop while (load-fasl-group stream)) + (setq *fop-stack-pointer* *fop-stack-pointer-on-entry*) + (push *current-fop-table* *free-fop-tables*) + ;; NIL out the stack and table, so that we don't hold onto garbage. + ;; + ;; FIXME: Couldn't we just get rid of the free fop table pool so + ;; that some of this NILing out would go away? + (fill *fop-stack* nil :end *fop-stack-pointer-on-entry*) + (fill *current-fop-table* nil)))) t) ;;; This is used in in target-load and also genesis, using diff --git a/src/code/symbol.lisp b/src/code/symbol.lisp index e1143df..76d7ab3 100644 --- a/src/code/symbol.lisp +++ b/src/code/symbol.lisp @@ -35,8 +35,10 @@ (about-to-modify-symbol-value symbol) (%set-symbol-value symbol new-value)) -(defun %set-symbol-value (symbol new-value) - (%set-symbol-value symbol new-value)) +;;; can't do this yet, the appropriate vop only gets defined in +;;; compiler/target/cell, 400 lines hence +;;;(defun %set-symbol-value (symbol new-value) +;;; (%set-symbol-value symbol new-value)) (defun makunbound (symbol) #!+sb-doc diff --git a/src/code/sysmacs.lisp b/src/code/sysmacs.lisp index 558eac1..1f9b8c8 100644 --- a/src/code/sysmacs.lisp +++ b/src/code/sysmacs.lisp @@ -10,24 +10,30 @@ ;;;; files for more information. (in-package "SB!IMPL") - - -#!-sb-thread -(defmacro atomic-incf (symbol-name &optional (delta 1)) - `(incf ,symbol-name ,delta)) - -(defmacro atomic-decf (place &optional (delta 1)) - `(atomic-incf ,place ,(- delta))) +;;; FIXME Not the most sensible way to do this: we could just use +;;; LOCK ADD, given that we don't need the old version. This will +;;; do until we get around to writing new VOPs +;;; FIXME in fact we're not SMP-safe without LOCK anyway, but +;;; this will do us for UP systems + +(defmacro atomic-incf/symbol (symbol-name &optional (delta 1)) + #!-sb-thread + `(incf ,symbol-name ,delta) + #!+sb-thread + `(locally + (declare (optimize (safety 0) (speed 3))) + (sb!vm::fast-symbol-global-value-xadd ',symbol-name ,delta) + ,symbol-name)) (defmacro without-gcing (&rest body) #!+sb-doc "Executes the forms in the body without doing a garbage collection." `(unwind-protect (progn - (atomic-incf *gc-inhibit*) + (atomic-incf/symbol *gc-inhibit*) ,@body) - (atomic-decf *gc-inhibit*) + (atomic-incf/symbol *gc-inhibit* -1) (when (and *need-to-collect-garbage* (zerop *gc-inhibit*)) (maybe-gc nil)))) diff --git a/src/code/thread.lisp b/src/code/thread.lisp index c5c7104..1984470 100644 --- a/src/code/thread.lisp +++ b/src/code/thread.lisp @@ -1,14 +1,7 @@ (in-package :sb!thread) -#+sb-xc-host -(defun make-mutex (&key name value) nil) - -#+sb-xc-host -(defmacro with-recursive-lock ((mutex) &body body) - `(progn ,@body)) - -#-sb-xc-host -(defmacro with-recursive-lock ((mutex) &body body) +(sb!xc:defmacro with-recursive-lock ((mutex) &body body) + #!+sb-thread (let ((cfp (gensym "CFP"))) `(let ((,cfp (ash (sb!sys:sap-int (sb!vm::current-fp) ) -2))) (unless (and (mutex-value ,mutex) @@ -17,15 +10,23 @@ (get-mutex ,mutex ,cfp)) (unwind-protect (progn ,@body) - (when (eql (mutex-value ,mutex) ,cfp) (release-mutex ,mutex)))))) + (when (eql (mutex-value ,mutex) ,cfp) (release-mutex ,mutex))))) + #!-sb-thread + `(progn ,@body)) +#!+sb-thread (defun get-foreground () - (when (not (eql (mutex-value *session-lock*) (CURRENT-THREAD-ID))) + (when (not (eql (mutex-value *session-lock*) (current-thread-id))) (get-mutex *session-lock*)) (sb!sys:enable-interrupt :sigint #'sb!unix::sigint-handler) t) +#!-sb-thread +(defun get-foreground () t) +#!+sb-thread (defun release-foreground () (sb!sys:enable-interrupt :sigint :ignore) (release-mutex *session-lock*) t) +#!-sb-thread +(defun release-foreground () t) diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp index 2b76918..1fa44d9 100644 --- a/src/code/toplevel.lisp +++ b/src/code/toplevel.lisp @@ -206,7 +206,7 @@ #!+stack-grows-downward-not-upward (let* ((csp (sap-int (sb!c::control-stack-pointer-sap))) - (end-of-stack (+ sb!vm:control-stack-start sb!c:*backend-page-size*)) + (end-of-stack (+ sb!vm::*control-stack-start* sb!c:*backend-page-size*)) (initial-offset (logand csp (1- bytes-per-scrub-unit)))) (labels ((scrub (ptr offset count) @@ -296,7 +296,8 @@ (defun toplevel-init () (/show0 "entering TOPLEVEL-INIT") - + (setf sb!thread::*session-lock* (sb!thread:make-mutex :name "the terminal")) + (sb!thread::get-foreground) (let ((sysinit nil) ; value of --sysinit option (userinit nil) ; value of --userinit option (reversed-evals nil) ; values of --eval options, in reverse order; and diff --git a/src/compiler/generic/objdef.lisp b/src/compiler/generic/objdef.lisp index f945ad3..a2797e4 100644 --- a/src/compiler/generic/objdef.lisp +++ b/src/compiler/generic/objdef.lisp @@ -326,7 +326,7 @@ ;; subtract 3 from (sb-kernel:get-lisp-obj-address 'NIL) you get the ;; first data slot, and if you subtract 7 you get a symbol header. - (value :set-trans %set-symbol-value + (value #!-sb-thread :set-trans #!-sb-thread %set-symbol-value :init :unbound) ;also the CAR of NIL-as-end-of-list (hash) ;the CDR of NIL-as-end-of-list @@ -336,7 +336,8 @@ (name :ref-trans symbol-name :init :arg) (package :ref-trans symbol-package :set-trans %set-symbol-package - :init :null)) + :init :null) + #!+sb-thread (tls-index)) (define-primitive-object (complex-single-float :lowtag other-pointer-lowtag @@ -359,3 +360,27 @@ (real :c-type "long double" :length #!+x86 3 #!+sparc 4) (imag :c-type "long double" :length #!+x86 3 #!+sparc 4)) +;;; this isn't actually a lisp object at all, it's a c structure that lives +;;; in c-land. However, we need sight of so many parts of it from Lisp that +;;; it makes sense to define it here anyway, so that the GENESIS machinery +;;; can take care of maintaining Lisp and C versions. +;;; Hence the even-fixnum lowtag just so we don't get odd(sic) numbers +;;; added to the slot offsets +(define-primitive-object (thread :lowtag even-fixnum-lowtag) + ;; unbound_marker is borrowed very briefly at thread startup to + ;; pass the address of initial-function into new_thread_trampoline + (unbound-marker :init :unbound) ; tls[0] = UNBOUND_MARKER_WIDETAG + (binding-stack-start :c-type "lispobj *") + (binding-stack-pointer :c-type "lispobj *") + (control-stack-start :c-type "lispobj *") + (alien-stack-start :c-type "lispobj *") + (alien-stack-pointer :c-type "lispobj *") + (alloc-region :c-type "struct alloc_region" :length 5) + (pid :c-type "pid_t") + (tls-cookie) ; on x86, the LDT index + (this :c-type "struct thread *") + (next :c-type "struct thread *") + (pseudo-atomic-atomic) + (pseudo-atomic-interrupted) + (interrupt-data :c-type "struct interrupt_data *") + (interrupt-contexts :c-type "os_context_t *" :rest-p t)) diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index e255974..41c49a1 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -87,6 +87,11 @@ ;;; normally causes nested uses to be no-ops). (defvar *in-compilation-unit* nil) +;;; This lock is siezed in the same situation: the compiler is not +;;; presently thread-safe +(defvar *big-compiler-lock* + (sb!thread:make-mutex :name "big compiler lock")) + ;;; Count of the number of compilation units dynamically enclosed by ;;; the current active WITH-COMPILATION-UNIT that were unwound out of. (defvar *aborted-compilation-unit-count*) @@ -127,7 +132,7 @@ ;; Inside another WITH-COMPILATION-UNIT, a WITH-COMPILATION-UNIT is ;; ordinarily (unless OVERRIDE) basically a no-op. (unwind-protect - (multiple-value-prog1 (funcall fn) (setf succeeded-p t)) + (multiple-value-prog1 (funcall fn) (setf succeeded-p t)) (unless succeeded-p (incf *aborted-compilation-unit-count*))) ;; FIXME: Now *COMPILER-FOO-COUNT* stuff is bound in more than @@ -140,16 +145,17 @@ (*compiler-note-count* 0) (*undefined-warnings* nil) (*in-compilation-unit* t)) - (handler-bind ((parse-unknown-type - (lambda (c) - (note-undefined-reference - (parse-unknown-type-specifier c) - :type)))) - (unwind-protect - (multiple-value-prog1 (funcall fn) (setf succeeded-p t)) - (unless succeeded-p - (incf *aborted-compilation-unit-count*)) - (summarize-compilation-unit (not succeeded-p)))))))) + (sb!thread:with-recursive-lock (*big-compiler-lock*) + (handler-bind ((parse-unknown-type + (lambda (c) + (note-undefined-reference + (parse-unknown-type-specifier c) + :type)))) + (unwind-protect + (multiple-value-prog1 (funcall fn) (setf succeeded-p t)) + (unless succeeded-p + (incf *aborted-compilation-unit-count*)) + (summarize-compilation-unit (not succeeded-p))))))))) ;;; This is to be called at the end of a compilation unit. It signals ;;; any residual warnings about unknown stuff, then prints the total diff --git a/src/compiler/x86/c-call.lisp b/src/compiler/x86/c-call.lisp index ca820a6..6f09cb7 100644 --- a/src/compiler/x86/c-call.lisp +++ b/src/compiler/x86/c-call.lisp @@ -209,27 +209,57 @@ (define-vop (alloc-alien-stack-space) (:info amount) + #!+sb-thread (:temporary (:sc unsigned-reg) temp) (:results (result :scs (sap-reg any-reg))) + #!+sb-thread (:generator 0 (aver (not (location= result esp-tn))) (unless (zerop amount) (let ((delta (logandc2 (+ amount 3) 3))) - (inst sub (make-ea :dword - :disp (+ nil-value - (static-symbol-offset '*alien-stack*) - (ash symbol-value-slot word-shift) - (- other-pointer-lowtag))) - delta))) + (inst mov temp + (make-ea :dword + :disp (+ nil-value + (static-symbol-offset '*alien-stack*) + (ash symbol-tls-index-slot word-shift) + (- other-pointer-lowtag)))) + (inst fs-segment-prefix) + (inst sub (make-ea :dword :scale 1 :index temp) delta))) + (load-tl-symbol-value result *alien-stack*)) + #!-sb-thread + (:generator 0 + (aver (not (location= result esp-tn))) + (unless (zerop amount) + (let ((delta (logandc2 (+ amount 3) 3))) + (inst sub (make-ea :dword + :disp (+ nil-value + (static-symbol-offset '*alien-stack*) + (ash symbol-value-slot word-shift) + (- other-pointer-lowtag))) + delta))) (load-symbol-value result *alien-stack*))) (define-vop (dealloc-alien-stack-space) (:info amount) + #!+sb-thread (:temporary (:sc unsigned-reg) temp) + #!+sb-thread (:generator 0 (unless (zerop amount) (let ((delta (logandc2 (+ amount 3) 3))) - (inst add (make-ea :dword + (inst mov temp + (make-ea :dword :disp (+ nil-value (static-symbol-offset '*alien-stack*) - (ash symbol-value-slot word-shift) - (- other-pointer-lowtag))) - delta))))) + (ash symbol-tls-index-slot word-shift) + (- other-pointer-lowtag)))) + (inst fs-segment-prefix) + (inst add (make-ea :dword :scale 1 :index temp) delta)))) + #!-sb-thread + (:generator 0 + (unless (zerop amount) + (let ((delta (logandc2 (+ amount 3) 3))) + (inst add (make-ea :dword + :disp (+ nil-value + (static-symbol-offset '*alien-stack*) + (ash symbol-value-slot word-shift) + (- other-pointer-lowtag))) + delta))))) diff --git a/src/compiler/x86/cell.lisp b/src/compiler/x86/cell.lisp index c3cfb86..1958778 100644 --- a/src/compiler/x86/cell.lisp +++ b/src/compiler/x86/cell.lisp @@ -50,16 +50,45 @@ ;; Else, value not immediate. (storew value object offset lowtag)))) + + ;;;; symbol hacking VOPs ;;; these next two cf the sparc version, by jrd. ;;; FIXME: Deref this ^ reference. + ;;; The compiler likes to be able to directly SET symbols. +#!+sb-thread +(define-vop (set) + (:args (symbol :scs (descriptor-reg)) + (value :scs (descriptor-reg any-reg))) + (:translate sb!kernel:%set-symbol-value) + (:temporary (:sc descriptor-reg ) tls) + ;;(:policy :fast-safe) + (:generator 4 + (let ((global-val (gen-label)) + (done (gen-label))) + (loadw tls symbol symbol-tls-index-slot other-pointer-lowtag) + (inst or tls tls) + (inst jmp :z global-val) + (inst fs-segment-prefix) + (inst cmp (make-ea :dword :scale 1 :index tls) unbound-marker-widetag) + (inst jmp :z global-val) + (inst fs-segment-prefix) + (inst mov (make-ea :dword :scale 1 :index tls) value) + (inst jmp done) + (emit-label global-val) + (storew value symbol symbol-value-slot other-pointer-lowtag) + (emit-label done)))) + +;; unithreaded it's a lot simpler ... +#!-sb-thread (define-vop (set cell-set) (:variant symbol-value-slot other-pointer-lowtag)) ;;; Do a cell ref with an error check for being unbound. +;;; XXX stil used? I can't see where -dan (define-vop (checked-cell-ref) (:args (object :scs (descriptor-reg) :target obj-temp)) (:results (value :scs (descriptor-reg any-reg))) @@ -70,6 +99,33 @@ ;;; With Symbol-Value, we check that the value isn't the trap object. So ;;; Symbol-Value of NIL is NIL. +#!+sb-thread +(define-vop (symbol-value) + (:translate symbol-value) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg) :to (:result 1))) + (:results (value :scs (descriptor-reg any-reg))) + (:vop-var vop) + (:save-p :compute-only) + (:generator 9 + (let* ((err-lab (generate-error-code vop unbound-symbol-error object)) + (ret-lab (gen-label))) + (loadw value object symbol-tls-index-slot other-pointer-lowtag) + (inst fs-segment-prefix) + (inst mov value (make-ea :dword :index value :scale 1)) + (inst cmp value unbound-marker-widetag) + (inst jmp :ne ret-lab) + (loadw value object symbol-value-slot other-pointer-lowtag) + (inst cmp value unbound-marker-widetag) + (inst jmp :e err-lab) + (emit-label ret-lab)))) + +#!+sb-thread +(define-vop (fast-symbol-value symbol-value) + (:policy :fast) + (:translate symbol-value)) + +#!-sb-thread (define-vop (symbol-value) (:translate symbol-value) (:policy :fast-safe) @@ -83,18 +139,49 @@ (inst cmp value unbound-marker-widetag) (inst jmp :e err-lab)))) +#!-sb-thread (define-vop (fast-symbol-value cell-ref) (:variant symbol-value-slot other-pointer-lowtag) (:policy :fast) (:translate symbol-value)) -(defknown fast-symbol-value-xadd (symbol fixnum) fixnum ()) -(define-vop (fast-symbol-value-xadd cell-xadd) +(defknown fast-symbol-global-value-xadd (symbol fixnum) fixnum ()) + +(define-vop (fast-symbol-global-value-xadd cell-xadd) (:variant symbol-value-slot other-pointer-lowtag) (:policy :fast) - (:translate fast-symbol-value-xadd) + (:translate fast-symbol-global-value-xadd) (:arg-types * tagged-num)) +#!+sb-thread +(define-vop (boundp) + (:translate boundp) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:conditional) + (:info target not-p) + (:temporary (:sc descriptor-reg #+nil(:from (:argument 0))) value) + (:generator 9 + (if not-p + (let ((not-target (gen-label))) + (loadw value object symbol-value-slot other-pointer-lowtag) + (inst cmp value unbound-marker-widetag) + (inst jmp :ne not-target) + (loadw value object symbol-tls-index-slot other-pointer-lowtag) + (inst fs-segment-prefix) + (inst cmp (make-ea :dword :index value :scale 1) unbound-marker-widetag) + (inst jmp :e target) + (emit-label not-target)) + (progn + (loadw value object symbol-value-slot other-pointer-lowtag) + (inst cmp value unbound-marker-widetag) + (inst jmp :ne target) + (loadw value object symbol-tls-index-slot other-pointer-lowtag) + (inst fs-segment-prefix) + (inst cmp (make-ea :dword :index value :scale 1) unbound-marker-widetag) + (inst jmp :ne target))))) + +#!-sb-thread (define-vop (boundp) (:translate boundp) (:policy :fast-safe) @@ -107,6 +194,7 @@ (inst cmp value unbound-marker-widetag) (inst jmp (if not-p :e :ne) target))) + (define-vop (symbol-hash) (:policy :fast-safe) (:translate symbol-hash) @@ -176,9 +264,38 @@ ;;; the symbol on the binding stack and stuff the new value into the ;;; symbol. +#!+sb-thread (define-vop (bind) (:args (val :scs (any-reg descriptor-reg)) (symbol :scs (descriptor-reg))) + (:temporary (:sc unsigned-reg) tls-index temp bsp) + (:generator 5 + (let ((tls-index-valid (gen-label))) + (load-tl-symbol-value bsp *binding-stack-pointer*) + (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag) + (inst add bsp (* binding-size n-word-bytes)) + (store-tl-symbol-value bsp *binding-stack-pointer* temp) + + (inst or tls-index tls-index) + (inst jmp :ne tls-index-valid) + ;; allocate a new tls-index + (load-symbol-value tls-index *free-tls-index*) + (inst add tls-index 4) ;XXX surely we can do this more + (store-symbol-value tls-index *free-tls-index*) ;succintly + (inst sub tls-index 4) + (storew tls-index symbol symbol-tls-index-slot other-pointer-lowtag) + (emit-label tls-index-valid) + (inst fs-segment-prefix) + (inst mov temp (make-ea :dword :scale 1 :index tls-index)) + (storew temp bsp (- binding-value-slot binding-size)) + (storew symbol bsp (- binding-symbol-slot binding-size)) + (inst fs-segment-prefix) + (inst mov (make-ea :dword :scale 1 :index tls-index) val)))) + +#!-sb-thread +(define-vop (bind) + (:args (val :scs (any-reg descriptor-reg)) + (symbol :scs (descriptor-reg))) (:temporary (:sc unsigned-reg) temp bsp) (:generator 5 (load-symbol-value bsp *binding-stack-pointer*) @@ -189,6 +306,26 @@ (storew symbol bsp (- binding-symbol-slot binding-size)) (storew val symbol symbol-value-slot other-pointer-lowtag))) + +#!+sb-thread +(define-vop (unbind) + ;; four temporaries? + (:temporary (:sc unsigned-reg) symbol value bsp tls-index) + (:generator 0 + (load-tl-symbol-value bsp *binding-stack-pointer*) + (loadw symbol bsp (- binding-symbol-slot binding-size)) + (loadw value bsp (- binding-value-slot binding-size)) + + (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag) + (inst fs-segment-prefix) + (inst mov (make-ea :dword :scale 1 :index tls-index) value) + + (storew 0 bsp (- binding-symbol-slot binding-size)) + (inst sub bsp (* binding-size n-word-bytes)) + ;; we're done with value, so we can use it as a temp here + (store-tl-symbol-value bsp *binding-stack-pointer* value))) + +#!-sb-thread (define-vop (unbind) (:temporary (:sc unsigned-reg) symbol value bsp) (:generator 0 @@ -200,11 +337,12 @@ (inst sub bsp (* binding-size n-word-bytes)) (store-symbol-value bsp *binding-stack-pointer*))) + (define-vop (unbind-to-here) (:args (where :scs (descriptor-reg any-reg))) - (:temporary (:sc unsigned-reg) symbol value bsp) + (:temporary (:sc unsigned-reg) symbol value bsp #!+sb-thread tls-index) (:generator 0 - (load-symbol-value bsp *binding-stack-pointer*) + (load-tl-symbol-value bsp *binding-stack-pointer*) (inst cmp where bsp) (inst jmp :e done) @@ -213,17 +351,25 @@ (inst or symbol symbol) (inst jmp :z skip) (loadw value bsp (- binding-value-slot binding-size)) - (storew value symbol symbol-value-slot other-pointer-lowtag) + #!-sb-thread (storew value symbol symbol-value-slot other-pointer-lowtag) + + #!+sb-thread (loadw + tls-index symbol symbol-tls-index-slot other-pointer-lowtag) + #!+sb-thread (inst fs-segment-prefix) + #!+sb-thread (inst mov (make-ea :dword :scale 1 :index tls-index) value) (storew 0 bsp (- binding-symbol-slot binding-size)) SKIP (inst sub bsp (* binding-size n-word-bytes)) (inst cmp where bsp) (inst jmp :ne loop) - (store-symbol-value bsp *binding-stack-pointer*) + ;; we're done with value, so can use it as a temporary + (store-tl-symbol-value bsp *binding-stack-pointer* value) DONE)) + + ;;;; closure indexing (define-full-reffer closure-index-ref * @@ -284,6 +430,32 @@ (define-full-setter instance-index-set * instance-slots-offset instance-pointer-lowtag (any-reg descriptor-reg) * %instance-set) + + +(defknown %instance-set-conditional (instance index t t) t + (unsafe)) + +(define-vop (instance-set-conditional) + (:translate %instance-set-conditional) + (:args (object :scs (descriptor-reg) :to :eval) + (slot :scs (any-reg) :to :result) + (old-value :scs (descriptor-reg any-reg) :target eax) + (new-value :scs (descriptor-reg any-reg))) + (:arg-types instance positive-fixnum * *) + (:temporary (:sc descriptor-reg :offset eax-offset + :from (:argument 2) :to :result :target result) eax) + (:results (result :scs (descriptor-reg any-reg))) + ;(:guard (backend-featurep :i486)) + (:policy :fast-safe) + (:generator 5 + (move eax old-value) + (inst cmpxchg (make-ea :dword :base object :index slot :scale 1 + :disp (- (* instance-slots-offset n-word-bytes) + instance-pointer-lowtag)) + new-value) + (move result eax))) + + ;;;; code object frobbing diff --git a/src/compiler/x86/macros.lisp b/src/compiler/x86/macros.lisp index 6fc2e5e..bedd274 100644 --- a/src/compiler/x86/macros.lisp +++ b/src/compiler/x86/macros.lisp @@ -84,7 +84,35 @@ (- other-pointer-lowtag))) ,reg)) +#!+sb-thread +(defmacro load-tl-symbol-value (reg symbol) + `(progn + (inst mov ,reg + (make-ea :dword + :disp (+ nil-value + (static-symbol-offset ',symbol) + (ash symbol-tls-index-slot word-shift) + (- other-pointer-lowtag)))) + (inst fs-segment-prefix) + (inst mov ,reg (make-ea :dword :scale 1 :index ,reg)))) +#!-sb-thread +(defmacro load-tl-symbol-value (reg symbol) `(load-symbol-value ,reg ,symbol)) +#!+sb-thread +(defmacro store-tl-symbol-value (reg symbol temp) + `(progn + (inst mov ,temp + (make-ea :dword + :disp (+ nil-value + (static-symbol-offset ',symbol) + (ash symbol-tls-index-slot word-shift) + (- other-pointer-lowtag)))) + (inst fs-segment-prefix) + (inst mov (make-ea :dword :scale 1 :index ,temp) ,reg))) +#!-sb-thread +(defmacro store-tl-symbol-value (reg symbol temp) + `(store-symbol-value ,reg ,symbol)) + (defmacro load-type (target source &optional (offset 0)) #!+sb-doc "Loads the type bits of a pointer into target independent of @@ -277,31 +305,53 @@ ;;; FIXME: It appears that PSEUDO-ATOMIC is used to wrap operations which leave ;;; untagged memory lying around, but some documentation would be nice. +#!+sb-thread +(defmacro pseudo-atomic (&rest forms) + (let ((label (gensym "LABEL-"))) + `(let ((,label (gen-label))) + (inst fs-segment-prefix) + (inst mov (make-ea :byte :disp (* 4 thread-pseudo-atomic-atomic-slot)) 1) + (inst fs-segment-prefix) + (inst mov (make-ea :byte + :disp (* 4 thread-pseudo-atomic-interrupted-slot)) 0) + ,@forms + (inst fs-segment-prefix) + (inst mov (make-ea :byte :disp (* 4 thread-pseudo-atomic-atomic-slot)) 0) + (inst fs-segment-prefix) + (inst cmp (make-ea :byte + :disp (* 4 thread-pseudo-atomic-interrupted-slot)) 0) + (inst jmp :eq ,label) + ;; if PAI was set, interrupts were disabled at the same time + ;; using the process signal mask. + (inst break pending-interrupt-trap) + (emit-label ,label)))) + +#!-sb-thread (defmacro pseudo-atomic (&rest forms) (let ((label (gensym "LABEL-"))) `(let ((,label (gen-label))) ;; FIXME: The MAKE-EA noise should become a MACROLET macro or ;; something. (perhaps SVLB, for static variable low byte) (inst mov (make-ea :byte :disp (+ nil-value - (static-symbol-offset - '*pseudo-atomic-interrupted*) - (ash symbol-value-slot word-shift) - ;; FIXME: Use mask, not minus, to - ;; take out type bits. - (- other-pointer-lowtag))) + (static-symbol-offset + '*pseudo-atomic-interrupted*) + (ash symbol-value-slot word-shift) + ;; FIXME: Use mask, not minus, to + ;; take out type bits. + (- other-pointer-lowtag))) 0) (inst mov (make-ea :byte :disp (+ nil-value - (static-symbol-offset - '*pseudo-atomic-atomic*) - (ash symbol-value-slot word-shift) - (- other-pointer-lowtag))) + (static-symbol-offset + '*pseudo-atomic-atomic*) + (ash symbol-value-slot word-shift) + (- other-pointer-lowtag))) (fixnumize 1)) ,@forms (inst mov (make-ea :byte :disp (+ nil-value - (static-symbol-offset - '*pseudo-atomic-atomic*) - (ash symbol-value-slot word-shift) - (- other-pointer-lowtag))) + (static-symbol-offset + '*pseudo-atomic-atomic*) + (ash symbol-value-slot word-shift) + (- other-pointer-lowtag))) 0) ;; KLUDGE: Is there any requirement for interrupts to be ;; handled in order? It seems as though an interrupt coming @@ -310,17 +360,19 @@ ;; are pending? I wish I could find the documentation for ;; pseudo-atomics.. -- WHN 19991130 (inst cmp (make-ea :byte - :disp (+ nil-value - (static-symbol-offset - '*pseudo-atomic-interrupted*) - (ash symbol-value-slot word-shift) - (- other-pointer-lowtag))) + :disp (+ nil-value + (static-symbol-offset + '*pseudo-atomic-interrupted*) + (ash symbol-value-slot word-shift) + (- other-pointer-lowtag))) 0) (inst jmp :eq ,label) ;; if PAI was set, interrupts were disabled at the same time ;; using the process signal mask. (inst break pending-interrupt-trap) (emit-label ,label)))) + + ;;;; indexed references diff --git a/src/compiler/x86/nlx.lisp b/src/compiler/x86/nlx.lisp index d220ffe..4f6c5a2 100644 --- a/src/compiler/x86/nlx.lisp +++ b/src/compiler/x86/nlx.lisp @@ -44,15 +44,16 @@ (:results (catch :scs (descriptor-reg)) (alien-stack :scs (descriptor-reg))) (:generator 13 - (load-symbol-value catch *current-catch-block*) - (load-symbol-value alien-stack *alien-stack*))) + (load-tl-symbol-value catch *current-catch-block*) + (load-tl-symbol-value alien-stack *alien-stack*))) (define-vop (restore-dynamic-state) (:args (catch :scs (descriptor-reg)) (alien-stack :scs (descriptor-reg))) + #!+sb-thread (:temporary (:sc unsigned-reg) temp) (:generator 10 - (store-symbol-value catch *current-catch-block*) - (store-symbol-value alien-stack *alien-stack*))) + (store-tl-symbol-value catch *current-catch-block* temp) + (store-tl-symbol-value alien-stack *alien-stack* temp))) (define-vop (current-stack-pointer) (:results (res :scs (any-reg control-stack))) @@ -62,7 +63,7 @@ (define-vop (current-binding-pointer) (:results (res :scs (any-reg descriptor-reg))) (:generator 1 - (load-symbol-value res *binding-stack-pointer*))) + (load-tl-symbol-value res *binding-stack-pointer*))) ;;;; unwind block hackery @@ -75,7 +76,7 @@ (:results (block :scs (any-reg))) (:generator 22 (inst lea block (catch-block-ea tn)) - (load-symbol-value temp *current-unwind-protect-block*) + (load-tl-symbol-value temp *current-unwind-protect-block*) (storew temp block unwind-block-current-uwp-slot) (storew ebp-tn block unwind-block-current-cont-slot) (storew (make-fixup nil :code-object entry-label) @@ -91,42 +92,42 @@ (:temporary (:sc descriptor-reg) temp) (:generator 44 (inst lea block (catch-block-ea tn)) - (load-symbol-value temp *current-unwind-protect-block*) + (load-tl-symbol-value temp *current-unwind-protect-block*) (storew temp block unwind-block-current-uwp-slot) (storew ebp-tn block unwind-block-current-cont-slot) (storew (make-fixup nil :code-object entry-label) block catch-block-entry-pc-slot) (storew tag block catch-block-tag-slot) - (load-symbol-value temp *current-catch-block*) + (load-tl-symbol-value temp *current-catch-block*) (storew temp block catch-block-previous-catch-slot) - (store-symbol-value block *current-catch-block*))) + (store-tl-symbol-value block *current-catch-block* temp))) ;;; Just set the current unwind-protect to TN's address. This instantiates an ;;; unwind block as an unwind-protect. (define-vop (set-unwind-protect) (:args (tn)) - (:temporary (:sc unsigned-reg) new-uwp) + (:temporary (:sc unsigned-reg) new-uwp #!+sb-thread tls) (:generator 7 (inst lea new-uwp (catch-block-ea tn)) - (store-symbol-value new-uwp *current-unwind-protect-block*))) + (store-tl-symbol-value new-uwp *current-unwind-protect-block* tls))) (define-vop (unlink-catch-block) - (:temporary (:sc unsigned-reg) block) + (:temporary (:sc unsigned-reg) #!+sb-thread tls block) (:policy :fast-safe) (:translate %catch-breakup) (:generator 17 - (load-symbol-value block *current-catch-block*) + (load-tl-symbol-value block *current-catch-block*) (loadw block block catch-block-previous-catch-slot) - (store-symbol-value block *current-catch-block*))) + (store-tl-symbol-value block *current-catch-block* tls))) (define-vop (unlink-unwind-protect) - (:temporary (:sc unsigned-reg) block) + (:temporary (:sc unsigned-reg) block #!+sb-thread tls) (:policy :fast-safe) (:translate %unwind-protect-breakup) (:generator 17 - (load-symbol-value block *current-unwind-protect-block*) + (load-tl-symbol-value block *current-unwind-protect-block*) (loadw block block unwind-block-current-uwp-slot) - (store-symbol-value block *current-unwind-protect-block*))) + (store-tl-symbol-value block *current-unwind-protect-block* tls))) ;;;; NLX entry VOPs (define-vop (nlx-entry) diff --git a/src/compiler/x86/parms.lisp b/src/compiler/x86/parms.lisp index 63d7d5c..8e3ee8f 100644 --- a/src/compiler/x86/parms.lisp +++ b/src/compiler/x86/parms.lisp @@ -144,11 +144,6 @@ (def!constant dynamic-space-start #x09000000) (def!constant dynamic-space-end #x29000000) - (def!constant control-stack-start #x50000000) - (def!constant control-stack-end #x57fff000) - - (def!constant binding-stack-start #x60000000) - (def!constant binding-stack-end #x67fff000) (def!constant alternate-signal-stack-start #x58000000)) #!+bsd @@ -162,15 +157,6 @@ #!+openbsd #x28000000) (def!constant static-space-end #x37fff000) - (def!constant binding-stack-start #x38000000) - (def!constant binding-stack-end #x3ffff000) - - (def!constant control-stack-start - #!+freebsd #x40000000 - #!+openbsd #x48000000) - (def!constant control-stack-end - #!+freebsd #x43fff000 - #!+openbsd #x4bfff000) (def!constant dynamic-space-start #!+freebsd #x48000000 #!+openbsd #x50000000) @@ -268,8 +254,13 @@ sb!unix::*interrupt-pending* *free-interrupt-context-index* + *free-tls-index* + sb!thread::*foreground-thread-stack* + *allocation-pointer* *binding-stack-pointer* + *binding-stack-start* + *control-stack-start* ;; the floating point constants *fp-constant-0d0* diff --git a/src/compiler/x86/system.lisp b/src/compiler/x86/system.lisp index 2bbfa62..803c580 100644 --- a/src/compiler/x86/system.lisp +++ b/src/compiler/x86/system.lisp @@ -163,7 +163,7 @@ (:translate binding-stack-pointer-sap) (:policy :fast-safe) (:generator 1 - (load-symbol-value int *binding-stack-pointer*))) + (load-tl-symbol-value int *binding-stack-pointer*))) (defknown (setf binding-stack-pointer-sap) (system-area-pointer) system-area-pointer ()) @@ -173,10 +173,11 @@ (:arg-types system-area-pointer) (:results (int :scs (sap-reg))) (:result-types system-area-pointer) + #!+sb-thread (:temporary (:sc any-reg) temp) (:translate (setf binding-stack-pointer-sap)) (:policy :fast-safe) (:generator 1 - (store-symbol-value new-value *binding-stack-pointer*) + (store-tl-symbol-value new-value *binding-stack-pointer* temp) (move int new-value))) (define-vop (control-stack-pointer-sap) @@ -273,6 +274,26 @@ (:generator 1 (inst break pending-interrupt-trap))) +(defknown current-thread-offset-sap ((unsigned-byte 32)) + system-area-pointer (flushable)) + +(define-vop (current-thread-offset-sap) + (:results (sap :scs (sap-reg))) + (:result-types system-area-pointer) + (:translate current-thread-offset-sap) + (:args (n :scs (unsigned-reg) #!+sb-thread :target #!+sb-thread sap)) + #!-sb-thread (:temporary (:sc unsigned-reg :target sap) temp) + (:arg-types unsigned-num) + (:policy :fast-safe) + #!+sb-thread + (:generator 2 + (inst fs-segment-prefix) + (inst mov sap (make-ea :dword :disp 0 :index n :scale 4))) + #!-sb-thread + (:generator 2 + (inst mov temp (make-fixup (extern-alien-name "all_threads") :foreign)) + (inst mov sap (make-ea :dword :base temp :index n :scale 4)))) + (define-vop (halt) (:generator 1 (inst break halt-trap))) diff --git a/src/runtime/GNUmakefile b/src/runtime/GNUmakefile index 28e6121..8545e9e 100644 --- a/src/runtime/GNUmakefile +++ b/src/runtime/GNUmakefile @@ -39,7 +39,7 @@ C_SRCS =alloc.c backtrace.c breakpoint.c coreparse.c \ dynbind.c gc-common.c globals.c interr.c interrupt.c \ monitor.c parse.c print.c purify.c \ regnames.c run-program.c runtime.c save.c search.c \ - time.c util.c validate.c vars.c wrap.c + thread.c time.c util.c validate.c vars.c wrap.c SRCS= $(C_SRCS) ${ARCH_SRC} ${ASSEM_SRC} ${OS_SRC} ${GC_SRC} diff --git a/src/runtime/alloc.c b/src/runtime/alloc.c index 01354b4..121a40b 100644 --- a/src/runtime/alloc.c +++ b/src/runtime/alloc.c @@ -23,12 +23,11 @@ #include "alloc.h" #include "globals.h" #include "gc.h" -#include "genesis/static-symbols.h" +#include "thread.h" #include "genesis/vector.h" #include "genesis/cons.h" #include "genesis/bignum.h" #include "genesis/sap.h" -#include "genesis/symbol.h" #define GET_FREE_POINTER() dynamic_space_free_pointer #define SET_FREE_POINTER(new_value) \ @@ -45,11 +44,12 @@ lispobj * pa_alloc(int bytes) { lispobj *result=0; - SetSymbolValue(PSEUDO_ATOMIC_INTERRUPTED, make_fixnum(0)); - SetSymbolValue(PSEUDO_ATOMIC_ATOMIC, make_fixnum(1)); + struct thread *th=arch_os_get_current_thread(); + SetSymbolValue(PSEUDO_ATOMIC_INTERRUPTED, make_fixnum(0),th); + SetSymbolValue(PSEUDO_ATOMIC_ATOMIC, make_fixnum(1),th); result=alloc(bytes); - SetSymbolValue(PSEUDO_ATOMIC_ATOMIC, make_fixnum(0)); - if (SymbolValue(PSEUDO_ATOMIC_INTERRUPTED)) + SetSymbolValue(PSEUDO_ATOMIC_ATOMIC, make_fixnum(0),th); + if (SymbolValue(PSEUDO_ATOMIC_INTERRUPTED,th)) /* even if we gc at this point, the new allocation will be * protected from being moved, because result is on the c stack * and points to it */ diff --git a/src/runtime/backtrace.c b/src/runtime/backtrace.c index 12f954f..a4cbc11 100644 --- a/src/runtime/backtrace.c +++ b/src/runtime/backtrace.c @@ -21,6 +21,9 @@ #include "os.h" #include "interrupt.h" #include "lispregs.h" +#ifdef LISP_FEATURE_GENCGC +#include "gencgc-alloc-region.h" +#endif #include "genesis/static-symbols.h" #include "genesis/primitive-objects.h" @@ -148,6 +151,7 @@ static int previous_info(struct call_info *info) { struct call_frame *this_frame; + struct thread *thread=arch_os_get_current_thread(); int free; if (!cs_valid_pointer_p(info->frame)) { @@ -165,10 +169,10 @@ previous_info(struct call_info *info) if (info->lra == NIL) { /* We were interrupted. Find the correct signal context. */ - free = SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX)>>2; + free = SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX,thread)>>2; while (free-- > 0) { os_context_t *context = - lisp_interrupt_contexts[free]; + thread->interrupt_contexts[free]; if ((struct call_frame *)(*os_context_register_addr(context, reg_CFP)) == info->frame) { diff --git a/src/runtime/breakpoint.c b/src/runtime/breakpoint.c index 716bc21..5ff8509 100644 --- a/src/runtime/breakpoint.c +++ b/src/runtime/breakpoint.c @@ -21,10 +21,9 @@ #include "globals.h" #include "alloc.h" #include "breakpoint.h" +#include "thread.h" #include "genesis/code.h" #include "genesis/fdefn.h" -#include "genesis/symbol.h" -#include "genesis/static-symbols.h" #define REAL_LRA_SLOT 0 #ifndef __i386__ diff --git a/src/runtime/coreparse.c b/src/runtime/coreparse.c index 2d03737..65fdc12 100644 --- a/src/runtime/coreparse.c +++ b/src/runtime/coreparse.c @@ -33,8 +33,7 @@ #include "arch.h" #include "interr.h" #include "sbcl.h" -#include "genesis/symbol.h" -#include "genesis/static-symbols.h" +#include "thread.h" unsigned char build_id[] = #include "../../output/build-id.tmp" @@ -94,7 +93,7 @@ process_directory(int fd, u32 *ptr, int count) * defined(__i386__) * ? */ #if defined(LISP_FEATURE_X86) - SetSymbolValue(ALLOCATION_POINTER, (lispobj)free_pointer); + SetSymbolValue(ALLOCATION_POINTER, (lispobj)free_pointer,0); #else dynamic_space_free_pointer = free_pointer; #endif diff --git a/src/runtime/dynbind.c b/src/runtime/dynbind.c index 93bdeb7..5f26c2a 100644 --- a/src/runtime/dynbind.c +++ b/src/runtime/dynbind.c @@ -17,35 +17,44 @@ #include "sbcl.h" #include "globals.h" #include "dynbind.h" +#include "thread.h" #include "genesis/symbol.h" #include "genesis/binding.h" -#include "genesis/static-symbols.h" +#include "genesis/thread.h" #if defined(__i386__) -#define GetBSP() ((struct binding *)SymbolValue(BINDING_STACK_POINTER)) -#define SetBSP(value) SetSymbolValue(BINDING_STACK_POINTER, (lispobj)(value)) +#define GetBSP() ((struct binding *)SymbolValue(BINDING_STACK_POINTER,thread)) +#define SetBSP(value) SetSymbolValue(BINDING_STACK_POINTER, (lispobj)(value),thread) #else #define GetBSP() ((struct binding *)current_binding_stack_pointer) #define SetBSP(value) (current_binding_stack_pointer=(lispobj *)(value)) #endif -void bind_variable(lispobj symbol, lispobj value) +void bind_variable(lispobj symbol, lispobj value, void *th) { - lispobj old_value; + lispobj old_tl_value; struct binding *binding; - - old_value = SymbolValue(symbol); + struct thread *thread=(struct thread *)th; + struct symbol *sym=(struct symbol *)native_pointer(symbol); binding = GetBSP(); SetBSP(binding+1); - - binding->value = old_value; +#ifdef LISP_FEATURE_SB_THREAD + if(!sym->tls_index) { + sym->tls_index=SymbolValue(FREE_TLS_INDEX,0); + SetSymbolValue(FREE_TLS_INDEX, + make_fixnum(fixnum_value(sym->tls_index)+1),0); + } +#endif + old_tl_value=SymbolTlValue(symbol,thread); + binding->value = old_tl_value; binding->symbol = symbol; - SetSymbolValue(symbol, value); + SetTlSymbolValue(symbol, value,thread); } void -unbind(void) +unbind(void *th) { + struct thread *thread=(struct thread *)th; struct binding *binding; lispobj symbol; @@ -53,7 +62,7 @@ unbind(void) symbol = binding->symbol; - SetSymbolValue(symbol, binding->value); + SetTlSymbolValue(symbol, binding->value,thread); binding->symbol = 0; @@ -61,8 +70,9 @@ unbind(void) } void -unbind_to_here(lispobj *bsp) +unbind_to_here(lispobj *bsp,void *th) { + struct thread *thread=(struct thread *)th; struct binding *target = (struct binding *)bsp; struct binding *binding = GetBSP(); lispobj symbol; @@ -71,12 +81,10 @@ unbind_to_here(lispobj *bsp) binding--; symbol = binding->symbol; - if (symbol) { - SetSymbolValue(symbol, binding->value); + SetTlSymbolValue(symbol, binding->value,thread); binding->symbol = 0; } - } SetBSP(binding); } diff --git a/src/runtime/dynbind.h b/src/runtime/dynbind.h index 010dbc1..41aa9eb 100644 --- a/src/runtime/dynbind.h +++ b/src/runtime/dynbind.h @@ -12,8 +12,8 @@ #ifndef _DYNBIND_H_ #define _DYNBIND_H_ -extern void bind_variable(lispobj symbol, lispobj value); -extern void unbind(void); -extern void unbind_to_here(lispobj *bsp); +extern void bind_variable(lispobj symbol, lispobj value,void *thread); +extern void unbind(void *thread); +extern void unbind_to_here(lispobj *bsp,void *thread); #endif diff --git a/src/runtime/gc.h b/src/runtime/gc.h index 3dc12ec..c0a1eeb 100644 --- a/src/runtime/gc.h +++ b/src/runtime/gc.h @@ -25,5 +25,6 @@ extern void collect_garbage(unsigned last_gen); extern void set_auto_gc_trigger(os_vm_size_t usage); extern void clear_auto_gc_trigger(void); -extern boolean maybe_gc_pending; +extern int maybe_gc_pending; +extern int gc_thread_pid; #endif /* _GC_H_ */ diff --git a/src/runtime/gencgc.c b/src/runtime/gencgc.c index aec65cd..3c5e7e7 100644 --- a/src/runtime/gencgc.c +++ b/src/runtime/gencgc.c @@ -38,11 +38,10 @@ #include "arch.h" #include "gc.h" #include "gc-internal.h" +#include "thread.h" #include "genesis/vector.h" #include "genesis/weak-pointer.h" #include "genesis/simple-fun.h" -#include "genesis/static-symbols.h" -#include "genesis/symbol.h" /* assembly language stub that executes trap_PendingInterrupt */ void do_pending_interrupt(void); @@ -247,6 +246,13 @@ unsigned int gencgc_oldest_gen_to_gc = NUM_GENERATIONS-1; * integrated with the Lisp code. */ static int last_free_page; +/* This lock is to prevent multiple threads from simultaneously + * allocating new regions which overlap each other. Note that the + * majority of GC is single-threaded, but alloc() may be called + * from >1 thread at a time and must be thread-safe */ +static lispobj free_pages_lock=0; + + /* * miscellaneous heap functions */ @@ -490,7 +496,7 @@ gc_alloc_new_region(int nbytes, int unboxed, struct alloc_region *alloc_region) gc_assert((alloc_region->first_page == 0) && (alloc_region->last_page == -1) && (alloc_region->free_pointer == alloc_region->end_addr)); - + get_spinlock(&free_pages_lock,alloc_region); if (unboxed) { first_page = generations[gc_alloc_generation].alloc_unboxed_start_page; @@ -510,20 +516,6 @@ gc_alloc_new_region(int nbytes, int unboxed, struct alloc_region *alloc_region) alloc_region->free_pointer = alloc_region->start_addr; alloc_region->end_addr = alloc_region->start_addr + bytes_found; - if (gencgc_zero_check) { - int *p; - for (p = (int *)alloc_region->start_addr; - p < (int *)alloc_region->end_addr; p++) { - if (*p != 0) { - /* KLUDGE: It would be nice to use %lx and explicit casts - * (long) in code like this, so that it is less likely to - * break randomly when running on a machine with different - * word sizes. -- WHN 19991129 */ - lose("The new region at %x is not zero.", p); - } - } - } - /* Set up the pages. */ /* The first page may have already been in use. */ @@ -559,15 +551,32 @@ gc_alloc_new_region(int nbytes, int unboxed, struct alloc_region *alloc_region) alloc_region->start_addr - page_address(i); page_table[i].allocated |= OPEN_REGION_PAGE ; } - /* Bump up last_free_page. */ if (last_page+1 > last_free_page) { last_free_page = last_page+1; SetSymbolValue(ALLOCATION_POINTER, - (lispobj)(((char *)heap_base) + last_free_page*4096)); + (lispobj)(((char *)heap_base) + last_free_page*4096), + 0); + } + free_pages_lock=0; + + /* we can do this after releasing free_pages_lock */ + if (gencgc_zero_check) { + int *p; + for (p = (int *)alloc_region->start_addr; + p < (int *)alloc_region->end_addr; p++) { + if (*p != 0) { + /* KLUDGE: It would be nice to use %lx and explicit casts + * (long) in code like this, so that it is less likely to + * break randomly when running on a machine with different + * word sizes. -- WHN 19991129 */ + lose("The new region at %x is not zero.", p); + } } } +} + /* If the record_new_objects flag is 2 then all new regions created * are recorded. * @@ -836,6 +845,8 @@ gc_alloc_large(int nbytes, int unboxed, struct alloc_region *alloc_region) index ahead of the current region and bumped up here to save a lot of re-scanning. */ + get_spinlock(&free_pages_lock,alloc_region); + if (unboxed) { first_page = generations[gc_alloc_generation].alloc_large_unboxed_start_page; @@ -932,8 +943,9 @@ gc_alloc_large(int nbytes, int unboxed, struct alloc_region *alloc_region) if (last_page+1 > last_free_page) { last_free_page = last_page+1; SetSymbolValue(ALLOCATION_POINTER, - (lispobj)(((char *)heap_base) + last_free_page*4096)); + (lispobj)(((char *)heap_base) + last_free_page*4096),0); } + free_pages_lock=0; return((void *)(page_address(first_page)+orig_first_page_bytes_used)); } @@ -951,6 +963,7 @@ gc_find_freeish_pages(int *restart_page_ptr, int nbytes, int unboxed, struct all int num_pages; int large = !alloc_region && (nbytes >= large_object_size); + gc_assert(free_pages_lock); /* Search for a contiguous free space of at least nbytes. If it's a large object then align it on a page boundary by searching for a free page. */ @@ -2088,7 +2101,7 @@ static lispobj* search_read_only_space(lispobj *pointer) { lispobj* start = (lispobj*)READ_ONLY_SPACE_START; - lispobj* end = (lispobj*)SymbolValue(READ_ONLY_SPACE_FREE_POINTER); + lispobj* end = (lispobj*)SymbolValue(READ_ONLY_SPACE_FREE_POINTER,0); if ((pointer < start) || (pointer >= end)) return NULL; return (search_space(start, (pointer+2)-start, pointer)); @@ -2098,7 +2111,7 @@ static lispobj * search_static_space(lispobj *pointer) { lispobj* start = (lispobj*)STATIC_SPACE_START; - lispobj* end = (lispobj*)SymbolValue(STATIC_SPACE_FREE_POINTER); + lispobj* end = (lispobj*)SymbolValue(STATIC_SPACE_FREE_POINTER,0); if ((pointer < start) || (pointer >= end)) return NULL; return (search_space(start, (pointer+2)-start, pointer)); @@ -2163,7 +2176,10 @@ possibly_valid_dynamic_space_pointer(lispobj *pointer) * (2) Perhaps find some other hack to protect against this, e.g. * recording the result of the last call to allocate-lisp-memory, * and returning true from this function when *pointer is - * a reference to that result. */ + * a reference to that result. + * + * (surely pseudo-atomic is supposed to be used for exactly this?) + */ switch (lowtag_of((lispobj)pointer)) { case FUN_POINTER_LOWTAG: /* Start_addr should be the enclosing code object, or a closure @@ -3231,7 +3247,7 @@ verify_space(lispobj *start, size_t words) int is_in_dynamic_space = (find_page_index((void*)start) != -1); int is_in_readonly_space = (READ_ONLY_SPACE_START <= (unsigned)start && - (unsigned)start < SymbolValue(READ_ONLY_SPACE_FREE_POINTER)); + (unsigned)start < SymbolValue(READ_ONLY_SPACE_FREE_POINTER,0)); while (words > 0) { size_t count = 1; @@ -3241,10 +3257,10 @@ verify_space(lispobj *start, size_t words) int page_index = find_page_index((void*)thing); int to_readonly_space = (READ_ONLY_SPACE_START <= thing && - thing < SymbolValue(READ_ONLY_SPACE_FREE_POINTER)); + thing < SymbolValue(READ_ONLY_SPACE_FREE_POINTER,0)); int to_static_space = (STATIC_SPACE_START <= thing && - thing < SymbolValue(STATIC_SPACE_FREE_POINTER)); + thing < SymbolValue(STATIC_SPACE_FREE_POINTER,0)); /* Does it point to the dynamic space? */ if (page_index != -1) { @@ -3439,18 +3455,20 @@ verify_gc(void) * to grep for all foo_size and rename the appropriate ones to * foo_count. */ int read_only_space_size = - (lispobj*)SymbolValue(READ_ONLY_SPACE_FREE_POINTER) + (lispobj*)SymbolValue(READ_ONLY_SPACE_FREE_POINTER,0) - (lispobj*)READ_ONLY_SPACE_START; int static_space_size = - (lispobj*)SymbolValue(STATIC_SPACE_FREE_POINTER) + (lispobj*)SymbolValue(STATIC_SPACE_FREE_POINTER,0) - (lispobj*)STATIC_SPACE_START; + struct thread *th; + for_each_thread(th) { int binding_stack_size = - (lispobj*)SymbolValue(BINDING_STACK_POINTER) - - (lispobj*)BINDING_STACK_START; - + (lispobj*)SymbolValue(BINDING_STACK_POINTER,th) + - (lispobj*)th->binding_stack_start; + verify_space(th->binding_stack_start, binding_stack_size); + } verify_space((lispobj*)READ_ONLY_SPACE_START, read_only_space_size); verify_space((lispobj*)STATIC_SPACE_START , static_space_size); - verify_space((lispobj*)BINDING_STACK_START , binding_stack_size); } static void @@ -3588,7 +3606,7 @@ garbage_collect_generation(int generation, int raise) unsigned long bytes_freed; unsigned long i; unsigned long static_space_size; - + struct thread *th; gc_assert(generation <= (NUM_GENERATIONS-1)); /* The oldest generation can't be raised. */ @@ -3630,11 +3648,33 @@ garbage_collect_generation(int generation, int raise) * be un-protected anyway before unmapping later. */ unprotect_oldspace(); - /* Scavenge the stack's conservative roots. */ - { + /* Scavenge the stacks' conservative roots. */ + for_each_thread(th) { void **ptr; - for (ptr = (void **)CONTROL_STACK_END - 1; +#ifdef LISP_FEATURE_SB_THREAD + struct user_regs_struct regs; + if(ptrace(PTRACE_GETREGS,th->pid,0,®s)){ + /* probably doesn't exist any more. */ + fprintf(stderr,"child pid %d, %s\n",th->pid,strerror(errno)); + perror("PTRACE_GETREGS"); + } + preserve_pointer(regs.ebx); + preserve_pointer(regs.ecx); + preserve_pointer(regs.edx); + preserve_pointer(regs.esi); + preserve_pointer(regs.edi); + preserve_pointer(regs.ebp); + preserve_pointer(regs.eax); +#endif + for (ptr = ((void **) + ((void *)th->control_stack_start + + THREAD_CONTROL_STACK_SIZE) + -1); +#ifdef LISP_FEATURE_SB_THREAD + ptr > regs.esp; +#else ptr > (void **)&raise; +#endif ptr--) { preserve_pointer(*ptr); } @@ -3656,18 +3696,31 @@ garbage_collect_generation(int generation, int raise) /* Scavenge the Lisp functions of the interrupt handlers, taking * care to avoid SIG_DFL and SIG_IGN. */ + for_each_thread(th) { + struct interrupt_data *data=th->interrupt_data; for (i = 0; i < NSIG; i++) { - union interrupt_handler handler = interrupt_handlers[i]; + union interrupt_handler handler = data->interrupt_handlers[i]; if (!ARE_SAME_HANDLER(handler.c, SIG_IGN) && !ARE_SAME_HANDLER(handler.c, SIG_DFL)) { - scavenge((lispobj *)(interrupt_handlers + i), 1); + scavenge((lispobj *)(data->interrupt_handlers + i), 1); + } + } + } + /* Scavenge the binding stacks. */ + { + struct thread *th; + for_each_thread(th) { + long len= (lispobj *)SymbolValue(BINDING_STACK_POINTER,th) - + th->binding_stack_start; + scavenge((lispobj *) th->binding_stack_start,len); +#ifdef LISP_FEATURE_SB_THREAD + /* do the tls as well */ + len=fixnum_value(SymbolValue(FREE_TLS_INDEX,0)) - + (sizeof (struct thread))/(sizeof (lispobj)); + scavenge((lispobj *) (th+1),len); +#endif } } - - /* Scavenge the binding stack. */ - scavenge((lispobj *) BINDING_STACK_START, - (lispobj *)SymbolValue(BINDING_STACK_POINTER) - - (lispobj *)BINDING_STACK_START); /* The original CMU CL code had scavenge-read-only-space code * controlled by the Lisp-level variable @@ -3690,7 +3743,7 @@ garbage_collect_generation(int generation, int raise) /* Scavenge static space. */ static_space_size = - (lispobj *)SymbolValue(STATIC_SPACE_FREE_POINTER) - + (lispobj *)SymbolValue(STATIC_SPACE_FREE_POINTER,0) - (lispobj *)STATIC_SPACE_START; if (gencgc_verbose > 1) { FSHOW((stderr, @@ -3801,7 +3854,7 @@ update_x86_dynamic_space_free_pointer(void) last_free_page = last_page+1; SetSymbolValue(ALLOCATION_POINTER, - (lispobj)(((char *)heap_base) + last_free_page*4096)); + (lispobj)(((char *)heap_base) + last_free_page*4096),0); return 0; /* dummy value: return something ... */ } @@ -4005,7 +4058,7 @@ gc_free_heap(void) gc_set_region_empty(&unboxed_region); last_free_page = 0; - SetSymbolValue(ALLOCATION_POINTER, (lispobj)((char *)heap_base)); + SetSymbolValue(ALLOCATION_POINTER, (lispobj)((char *)heap_base),0); if (verify_after_free_heap) { /* Check whether purify has left any bad pointers. */ @@ -4076,7 +4129,7 @@ gencgc_pickup_dynamic(void) { int page = 0; int addr = DYNAMIC_SPACE_START; - int alloc_ptr = SymbolValue(ALLOCATION_POINTER); + int alloc_ptr = SymbolValue(ALLOCATION_POINTER,0); /* Initialize the first region. */ do { @@ -4120,18 +4173,20 @@ extern boolean maybe_gc_pending ; char * alloc(int nbytes) { - struct alloc_region *region= &boxed_region; + struct thread *th=arch_os_get_current_thread(); + struct alloc_region *region= + th ? &(th->alloc_region) : &boxed_region; void *new_obj; void *new_free_pointer; /* Check for alignment allocation problems. */ gc_assert((((unsigned)region->free_pointer & 0x7) == 0) && ((nbytes & 0x7) == 0)); - /* At this point we should either be in pseudo-atomic, or early - * enough in cold initn that interrupts are not yet enabled anyway. - * It would be nice to assert same. - */ - gc_assert(SymbolValue(PSEUDO_ATOMIC_ATOMIC)); + if(all_threads) + /* there are a few places in the C code that allocate data in the + * heap before Lisp starts. This is before interrupts are enabled, + * so we don't need to check for pseudo-atomic */ + gc_assert(SymbolValue(PSEUDO_ATOMIC_ATOMIC,th)); /* maybe we can do this quickly ... */ new_free_pointer = region->free_pointer + nbytes; @@ -4149,7 +4204,7 @@ alloc(int nbytes) /* set things up so that GC happens when we finish the PA * section. */ maybe_gc_pending=1; - SetSymbolValue(PSEUDO_ATOMIC_INTERRUPTED, make_fixnum(1)); + SetSymbolValue(PSEUDO_ATOMIC_INTERRUPTED, make_fixnum(1),th); } new_obj = gc_alloc_with_region(nbytes,0,region,0); return (new_obj); @@ -4260,6 +4315,9 @@ unhandled_sigmemoryfault() gc_alloc_update_all_page_tables(void) { /* Flush the alloc regions updating the tables. */ + struct thread *th; + for_each_thread(th) + gc_alloc_update_page_tables(0, &th->alloc_region); gc_alloc_update_page_tables(1, &unboxed_region); gc_alloc_update_page_tables(0, &boxed_region); } diff --git a/src/runtime/gencgc.h b/src/runtime/gencgc.h index 4ec36c0..d9d4804 100644 --- a/src/runtime/gencgc.h +++ b/src/runtime/gencgc.h @@ -16,6 +16,8 @@ #ifndef _GENCGC_H_ #define _GENCGC_H_ +#include "genesis/code.h" + void gc_free_heap(void); inline int find_page_index(void *); inline void *page_address(int); @@ -81,22 +83,6 @@ struct page { #define NUM_PAGES ((DYNAMIC_SPACE_SIZE+4095)/4096) extern struct page page_table[NUM_PAGES]; -/* Abstract out the data for an allocation region allowing a single - * routine to be used for allocation and closing. */ -struct alloc_region { - - /* These two are needed for quick allocation. */ - void *free_pointer; - void *end_addr; /* pointer to the byte after the last usable byte */ - - /* These are needed when closing the region. */ - int first_page; - int last_page; - void *start_addr; -}; - -extern struct alloc_region boxed_region; -extern struct alloc_region unboxed_region; void gencgc_pickup_dynamic(void); @@ -105,5 +91,6 @@ void sniff_code_object(struct code *code, unsigned displacement); int update_x86_dynamic_space_free_pointer(void); void gc_alloc_update_page_tables(int unboxed, struct alloc_region *alloc_region); - +void gc_alloc_update_all_page_tables(void); +void gc_set_region_empty(struct alloc_region *region); #endif _GENCGC_H_ diff --git a/src/runtime/globals.c b/src/runtime/globals.c index 6152e25..b55aecd 100644 --- a/src/runtime/globals.c +++ b/src/runtime/globals.c @@ -59,16 +59,7 @@ void globals_init(void) /* Set foreign function call active. */ foreign_function_call_active = 1; - - /* Initialize the current Lisp state. */ -#ifdef LISP_FEATURE_STACK_GROWS_DOWNWARD_NOT_UPWARD - current_control_stack_pointer = (lispobj *)CONTROL_STACK_END; -#else - current_control_stack_pointer = (lispobj *)CONTROL_STACK_START; -#endif - - current_control_frame_pointer = (lispobj *)0; -#ifndef BINDING_STACK_POINTER - current_binding_stack_pointer = native_pointer(BINDING_STACK_START); +#ifdef LISP_FEATURE_SB_THREAD + parent_pid=getpid(); #endif } diff --git a/src/runtime/globals.h b/src/runtime/globals.h index c9e8c85..baff01a 100644 --- a/src/runtime/globals.h +++ b/src/runtime/globals.h @@ -14,9 +14,12 @@ #ifndef LANGUAGE_ASSEMBLY +#include +#include #include "runtime.h" extern int foreign_function_call_active; +extern boolean stop_the_world; extern lispobj *current_control_stack_pointer; extern lispobj *current_control_frame_pointer; @@ -31,6 +34,7 @@ extern lispobj *current_auto_gc_trigger; #endif extern lispobj *current_dynamic_space; +extern pid_t parent_pid; extern void globals_init(void); diff --git a/src/runtime/interrupt.c b/src/runtime/interrupt.c index 4027b3d..c630831 100644 --- a/src/runtime/interrupt.c +++ b/src/runtime/interrupt.c @@ -31,10 +31,8 @@ #include "alloc.h" #include "dynbind.h" #include "interr.h" -#include "genesis/simple-fun.h" #include "genesis/fdefn.h" -#include "genesis/symbol.h" -#include "genesis/static-symbols.h" +#include "genesis/simple-fun.h" void sigaddset_blockable(sigset_t *s) { @@ -64,7 +62,7 @@ void sigaddset_blockable(sigset_t *s) * becomes 'yes'.) */ boolean internal_errors_enabled = 0; -os_context_t *lisp_interrupt_contexts[MAX_INTERRUPTS]; +struct interrupt_data * global_interrupt_data; /* As far as I can tell, what's going on here is: * @@ -93,16 +91,6 @@ os_context_t *lisp_interrupt_contexts[MAX_INTERRUPTS]; * - WHN 20000728, dan 20010128 */ -void (*interrupt_low_level_handlers[NSIG]) (int, siginfo_t*, void*) = {0}; -union interrupt_handler interrupt_handlers[NSIG]; - -/* signal number, siginfo_t, and old mask information for pending signal - * - * pending_signal=0 when there is no pending signal. */ -static int pending_signal = 0; -static siginfo_t pending_info; -static sigset_t pending_mask; - boolean maybe_gc_pending = 0; /* @@ -110,7 +98,7 @@ boolean maybe_gc_pending = 0; */ void -build_fake_control_stack_frames(os_context_t *context) +build_fake_control_stack_frames(struct thread *th,os_context_t *context) { #ifndef LISP_FEATURE_X86 @@ -164,6 +152,7 @@ void fake_foreign_function_call(os_context_t *context) { int context_index; + struct thread *thread=arch_os_get_current_thread(); /* Get current Lisp state from context. */ #ifdef reg_ALLOC @@ -180,24 +169,21 @@ fake_foreign_function_call(os_context_t *context) (lispobj *)(*os_context_register_addr(context, reg_BSP)); #endif - build_fake_control_stack_frames(context); + build_fake_control_stack_frames(thread,context); /* Do dynamic binding of the active interrupt context index * and save the context in the context array. */ - context_index = SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX)>>2; - /* FIXME: Ick! Why use abstract "make_fixnum" in some places if - * you're going to convert from fixnum by bare >>2 in other - * places? Use fixnum_value(..) here, and look for other places - * which do bare >> and << for fixnum_value and make_fixnum. */ - + context_index = + fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX,thread)); + if (context_index >= MAX_INTERRUPTS) { lose("maximum interrupt nesting depth (%d) exceeded", MAX_INTERRUPTS); } bind_variable(FREE_INTERRUPT_CONTEXT_INDEX, - make_fixnum(context_index + 1)); + make_fixnum(context_index + 1),thread); - lisp_interrupt_contexts[context_index] = context; + thread->interrupt_contexts[context_index] = context; /* no longer in Lisp now */ foreign_function_call_active = 1; @@ -206,6 +192,7 @@ fake_foreign_function_call(os_context_t *context) void undo_fake_foreign_function_call(os_context_t *context) { + struct thread *thread=arch_os_get_current_thread(); /* Block all blockable signals. */ sigset_t block; sigemptyset(&block); @@ -222,7 +209,7 @@ undo_fake_foreign_function_call(os_context_t *context) * perhaps yes, unbind_to_here() really would be clearer and less * fragile.. */ /* dan (2001.08.10) thinks the above supposition is probably correct */ - unbind(); + unbind(thread); #ifdef reg_ALLOC /* Put the dynamic space free pointer back into the context. */ @@ -281,14 +268,20 @@ interrupt_internal_error(int signal, siginfo_t *info, os_context_t *context, void interrupt_handle_pending(os_context_t *context) { + struct thread *thread; + struct interrupt_data *data; + #ifndef __i386__ boolean were_in_lisp = !foreign_function_call_active; #endif - - SetSymbolValue(INTERRUPT_PENDING, NIL); +#ifdef LISP_FEATURE_SB_THREAD + while(stop_the_world) kill(getpid(),SIGSTOP); +#endif + thread=arch_os_get_current_thread(); + data=thread->interrupt_data; + SetSymbolValue(INTERRUPT_PENDING, NIL,thread); if (maybe_gc_pending) { - maybe_gc_pending = 0; #ifndef __i386__ if (were_in_lisp) #endif @@ -332,12 +325,12 @@ interrupt_handle_pending(os_context_t *context) memcpy(os_context_sigmask_addr(context), &pending_mask, 4 /* sizeof(sigset_t) */ ); #endif - sigemptyset(&pending_mask); - if (pending_signal) { - int signal = pending_signal; + sigemptyset(&data->pending_mask); + if (data->pending_signal) { + int signal = data->pending_signal; siginfo_t info; - memcpy(&info, &pending_info, sizeof(siginfo_t)); - pending_signal = 0; + memcpy(&info, &data->pending_info, sizeof(siginfo_t)); + data->pending_signal = 0; interrupt_handle_now(signal, &info, context); } } @@ -361,6 +354,7 @@ void interrupt_handle_now(int signal, siginfo_t *info, void *void_context) { os_context_t *context = (os_context_t*)void_context; + struct thread *thread=arch_os_get_current_thread(); #ifndef __i386__ boolean were_in_lisp; #endif @@ -372,7 +366,7 @@ interrupt_handle_now(int signal, siginfo_t *info, void *void_context) delivered we appear to have a null FPU control word. */ os_restore_fp_control(context); #endif - handler = interrupt_handlers[signal]; + handler = thread->interrupt_data->interrupt_handlers[signal]; if (ARE_SAME_HANDLER(handler.c, SIG_IGN)) { return; @@ -445,50 +439,40 @@ interrupt_handle_now(int signal, siginfo_t *info, void *void_context) } static void +store_signal_data_for_later (struct interrupt_data *data, int signal, + siginfo_t *info, os_context_t *context) +{ + data->pending_signal = signal; + memcpy(&(data->pending_info), info, sizeof(siginfo_t)); + memcpy(&(data->pending_mask), + os_context_sigmask_addr(context), + sizeof(sigset_t)); + sigaddset_blockable(os_context_sigmask_addr(context)); +} + + +static void maybe_now_maybe_later(int signal, siginfo_t *info, void *void_context) { os_context_t *context = arch_os_get_context(&void_context); - + struct thread *thread=arch_os_get_current_thread(); + struct interrupt_data *data=thread->interrupt_data; #ifdef LISP_FEATURE_LINUX os_restore_fp_control(context); #endif - /* see comments at top of code/signal.lisp for what's going on here * with INTERRUPTS_ENABLED/INTERRUPT_HANDLE_NOW */ - if (SymbolValue(INTERRUPTS_ENABLED) == NIL) { - - /* FIXME: This code is exactly the same as the code in the - * other leg of the if(..), and should be factored out into - * a shared function. */ - pending_signal = signal; - memcpy(&pending_info, info, sizeof(siginfo_t)); - memcpy(&pending_mask, - os_context_sigmask_addr(context), - sizeof(sigset_t)); - sigaddset_blockable(os_context_sigmask_addr(context)); - SetSymbolValue(INTERRUPT_PENDING, T); - + if (SymbolValue(INTERRUPTS_ENABLED,thread) == NIL) { + store_signal_data_for_later(data,signal,info,context); + SetSymbolValue(INTERRUPT_PENDING, T,thread); } else if ( #ifndef __i386__ (!foreign_function_call_active) && #endif arch_pseudo_atomic_atomic(context)) { - - /* FIXME: It would probably be good to replace these bare - * memcpy(..) calls with calls to cpy_siginfo_t and - * cpy_sigset_t, so that we only have to get the sizeof - * expressions right in one place, and after that static type - * checking takes over. */ - pending_signal = signal; - memcpy(&pending_info, info, sizeof(siginfo_t)); - memcpy(&pending_mask, - os_context_sigmask_addr(context), - sizeof(sigset_t)); - sigaddset_blockable(os_context_sigmask_addr(context)); - + store_signal_data_for_later(data,signal,info,context); arch_set_pseudo_atomic_interrupted(context); - } else { interrupt_handle_now(signal, info, context); } @@ -525,16 +509,17 @@ gc_trigger_hit(int signal, siginfo_t *info, os_context_t *context) boolean handle_control_stack_guard_triggered(os_context_t *context,void *addr) { + struct thread *th=arch_os_get_current_thread(); /* note the os_context hackery here. When the signal handler returns, * it won't go back to what it was doing ... */ - if(addr>=(void *)CONTROL_STACK_GUARD_PAGE && - addr<(void *)(CONTROL_STACK_GUARD_PAGE+os_vm_page_size)) { + if(addr>=(void *)CONTROL_STACK_GUARD_PAGE(th) && + addr<(void *)(CONTROL_STACK_GUARD_PAGE(th)+os_vm_page_size)) { void *fun; void *code; - + /* fprintf(stderr, "hit end of control stack\n"); */ /* we hit the end of the control stack. disable protection * temporarily so the error handler has some headroom */ - protect_control_stack_guard_page(0); + protect_control_stack_guard_page(th->pid,0L); fun = (void *) native_pointer((lispobj) SymbolFunction(CONTROL_STACK_EXHAUSTED_ERROR)); @@ -542,7 +527,7 @@ boolean handle_control_stack_guard_triggered(os_context_t *context,void *addr) /* Build a stack frame showing `interrupted' so that the * user's backtrace makes (as much) sense (as usual) */ - build_fake_control_stack_frames(context); + build_fake_control_stack_frames(th,context); /* signal handler will "return" to this error-causing function */ *os_context_pc_addr(context) = code; #ifdef LISP_FEATURE_X86 @@ -640,46 +625,29 @@ interrupt_maybe_gc(int signal, siginfo_t *info, void *void_context) * noise to install handlers */ -/* - * what low-level signal handlers looked like before - * undoably_install_low_level_interrupt_handler() got involved - */ -struct low_level_signal_handler_state { - int was_modified; - void (*handler)(int, siginfo_t*, void*); -} old_low_level_signal_handler_states[NSIG]; +/* SBCL used to have code to restore signal handlers on exit, which + * has been removed from the threaded version until we decide: exit of + * _what_ ? */ + +/* SBCL comment: The "undoably" aspect is because we also arrange with + * atexit() for the handler to be restored to its old value. This is + * for tidiness: it shouldn't matter much ordinarily, but it does + * remove a window where e.g. memory fault signals (SIGSEGV or SIGBUS, + * which in ordinary operation of SBCL are sent to the generational + * garbage collector, then possibly onward to Lisp code) or SIGINT + * (which is ordinarily passed to Lisp code) could otherwise be + * handled bizarrely/brokenly because the Lisp code would try to deal + * with them using machinery (like stream output buffers) which has + * already been dismantled. */ + +/* I'm not sure (a) whether this is a real concern, (b) how it helps + anyway */ void uninstall_low_level_interrupt_handlers_atexit(void) { - int signal; - for (signal = 0; signal < NSIG; ++signal) { - struct low_level_signal_handler_state - *old_low_level_signal_handler_state = - old_low_level_signal_handler_states + signal; - if (old_low_level_signal_handler_state->was_modified) { - struct sigaction sa; - sa.sa_sigaction = old_low_level_signal_handler_state->handler; - sigemptyset(&sa.sa_mask); - sa.sa_flags = SA_SIGINFO | SA_RESTART; - sigaction(signal, &sa, NULL); - } - } } -/* Undoably install a special low-level handler for signal; or if - * handler is SIG_DFL, remove any special handling for signal. - * - * The "undoably" aspect is because we also arrange with atexit() for - * the handler to be restored to its old value. This is for tidiness: - * it shouldn't matter much ordinarily, but it does remove a window - * where e.g. memory fault signals (SIGSEGV or SIGBUS, which in - * ordinary operation of SBCL are sent to the generational garbage - * collector, then possibly onward to Lisp code) or SIGINT (which is - * ordinarily passed to Lisp code) could otherwise be handled - * bizarrely/brokenly because the Lisp code would try to deal with - * them using machinery (like stream output buffers) which has already - * been dismantled. */ void undoably_install_low_level_interrupt_handler (int signal, void handler(int, @@ -687,8 +655,9 @@ undoably_install_low_level_interrupt_handler (int signal, void*)) { struct sigaction sa; - struct low_level_signal_handler_state *old_low_level_signal_handler_state = - old_low_level_signal_handler_states + signal; + struct thread *th=arch_os_get_current_thread(); + struct interrupt_data *data= + th ? th->interrupt_data : global_interrupt_data; if (0 > signal || signal >= NSIG) { lose("bad signal number %d", signal); @@ -699,31 +668,11 @@ undoably_install_low_level_interrupt_handler (int signal, sigaddset_blockable(&sa.sa_mask); sa.sa_flags = SA_SIGINFO | SA_RESTART; #ifdef LISP_FEATURE_C_STACK_IS_CONTROL_STACK - /* Signal handlers are run on the control stack, so if it is exhausted - * we had better use an alternate stack for whatever signal tells us - * we've exhausted it */ - if(signal==SIG_MEMORY_FAULT) { - stack_t sigstack; - sigstack.ss_sp=(void *) ALTERNATE_SIGNAL_STACK_START; - sigstack.ss_flags=0; - sigstack.ss_size = SIGSTKSZ; - sigaltstack(&sigstack,0); - sa.sa_flags|=SA_ONSTACK; - } + if(signal==SIG_MEMORY_FAULT) sa.sa_flags|= SA_ONSTACK; #endif - /* In the case of interrupt handlers which are modified more than - * once, we only save the original unmodified copy. */ - if (!old_low_level_signal_handler_state->was_modified) { - struct sigaction *old_handler = - (struct sigaction*) &old_low_level_signal_handler_state->handler; - old_low_level_signal_handler_state->was_modified = 1; - sigaction(signal, &sa, old_handler); - } else { sigaction(signal, &sa, NULL); - } - - interrupt_low_level_handlers[signal] = + data->interrupt_low_level_handlers[signal] = (ARE_SAME_HANDLER(handler, SIG_DFL) ? 0 : handler); } @@ -734,6 +683,9 @@ install_handler(int signal, void handler(int, siginfo_t*, void*)) struct sigaction sa; sigset_t old, new; union interrupt_handler oldhandler; + struct thread *th=arch_os_get_current_thread(); + struct interrupt_data *data= + th ? th->interrupt_data : global_interrupt_data; FSHOW((stderr, "/entering POSIX install_handler(%d, ..)\n", signal)); @@ -746,7 +698,7 @@ install_handler(int signal, void handler(int, siginfo_t*, void*)) FSHOW((stderr, "/interrupt_low_level_handlers[signal]=%d\n", interrupt_low_level_handlers[signal])); - if (interrupt_low_level_handlers[signal]==0) { + if (data->interrupt_low_level_handlers[signal]==0) { if (ARE_SAME_HANDLER(handler, SIG_DFL) || ARE_SAME_HANDLER(handler, SIG_IGN)) { sa.sa_sigaction = handler; @@ -759,12 +711,11 @@ install_handler(int signal, void handler(int, siginfo_t*, void*)) sigemptyset(&sa.sa_mask); sigaddset_blockable(&sa.sa_mask); sa.sa_flags = SA_SIGINFO | SA_RESTART; - sigaction(signal, &sa, NULL); } - oldhandler = interrupt_handlers[signal]; - interrupt_handlers[signal].c = handler; + oldhandler = data->interrupt_handlers[signal]; + data->interrupt_handlers[signal].c = handler; sigprocmask(SIG_SETMASK, &old, 0); @@ -774,18 +725,15 @@ install_handler(int signal, void handler(int, siginfo_t*, void*)) } void -interrupt_init(void) +interrupt_init() { int i; - SHOW("entering interrupt_init()"); - - /* Set up for recovery from any installed low-level handlers. */ - atexit(&uninstall_low_level_interrupt_handlers_atexit); + global_interrupt_data=calloc(sizeof(struct interrupt_data), 1); /* Set up high level handler information. */ for (i = 0; i < NSIG; i++) { - interrupt_handlers[i].c = + global_interrupt_data->interrupt_handlers[i].c = /* (The cast here blasts away the distinction between * SA_SIGACTION-style three-argument handlers and * signal(..)-style one-argument handlers, which is OK diff --git a/src/runtime/interrupt.h b/src/runtime/interrupt.h index 2a35852..25d151f 100644 --- a/src/runtime/interrupt.h +++ b/src/runtime/interrupt.h @@ -19,16 +19,26 @@ * Note: In CMU CL, this was 4096, but there was no explanation given, * and it's hard to see why we'd need that many nested interrupts, so * I've scaled it back to see what happens. -- WHN 20000730 */ -#define MAX_INTERRUPTS 256 - -extern os_context_t *lisp_interrupt_contexts[MAX_INTERRUPTS]; +#define MAX_INTERRUPTS 8 union interrupt_handler { lispobj lisp; void (*c)(int, siginfo_t*, void*); }; -extern void interrupt_init(void); +struct interrupt_data { + void (*interrupt_low_level_handlers[NSIG]) (int, siginfo_t*, void*) ; + union interrupt_handler interrupt_handlers[NSIG]; + + /* signal number, siginfo_t, and old mask information for pending + * signal. pending_signal=0 when there is no pending signal. */ + int pending_signal ; + siginfo_t pending_info; + sigset_t pending_mask; +}; + + +extern void interrupt_init(); extern void fake_foreign_function_call(os_context_t* context); extern void undo_fake_foreign_function_call(os_context_t* context); extern void interrupt_handle_now(int, siginfo_t*, void*); diff --git a/src/runtime/ldso-stubs.S b/src/runtime/ldso-stubs.S index 37006fb..65fc520 100644 --- a/src/runtime/ldso-stubs.S +++ b/src/runtime/ldso-stubs.S @@ -165,6 +165,7 @@ ldso_stub__ ## fct: ; \ LDSO_STUBIFY(send) LDSO_STUBIFY(setitimer) LDSO_STUBIFY(setpgrp) + LDSO_STUBIFY(setsid) #if !defined(SVR4) LDSO_STUBIFY(sigsetmask) #endif diff --git a/src/runtime/linux-os.c b/src/runtime/linux-os.c index 371cbb6..8eb8d6f 100644 --- a/src/runtime/linux-os.c +++ b/src/runtime/linux-os.c @@ -42,6 +42,7 @@ #include #include "validate.h" +#include "thread.h" size_t os_vm_page_size; #include "gc.h" @@ -228,12 +229,19 @@ in_range_p(os_vm_address_t a, lispobj sbeg, size_t slen) boolean is_valid_lisp_addr(os_vm_address_t addr) { - return - in_range_p(addr, READ_ONLY_SPACE_START, READ_ONLY_SPACE_SIZE) || + struct thread *th; + if(in_range_p(addr, READ_ONLY_SPACE_START, READ_ONLY_SPACE_SIZE) || in_range_p(addr, STATIC_SPACE_START , STATIC_SPACE_SIZE) || - in_range_p(addr, DYNAMIC_SPACE_START , DYNAMIC_SPACE_SIZE) || - in_range_p(addr, CONTROL_STACK_START , CONTROL_STACK_SIZE) || - in_range_p(addr, BINDING_STACK_START , BINDING_STACK_SIZE); + in_range_p(addr, DYNAMIC_SPACE_START , DYNAMIC_SPACE_SIZE)) + return 1; + for_each_thread(th) { + if(in_range_p(addr, th->control_stack_start, + THREAD_CONTROL_STACK_SIZE) || + in_range_p(addr, th->binding_stack_start, + BINDING_STACK_SIZE)) + return 1; + } + return 0; } /* @@ -289,10 +297,19 @@ sigsegv_handler(int signal, siginfo_t *info, void* void_context) } #endif +void sigcont_handler(int signal, siginfo_t *info, void *void_context) +{ + /* we need to have a handler installed for this signal so that + * sigwaitinfo() for it actually returns at the appropriate time + */ +} + void os_install_interrupt_handlers(void) { undoably_install_low_level_interrupt_handler(SIG_MEMORY_FAULT, sigsegv_handler); + undoably_install_low_level_interrupt_handler(SIGCONT, + sigcont_handler); } diff --git a/src/runtime/monitor.c b/src/runtime/monitor.c index e61faf3..ccda1d9 100644 --- a/src/runtime/monitor.c +++ b/src/runtime/monitor.c @@ -33,6 +33,7 @@ #include "globals.h" #include "lispregs.h" #include "interrupt.h" +#include "thread.h" #include "genesis/static-symbols.h" #include "genesis/primitive-objects.h" @@ -178,6 +179,7 @@ regs_cmd(char **ptr) #if !defined(__i386__) printf("BSP\t=\t0x%08X\n", (unsigned long)current_binding_stack_pointer); #endif +#if 0 #ifdef __i386__ printf("BSP\t=\t0x%08lx\n", (unsigned long)SymbolValue(BINDING_STACK_POINTER)); @@ -196,7 +198,7 @@ regs_cmd(char **ptr) (unsigned long)SymbolValue(STATIC_SPACE_FREE_POINTER)); printf("RDONLY\t=\t0x%08lx\n", (unsigned long)SymbolValue(READ_ONLY_SPACE_FREE_POINTER)); - +#endif /* 0 */ #ifdef MIPS printf("FLAGS\t=\t0x%08x\n", current_flags_register); #endif @@ -332,8 +334,9 @@ static void print_context_cmd(char **ptr) { int free; + struct thread *thread=arch_os_get_current_thread(); - free = SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX)>>2; + free = SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX,thread)>>2; if (more_p(ptr)) { int index; @@ -343,7 +346,7 @@ print_context_cmd(char **ptr) if ((index >= 0) && (index < free)) { printf("There are %d interrupt contexts.\n", free); printf("printing context %d\n", index); - print_context(lisp_interrupt_contexts[index]); + print_context(thread->interrupt_contexts[index]); } else { printf("There aren't that many/few contexts.\n"); printf("There are %d interrupt contexts.\n", free); @@ -354,7 +357,7 @@ print_context_cmd(char **ptr) else { printf("There are %d interrupt contexts.\n", free); printf("printing context %d\n", free - 1); - print_context(lisp_interrupt_contexts[free - 1]); + print_context(thread->interrupt_contexts[free - 1]); } } } @@ -378,8 +381,9 @@ static void catchers_cmd(char **ptr) { struct catch_block *catch; + struct thread *thread=arch_os_get_current_thread(); - catch = (struct catch_block *)SymbolValue(CURRENT_CATCH_BLOCK); + catch = (struct catch_block *)SymbolValue(CURRENT_CATCH_BLOCK,thread); if (catch == NULL) printf("There are no active catchers!\n"); diff --git a/src/runtime/parse.c b/src/runtime/parse.c index cb71dc4..61d8a24 100644 --- a/src/runtime/parse.c +++ b/src/runtime/parse.c @@ -29,6 +29,7 @@ #include "monitor.h" #include "arch.h" #include "search.h" +#include "thread.h" #include "genesis/simple-fun.h" #include "genesis/fdefn.h" @@ -248,7 +249,7 @@ static boolean lookup_symbol(char *name, lispobj *result) /* Search static space. */ headerptr = (lispobj *)STATIC_SPACE_START; count = - (lispobj *)SymbolValue(STATIC_SPACE_FREE_POINTER) - + (lispobj *)SymbolValue(STATIC_SPACE_FREE_POINTER,0) - (lispobj *)STATIC_SPACE_START; if (search_for_symbol(name, &headerptr, &count)) { *result = make_lispobj(headerptr,OTHER_POINTER_LOWTAG); @@ -263,7 +264,7 @@ static boolean lookup_symbol(char *name, lispobj *result) (lispobj *)DYNAMIC_SPACE_START; #else count = - (lispobj *)SymbolValue(ALLOCATION_POINTER) - + (lispobj *)SymbolValue(ALLOCATION_POINTER,0) - (lispobj *)DYNAMIC_SPACE_START; #endif if (search_for_symbol(name, &headerptr, &count)) { @@ -307,6 +308,7 @@ parse_regnum(char *s) lispobj parse_lispobj(ptr) char **ptr; { + struct thread *thread=arch_os_get_current_thread(); char *token = parse_token(ptr); long pointer; lispobj result; @@ -320,14 +322,14 @@ char **ptr; int regnum; os_context_t *context; - free = SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX)>>2; + free = SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX,thread)>>2; if (free == 0) { printf("Variable ``%s'' is not valid -- there is no current interrupt context.\n", token); throw_to_monitor(); } - context = lisp_interrupt_contexts[free - 1]; + context = thread->interrupt_contexts[free - 1]; regnum = parse_regnum(token); if (regnum < 0) { diff --git a/src/runtime/print.c b/src/runtime/print.c index 60ad9bd..6362a6f 100644 --- a/src/runtime/print.c +++ b/src/runtime/print.c @@ -30,9 +30,14 @@ #include "monitor.h" #include "vars.h" #include "os.h" +#include "gencgc-alloc-region.h" /* genesis/thread.h needs this */ #include "genesis/static-symbols.h" #include "genesis/primitive-objects.h" +#include "genesis/static-symbols.h" + + + static int max_lines = 20, cur_lines = 0; static int max_depth = 5, brief_depth = 2, cur_depth = 0; static int max_length = 5; @@ -413,7 +418,11 @@ static void print_slots(char **slots, int count, lispobj *ptr) * on the values in sbcl.h (or perhaps be generated automatically * by GENESIS as part of sbcl.h). */ static char *symbol_slots[] = {"value: ", "unused: ", - "plist: ", "name: ", "package: ", NULL}; + "plist: ", "name: ", "package: ", +#ifdef LISP_FEATURE_SB_THREAD + "tls-index: " , +#endif + NULL}; static char *ratio_slots[] = {"numer: ", "denom: ", NULL}; static char *complex_slots[] = {"real: ", "imag: ", NULL}; static char *code_slots[] = {"words: ", "entry: ", "debug: ", NULL}; diff --git a/src/runtime/purify.c b/src/runtime/purify.c index e93e170..e061156 100644 --- a/src/runtime/purify.c +++ b/src/runtime/purify.c @@ -17,6 +17,9 @@ #include #include #include +#include +#include +#include #include "runtime.h" #include "os.h" @@ -28,6 +31,7 @@ #include "interr.h" #include "gc.h" #include "gc-internal.h" +#include "thread.h" #include "genesis/primitive-objects.h" #include "genesis/static-symbols.h" @@ -1301,7 +1305,7 @@ purify(lispobj static_roots, lispobj read_only_roots) lispobj *clean; int count, i; struct later *laters, *next; - + struct thread *thread; #ifdef PRINTNOISE printf("[doing purification:"); @@ -1310,7 +1314,8 @@ purify(lispobj static_roots, lispobj read_only_roots) #ifdef LISP_FEATURE_GENCGC gc_alloc_update_all_page_tables(); #endif - if (fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX)) != 0) { + for_each_thread(thread) + if (fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX,thread)) != 0) { /* FIXME: 1. What does this mean? 2. It shouldn't be reporting * its error simply by a. printing a string b. to stdout instead * of stderr. */ @@ -1321,23 +1326,42 @@ purify(lispobj static_roots, lispobj read_only_roots) #if defined(__i386__) dynamic_space_free_pointer = - (lispobj*)SymbolValue(ALLOCATION_POINTER); + (lispobj*)SymbolValue(ALLOCATION_POINTER,0); #endif read_only_end = read_only_free = - (lispobj *)SymbolValue(READ_ONLY_SPACE_FREE_POINTER); + (lispobj *)SymbolValue(READ_ONLY_SPACE_FREE_POINTER,0); static_end = static_free = - (lispobj *)SymbolValue(STATIC_SPACE_FREE_POINTER); + (lispobj *)SymbolValue(STATIC_SPACE_FREE_POINTER,0); #ifdef PRINTNOISE printf(" roots"); fflush(stdout); #endif +#if 0 + /* can't do this unless the threads in question are suspended with + * ptrace + */ #if (defined(LISP_FEATURE_GENCGC) && defined(LISP_FEATURE_X86)) - gc_assert((lispobj *)CONTROL_STACK_END > ((&read_only_roots)+1)); - setup_i386_stack_scav(((&static_roots)-2), (lispobj *)CONTROL_STACK_END); + for_each_thread(thread) { + void **ptr; + struct user_regs_struct regs; + if(ptrace(PTRACE_GETREGS,thread->pid,0,®s)){ + fprintf(stderr,"child pid %d, %s\n",thread->pid,strerror(errno)); + lose("PTRACE_GETREGS"); + } + setup_i386_stack_scav(regs.ebp, + ((void *)thread->control_stack_start) + +THREAD_CONTROL_STACK_SIZE); + } +#endif #endif + setup_i386_stack_scav(((&static_roots)-2), + ((void *)all_threads->control_stack_start) + +THREAD_CONTROL_STACK_SIZE); + + pscav(&static_roots, 1, 0); pscav(&read_only_roots, 1, 1); @@ -1346,8 +1370,9 @@ purify(lispobj static_roots, lispobj read_only_roots) printf(" handlers"); fflush(stdout); #endif - pscav((lispobj *) interrupt_handlers, - sizeof(interrupt_handlers) / sizeof(lispobj), + pscav((lispobj *) all_threads->interrupt_data->interrupt_handlers, + sizeof(all_threads->interrupt_data->interrupt_handlers) + / sizeof(lispobj), 0); #ifdef PRINTNOISE @@ -1373,10 +1398,18 @@ purify(lispobj static_roots, lispobj read_only_roots) (lispobj *)current_binding_stack_pointer - (lispobj *)BINDING_STACK_START, 0); #else - pscav( (lispobj *)BINDING_STACK_START, - (lispobj *)SymbolValue(BINDING_STACK_POINTER) - - (lispobj *)BINDING_STACK_START, + for_each_thread(thread) { + pscav( (lispobj *)thread->binding_stack_start, + (lispobj *)SymbolValue(BINDING_STACK_POINTER,thread) - + (lispobj *)thread->binding_stack_start, + 0); + pscav( (lispobj *) (thread+1), + fixnum_value(SymbolValue(FREE_TLS_INDEX,0)) - + (sizeof (struct thread))/(sizeof (lispobj)), 0); + } + + #endif /* The original CMU CL code had scavenge-read-only-space code @@ -1449,8 +1482,8 @@ purify(lispobj static_roots, lispobj read_only_roots) /* It helps to update the heap free pointers so that free_heap can * verify after it's done. */ - SetSymbolValue(READ_ONLY_SPACE_FREE_POINTER, (lispobj)read_only_free); - SetSymbolValue(STATIC_SPACE_FREE_POINTER, (lispobj)static_free); + SetSymbolValue(READ_ONLY_SPACE_FREE_POINTER, (lispobj)read_only_free,0); + SetSymbolValue(STATIC_SPACE_FREE_POINTER, (lispobj)static_free,0); #if !defined(__i386__) dynamic_space_free_pointer = current_dynamic_space; diff --git a/src/runtime/runtime.c b/src/runtime/runtime.c index 087efc4..e3e11bc 100644 --- a/src/runtime/runtime.c +++ b/src/runtime/runtime.c @@ -17,11 +17,16 @@ #include #include #include +#include #include #include #include #include #include +#include +#include +#include +#include #if defined(SVR4) || defined(__linux__) #include @@ -44,6 +49,7 @@ #include "core.h" #include "save.h" #include "lispregs.h" +#include "thread.h" #include "genesis/static-symbols.h" #include "genesis/symbol.h" @@ -175,6 +181,10 @@ More information about SBCL is available at .\n\ ", SBCL_VERSION_STRING); } +int gc_thread_pid; +FILE *stdlog; + + int main(int argc, char *argv[], char *envp[]) { @@ -333,35 +343,150 @@ main(int argc, char *argv[], char *envp[]) gc_initialize_pointers(); -#ifdef BINDING_STACK_POINTER - SetSymbolValue(BINDING_STACK_POINTER, BINDING_STACK_START); -#endif - interrupt_init(); - arch_install_interrupt_handlers(); os_install_interrupt_handlers(); -#ifdef PSEUDO_ATOMIC_ATOMIC - /* Turn on pseudo atomic for when we call into Lisp. */ - SHOW("turning on pseudo atomic"); - SetSymbolValue(PSEUDO_ATOMIC_ATOMIC, make_fixnum(1)); - SetSymbolValue(PSEUDO_ATOMIC_INTERRUPTED, make_fixnum(0)); -#endif - /* Convert remaining argv values to something that Lisp can grok. */ SHOW("setting POSIX-ARGV symbol value"); - SetSymbolValue(POSIX_ARGV, alloc_string_list(argv)); + SetSymbolValue(POSIX_ARGV, alloc_string_list(argv),0); /* Install a handler to pick off SIGINT until the Lisp system gets * far enough along to install its own handler. */ sigint_init(); FSHOW((stderr, "/funcalling initial_function=0x%lx\n", initial_function)); - funcall0(initial_function); + create_thread(initial_function); + /* in a unithread build, create_thread never returns */ +#ifdef LISP_FEATURE_SB_THREAD + gc_thread_pid=getpid(); + parent_loop(); +#endif +} - /* initial_function() is not supposed to return. */ - lose("Lisp initial_function gave up control."); - return 0; /* dummy value: return something */ +static void parent_sighandler(int signum,siginfo_t *info, void *void_context) +{ +#if 0 + os_context_t *context = (os_context_t*)void_context; + fprintf(stderr, + "parent thread got signal %d from %d, maybe_gc_pending=%d\n", + signum, info->si_pid, + maybe_gc_pending); +#endif } +#ifdef LISP_FEATURE_SB_THREAD +static void parent_do_garbage_collect(void) +{ + int waiting_threads=0; + struct thread *th; + int status,p; + + for_each_thread(th) { + if(ptrace(PTRACE_ATTACH,th->pid,0,0)) { + fprintf(stderr,"attaching to %d ...",th->pid); + perror("PTRACE_ATTACH"); + } + else waiting_threads++; + } + stop_the_world=1; + + do { + /* not sure if we have to wait for PTRACE_ATTACH to finish + * before we can send PTRACE_CONT, so let's play it safe + */ + while(waiting_threads>0) { + if((p=waitpid(-1,&status, WUNTRACED|__WALL))>0) { + if(WIFEXITED(status) || WIFSIGNALED(status)) + destroy_thread(find_thread_by_pid(p)); + else { +#if 0 + fprintf(stderr, "wait returned pid %d signal %x\n", + p,WSTOPSIG(status)); +#endif + if(WSTOPSIG(status)==SIGTRAP) { + if(ptrace(PTRACE_CONT,p,0,SIGTRAP)) + perror("PTRACE_CONT"); + } + else waiting_threads--; + } + } + } + for_each_thread(th) { + if(SymbolTlValue(PSEUDO_ATOMIC_ATOMIC,th)) { + /* restart the child, setting *p-a-i* which will cause it + * to go into interrupt_handle_pending as soon as it's + * finished being pseudo_atomic. once there it will + * signal itself SIGSTOP, which will give us another + * event to wait for */ + fprintf(stderr, "%d was pseudo-atomic, letting it resume \n", + th->pid); + SetTlSymbolValue(PSEUDO_ATOMIC_INTERRUPTED,1,th) ; + if(ptrace(PTRACE_CONT,th->pid,0,0)) + perror("PTRACE_CONT"); + waiting_threads++; + } + } + } while (waiting_threads>0); + + collect_garbage(maybe_gc_pending-1); + maybe_gc_pending=0; + stop_the_world=0; + /* fprintf(stderr, "gc done\n"); */ + for_each_thread(th) + if(ptrace(PTRACE_DETACH,th->pid,0,0)) + perror("PTRACE_DETACH"); +} + +static void /* noreturn */ parent_loop(void) +{ + struct sigaction sa; + sigset_t sigset; + int status; + + sigemptyset(&sigset); + + sigaddset(&sigset, SIGALRM); + sigaddset(&sigset, SIGCHLD); + sigprocmask(SIG_UNBLOCK,&sigset,0); + sa.sa_handler=parent_sighandler; + sa.sa_mask=sigset; + sa.sa_flags=SA_SIGINFO; + sigaction(SIGALRM, &sa, 0); + sigaction(SIGCHLD, &sa, 0); + + sigemptyset(&sigset); + sa.sa_handler=SIG_IGN; + sa.sa_mask=sigset; + sa.sa_flags=0; + sigaction(SIGINT, &sa, 0); + + while(all_threads) { + pid_t pid=0; + while(pid=waitpid(-1,&status,__WALL|WUNTRACED)) { + struct thread *th; + fprintf(stderr,"waitpid pid %d\n",pid); + if(pid==-1) { + if(errno == EINTR) { + if(maybe_gc_pending) parent_do_garbage_collect(); + continue; + } + if(errno == ECHILD) break; + fprintf(stderr,"waitpid: %s\n",strerror(errno)); + continue; + } + th=find_thread_by_pid(pid); + if(!th) continue; + if(WIFEXITED(status) || WIFSIGNALED(status)) { + fprintf(stderr,"waitpid : child %d %x exited \n", pid,th); + destroy_thread(th); + /* FIXME arrange to call or fake (free-mutex *session-lock*) + * if necessary */ + if(!all_threads) break; + } + } + } + exit(WEXITSTATUS(status)); +} + +#endif diff --git a/src/runtime/runtime.h b/src/runtime/runtime.h index 0ee1264..91e205c 100644 --- a/src/runtime/runtime.h +++ b/src/runtime/runtime.h @@ -102,19 +102,15 @@ native_pointer(lispobj obj) /* Too bad ANSI C doesn't define "bool" as C++ does.. */ typedef int boolean; -/* FIXME: There seems to be no reason that SymbolValue, SetSymbolValue, - * and SymbolFunction can't be defined as (possibly inline) functions - * instead of macros. */ - -#define SymbolValue(sym) \ - (((struct symbol *)((sym)-OTHER_POINTER_LOWTAG))->value) -#define SetSymbolValue(sym,val) \ - (((struct symbol *)((sym)-OTHER_POINTER_LOWTAG))->value = (val)) +/* FIXME: There seems to be no reason that SymbolFunction can't be + * defined as (possibly inline) functions instead of macros. */ +static inline lispobj SymbolValue(u32 sym, void *thread); +static inline void SetSymbolValue(u32 sym, lispobj val, void *thread); /* This only works for static symbols. */ /* FIXME: should be called StaticSymbolFunction, right? */ #define SymbolFunction(sym) \ - (((struct fdefn *)(native_pointer(SymbolValue(sym))))->fun) + (((struct fdefn *)(native_pointer(SymbolValue(sym,0))))->fun) /* KLUDGE: As far as I can tell there's no ANSI C way of saying * "this function never returns". This is the way that you do it diff --git a/src/runtime/save.c b/src/runtime/save.c index 716001f..c8c152f 100644 --- a/src/runtime/save.c +++ b/src/runtime/save.c @@ -24,6 +24,7 @@ #include "lispregs.h" #include "validate.h" #include "gc-internal.h" +#include "thread.h" #include "genesis/static-symbols.h" #include "genesis/symbol.h" @@ -83,6 +84,7 @@ boolean save(char *filename, lispobj init_function) { FILE *file; + struct thread *th; /* Open the output file. We don't actually need the file yet, but * the fopen() might fail for some reason, and we want to detect @@ -99,9 +101,11 @@ save(char *filename, lispobj init_function) * being SAVE-LISP-AND-DIE instead of SAVE-LISP-AND-GO-ON). */ printf("[undoing binding stack and other enclosing state... "); fflush(stdout); - unbind_to_here((lispobj *)BINDING_STACK_START); - SetSymbolValue(CURRENT_CATCH_BLOCK, 0); - SetSymbolValue(CURRENT_UNWIND_PROTECT_BLOCK, 0); + for_each_thread(th) { /* XXX really? */ + unbind_to_here((lispobj *)th->binding_stack_start,th); + SetSymbolValue(CURRENT_CATCH_BLOCK, 0,th); + SetSymbolValue(CURRENT_UNWIND_PROTECT_BLOCK, 0,th); + } printf("done]\n"); fflush(stdout); @@ -135,11 +139,11 @@ save(char *filename, lispobj init_function) output_space(file, READ_ONLY_CORE_SPACE_ID, (lispobj *)READ_ONLY_SPACE_START, - (lispobj *)SymbolValue(READ_ONLY_SPACE_FREE_POINTER)); + (lispobj *)SymbolValue(READ_ONLY_SPACE_FREE_POINTER,0)); output_space(file, STATIC_CORE_SPACE_ID, (lispobj *)STATIC_SPACE_START, - (lispobj *)SymbolValue(STATIC_SPACE_FREE_POINTER)); + (lispobj *)SymbolValue(STATIC_SPACE_FREE_POINTER,0)); #ifdef reg_ALLOC output_space(file, DYNAMIC_CORE_SPACE_ID, @@ -154,7 +158,7 @@ save(char *filename, lispobj init_function) output_space(file, DYNAMIC_CORE_SPACE_ID, (lispobj *)DYNAMIC_SPACE_START, - (lispobj *)SymbolValue(ALLOCATION_POINTER)); + (lispobj *)SymbolValue(ALLOCATION_POINTER,0)); #endif putw(INITIAL_FUN_CORE_ENTRY_TYPE_CODE, file); diff --git a/src/runtime/search.c b/src/runtime/search.c index 611c77a..6988dda 100644 --- a/src/runtime/search.c +++ b/src/runtime/search.c @@ -15,6 +15,7 @@ #include "sbcl.h" #include "os.h" #include "search.h" +#include "thread.h" #include "genesis/primitive-objects.h" boolean search_for_type(int type, lispobj **start, int *count) diff --git a/src/runtime/thread.c b/src/runtime/thread.c index 40d3afe..ddcc8fd 100644 --- a/src/runtime/thread.c +++ b/src/runtime/thread.c @@ -41,6 +41,7 @@ int new_thread_trampoline(struct thread *th) { lispobj function; + lispobj *args = NULL; function = th->unbound_marker; if(go==0) { fprintf(stderr, "/pausing 0x%lx(%d,%d) before new_thread_trampoline(0x%lx)\n", @@ -54,7 +55,11 @@ new_thread_trampoline(struct thread *th) if(arch_os_thread_init(th)==0) return 1; /* failure. no, really */ - return funcall0(function); +#ifdef LISP_FEATURE_SB_THREAD + return call_into_lisp(function,args,0); +#else + return call_into_lisp_first_time(function,args,0); +#endif } /* this is called from any other thread to create the new one, and @@ -99,6 +104,7 @@ pid_t create_thread(lispobj initial_function) { make_fixnum(MAX_INTERRUPTS+ sizeof(struct thread)/sizeof(lispobj)), 0); +#ifdef LISP_FEATURE_SB_THREAD #define STATIC_TLS_INIT(sym,field) \ ((struct symbol *)(sym-OTHER_POINTER_LOWTAG))->tls_index= \ make_fixnum(THREAD_SLOT_OFFSET_WORDS(field)) @@ -110,6 +116,7 @@ pid_t create_thread(lispobj initial_function) { STATIC_TLS_INIT(PSEUDO_ATOMIC_ATOMIC,pseudo_atomic_atomic); STATIC_TLS_INIT(PSEUDO_ATOMIC_INTERRUPTED,pseudo_atomic_interrupted); #undef STATIC_TLS_INIT +#endif } th->control_stack_start = spaces; @@ -131,6 +138,21 @@ pid_t create_thread(lispobj initial_function) { * sure why, but it appears to help */ th->pseudo_atomic_atomic=make_fixnum(1); gc_set_region_empty(&th->alloc_region); + +#ifndef LISP_FEATURE_SB_THREAD + /* the tls-points-into-struct-thread trick is only good for threaded + * sbcl, because unithread sbcl doesn't have tls. So, we copy the + * appropriate values from struct thread here, and make sure that + * we use the appropriate SymbolValue macros to access any of the + * variable quantities from the C runtime. It's not quite OAOOM, + * it just feels like it */ + SetSymbolValue(BINDING_STACK_START,th->binding_stack_start,th); + SetSymbolValue(BINDING_STACK_POINTER,th->binding_stack_pointer,th); + SetSymbolValue(CONTROL_STACK_START,th->control_stack_start,th); + SetSymbolValue(ALIEN_STACK,th->alien_stack_pointer,th); + SetSymbolValue(PSEUDO_ATOMIC_ATOMIC,th->pseudo_atomic_atomic,th); + SetSymbolValue(PSEUDO_ATOMIC_INTERRUPTED,th->pseudo_atomic_interrupted,th); +#endif bind_variable(CURRENT_CATCH_BLOCK,make_fixnum(0),th); bind_variable(CURRENT_UNWIND_PROTECT_BLOCK,make_fixnum(0),th); @@ -146,9 +168,9 @@ pid_t create_thread(lispobj initial_function) { memcpy(th->interrupt_data,global_interrupt_data, sizeof (struct interrupt_data)); - -#if defined(LISP_FEATURE_X86) && defined (LISP_FEATURE_LINUX) th->unbound_marker=initial_function; +#ifdef LISP_FEATURE_SB_THREAD +#if defined(LISP_FEATURE_X86) && defined (LISP_FEATURE_LINUX) kid_pid= clone(new_thread_trampoline, (((void*)th->control_stack_start)+THREAD_CONTROL_STACK_SIZE-4), @@ -159,7 +181,9 @@ pid_t create_thread(lispobj initial_function) { #else #error this stuff presently only works on x86 Linux #endif - +#else + kid_pid=getpid(); +#endif get_spinlock(&all_threads_lock,kid_pid); th->next=all_threads; all_threads=th; @@ -169,6 +193,11 @@ pid_t create_thread(lispobj initial_function) { protect_control_stack_guard_page(th->pid,1); all_threads_lock=0; th->pid=kid_pid; /* child will not start until this is set */ +#ifndef LISP_FEATURE_SB_THREAD + new_thread_trampoline(all_threads); /* call_into_lisp */ + lose("Clever child? Idiot savant, verging on the."); +#endif + return th->pid; cleanup: /* if(th && th->tls_cookie>=0) os_free_tls_pointer(th); */ diff --git a/src/runtime/thread.h b/src/runtime/thread.h index 674f051..948b6b6 100644 --- a/src/runtime/thread.h +++ b/src/runtime/thread.h @@ -29,29 +29,42 @@ extern struct thread *all_threads; extern int dynamic_values_bytes; extern struct thread *find_thread_by_pid(pid_t pid); +#ifdef LISP_FEATURE_SB_THREAD #define for_each_thread(th) for(th=all_threads;th;th=th->next) +#else +/* there's some possibility a SSC could notice this never actually + * loops */ +#define for_each_thread(th) for(th=all_threads;th;th=0) +#endif static inline lispobj SymbolValue(u32 tagged_symbol_pointer, void *thread) { struct symbol *sym= (struct symbol *) (tagged_symbol_pointer-OTHER_POINTER_LOWTAG); +#ifdef LISP_FEATURE_SB_THREAD if(thread && sym->tls_index) { lispobj r= ((union per_thread_data *)thread) ->dynamic_values[fixnum_value(sym->tls_index)]; if(r!=UNBOUND_MARKER_WIDETAG) return r; } +#endif return sym->value; } static inline lispobj SymbolTlValue(u32 tagged_symbol_pointer, void *thread) { struct symbol *sym= (struct symbol *) (tagged_symbol_pointer-OTHER_POINTER_LOWTAG); +#ifdef LISP_FEATURE_SB_THREAD return ((union per_thread_data *)thread) ->dynamic_values[fixnum_value(sym->tls_index)]; +#else + return sym->value; +#endif } static inline void SetSymbolValue(u32 tagged_symbol_pointer,lispobj val, void *thread) { struct symbol *sym= (struct symbol *) (tagged_symbol_pointer-OTHER_POINTER_LOWTAG); +#ifdef LISP_FEATURE_SB_THREAD if(thread && sym->tls_index) { lispobj *pr= &(((union per_thread_data *)thread) ->dynamic_values[fixnum_value(sym->tls_index)]); @@ -60,14 +73,19 @@ static inline void SetSymbolValue(u32 tagged_symbol_pointer,lispobj val, void *t return; } } +#endif sym->value = val; } static inline void SetTlSymbolValue(u32 tagged_symbol_pointer,lispobj val, void *thread) { +#ifdef LISP_FEATURE_SB_THREAD struct symbol *sym= (struct symbol *) (tagged_symbol_pointer-OTHER_POINTER_LOWTAG); ((union per_thread_data *)thread) ->dynamic_values[fixnum_value(sym->tls_index)] =val; +#else + SetSymbolValue(tagged_symbol_pointer,val,thread) ; +#endif } diff --git a/src/runtime/validate.c b/src/runtime/validate.c index be8ad27..7681dcd 100644 --- a/src/runtime/validate.c +++ b/src/runtime/validate.c @@ -72,8 +72,6 @@ validate(void) ensure_space( (lispobj *)DYNAMIC_0_SPACE_START , DYNAMIC_SPACE_SIZE); ensure_space( (lispobj *)DYNAMIC_1_SPACE_START , DYNAMIC_SPACE_SIZE); #endif - ensure_space( (lispobj *)CONTROL_STACK_START , CONTROL_STACK_SIZE); - ensure_space( (lispobj *)BINDING_STACK_START , BINDING_STACK_SIZE); #ifdef LISP_FEATURE_C_STACK_IS_CONTROL_STACK ensure_space( (lispobj *) ALTERNATE_SIGNAL_STACK_START, SIGSTKSZ); #endif @@ -85,11 +83,11 @@ validate(void) #ifdef PRINTNOISE printf(" done.\n"); #endif - protect_control_stack_guard_page(1); } -void protect_control_stack_guard_page(int protect_p) { - os_protect(CONTROL_STACK_GUARD_PAGE, +void protect_control_stack_guard_page(pid_t t_id, int protect_p) { + struct thread *th= find_thread_by_pid(t_id); + os_protect(CONTROL_STACK_GUARD_PAGE(th), os_vm_page_size,protect_p ? (OS_VM_PROT_READ|OS_VM_PROT_EXECUTE) : OS_VM_PROT_ALL); } diff --git a/src/runtime/validate.h b/src/runtime/validate.h index 2a963a0..71278f9 100644 --- a/src/runtime/validate.h +++ b/src/runtime/validate.h @@ -13,21 +13,22 @@ #define _INCLUDE_VALIDATE_H_ /* constants derived from the fundamental constants in passed by GENESIS */ -#define BINDING_STACK_SIZE ( BINDING_STACK_END - BINDING_STACK_START) -#define CONTROL_STACK_SIZE ( CONTROL_STACK_END - CONTROL_STACK_START) +#define BINDING_STACK_SIZE (1024*1024) /* chosen at random */ #define DYNAMIC_SPACE_SIZE ( DYNAMIC_SPACE_END - DYNAMIC_SPACE_START) #define READ_ONLY_SPACE_SIZE (READ_ONLY_SPACE_END - READ_ONLY_SPACE_START) #define STATIC_SPACE_SIZE ( STATIC_SPACE_END - STATIC_SPACE_START) +#define THREAD_CONTROL_STACK_SIZE (2*1024*1024) /* wired elsewhere-watch out */ +#if !defined(LANGUAGE_ASSEMBLY) +#include #ifdef LISP_FEATURE_STACK_GROWS_DOWNWARD_NOT_UPWARD -#define CONTROL_STACK_GUARD_PAGE (CONTROL_STACK_START) +#define CONTROL_STACK_GUARD_PAGE(th) ((void *)(th->control_stack_start)) #else -#define CONTROL_STACK_GUARD_PAGE (CONTROL_STACK_END - os_vm_page_size) +#define CONTROL_STACK_GUARD_PAGE(th) (((void *)(th->control_stack_start))+THREAD_CONTROL_STACK_SIZE - os_vm_page_size) #endif -#if !defined(LANGUAGE_ASSEMBLY) extern void validate(void); -extern void protect_control_stack_guard_page(int protect_p); +extern void protect_control_stack_guard_page(pid_t t_id, int protect_p); #endif /* note for anyone trying to port an architecture's support files diff --git a/src/runtime/x86-arch.c b/src/runtime/x86-arch.c index d2213d5..9b51cc0 100644 --- a/src/runtime/x86-arch.c +++ b/src/runtime/x86-arch.c @@ -24,6 +24,7 @@ #include "interr.h" #include "breakpoint.h" #include "monitor.h" +#include "thread.h" #include "genesis/static-symbols.h" #include "genesis/symbol.h" @@ -115,13 +116,14 @@ arch_internal_error_arguments(os_context_t *context) boolean arch_pseudo_atomic_atomic(os_context_t *context) { - return SymbolValue(PSEUDO_ATOMIC_ATOMIC); + return SymbolValue(PSEUDO_ATOMIC_ATOMIC,arch_os_get_current_thread()); } void arch_set_pseudo_atomic_interrupted(os_context_t *context) { - SetSymbolValue(PSEUDO_ATOMIC_INTERRUPTED, make_fixnum(1)); + SetSymbolValue(PSEUDO_ATOMIC_INTERRUPTED, make_fixnum(1), + arch_os_get_current_thread()); } /* @@ -316,6 +318,7 @@ call_into_lisp(lispobj fun, lispobj *args, int nargs); * could be in registers depending on what the compiler likes. So we * copy the args into a portable vector and let the assembly language * call-in function figure it out. */ + lispobj funcall0(lispobj function) { diff --git a/src/runtime/x86-assem.S b/src/runtime/x86-assem.S index 19584b9..a569f24 100644 --- a/src/runtime/x86-assem.S +++ b/src/runtime/x86-assem.S @@ -19,8 +19,8 @@ #include "genesis/closure.h" #include "genesis/fdefn.h" #include "genesis/static-symbols.h" -#include "genesis/symbol.h" - +#include "genesis/symbol.h" +#include "genesis/thread.h" /* Minimize conditionalization for different OS naming schemes. */ #if defined __linux__ || defined __FreeBSD__ /* (but *not* OpenBSD) */ @@ -43,6 +43,7 @@ .text .global GNAME(foreign_function_call_active) + .global GNAME(all_threads) /* @@ -127,19 +128,38 @@ Lfp_rtn_value: .text + .global GNAME(call_into_lisp_first_time) + .type GNAME(call_into_lisp_first_time),@function + +/* The *ALIEN-STACK* pointer is set up on the first call_into_lisp when + * the stack changes. We don't worry too much about saving registers + * here, because we never expect to return from the initial call to lisp + * anyway */ + + .align align_16byte,0x90 +GNAME(call_into_lisp_first_time): + pushl %ebp # Save old frame pointer. + movl %esp,%ebp # Establish new frame. + movl %esp,ALIEN_STACK + SYMBOL_VALUE_OFFSET + movl all_threads,%eax + movl THREAD_CONTROL_STACK_START_OFFSET(%eax) ,%esp + /* don't think too hard about what happens if we get interrupted + * here */ + addl $THREAD_CONTROL_STACK_SIZE-4,%esp + jmp Lstack + + .text .global GNAME(call_into_lisp) .type GNAME(call_into_lisp),@function /* The C conventions require that ebx, esi, edi, and ebp be preserved * across function calls. */ -/* The *ALIEN-STACK* pointer is set up on the first call_into_lisp when - * the stack changes. */ .align align_16byte,0x90 GNAME(call_into_lisp): pushl %ebp # Save old frame pointer. movl %esp,%ebp # Establish new frame. - +Lstack: /* Save the NPX state */ fwait # Catch any pending NPX exceptions. subl $108,%esp # Make room for the NPX state. @@ -178,15 +198,6 @@ GNAME(call_into_lisp): movl %eax, GNAME(foreign_function_call_active) movl %esp,%ebx # remember current stack - cmpl $CONTROL_STACK_START,%esp - jbe ChangeToLispStack - cmpl $CONTROL_STACK_END,%esp - jbe OnLispStack -ChangeToLispStack: - /* Setup the *alien-stack* pointer */ - movl %esp,ALIEN_STACK + SYMBOL_VALUE_OFFSET - movl $CONTROL_STACK_END,%esp # new stack -OnLispStack: pushl %ebx # Save entry stack on (maybe) new stack. /* Establish Lisp args. */ @@ -662,7 +673,7 @@ GNAME(alloc_16_to_edi): -#ifdef LISP_FEATURE_GENCGC_INLINE_ALLOC /* disabled at present */ +#ifdef GENCGC_INLINE_ALLOC /* LISP_FEATURE_GENCGC */ /* These routines are called from Lisp when an inline allocation * overflows. Every register except the result needs to be preserved. diff --git a/src/runtime/x86-linux-os.c b/src/runtime/x86-linux-os.c index 30a44da..aa1a0ad 100644 --- a/src/runtime/x86-linux-os.c +++ b/src/runtime/x86-linux-os.c @@ -15,8 +15,12 @@ */ #include +#include #include #include +#include +#include + #include "./signal.h" #include "os.h" #include "arch.h" @@ -34,10 +38,105 @@ #include #include #include +#include +#include +#include +#include "thread.h" /* dynamic_values_bytes */ + +_syscall3(int, modify_ldt, int, func, void *, ptr, unsigned long, bytecount ); #include "validate.h" size_t os_vm_page_size; +u32 local_ldt_copy[LDT_ENTRIES*LDT_ENTRY_SIZE/sizeof(u32)]; + +/* XXX this could be conditionally compiled based on some + * "debug-friendly" flag. But it doesn't really make stuff slower, + * just the runtime gets fractionally larger */ + +void debug_get_ldt() +{ + int n=__modify_ldt (0, local_ldt_copy, sizeof local_ldt_copy); + printf("%d bytes in ldt: print/x local_ldt_copy\n", n); +} + +int arch_os_thread_init(struct thread *thread) { + stack_t sigstack; +#ifdef LISP_FEATURE_SB_THREAD + /* this must be called from a function that has an exclusive lock + * on all_threads + */ + struct modify_ldt_ldt_s ldt_entry = { + 1, 0, 0, /* index, address, length filled in later */ + 1, MODIFY_LDT_CONTENTS_DATA, 0, 0, 0, 1 + }; + /* get next free ldt entry */ + int n=__modify_ldt(0,local_ldt_copy,sizeof local_ldt_copy); + if(n) { + u32 *p; + for(n=0,p=local_ldt_copy;*p;p+=LDT_ENTRY_SIZE/sizeof(u32)) + n++; + } + ldt_entry.entry_number=n; + ldt_entry.base_addr=(unsigned long) thread; + ldt_entry.limit=dynamic_values_bytes; + ldt_entry.limit_in_pages=0; + if (__modify_ldt (1, &ldt_entry, sizeof (ldt_entry)) != 0) + /* modify_ldt call failed: something magical is not happening */ + return -1; + __asm__ __volatile__ ("movw %w0, %%gs" : : "q" + ((n << 3) /* selector number */ + + (1 << 2) /* TI set = LDT */ + + 3)); /* privilege level */ + thread->tls_cookie=n; + if(n<0) return 0; +#endif +#ifdef LISP_FEATURE_C_STACK_IS_CONTROL_STACK + /* Signal handlers are run on the control stack, so if it is exhausted + * we had better use an alternate stack for whatever signal tells us + * we've exhausted it */ + sigstack.ss_sp=((void *) thread)+dynamic_values_bytes; + sigstack.ss_flags=0; + sigstack.ss_size = 32*SIGSTKSZ; + sigaltstack(&sigstack,0); +#endif + return 1; +} + +/* if you can't do something like this (maybe because you're using a + * register for thread base that is only available in Lisp code) + * you'll just have to find_thread_by_pid(getpid()) + */ +struct thread *arch_os_get_current_thread() { +#ifdef LISP_FEATURE_SB_THREAD + register struct thread *me=0; + if(all_threads) + __asm__ ("movl %%gs:%c1,%0" : "=r" (me) + : "i" (offsetof (struct thread,this))); + return me; +#else + return all_threads; +#endif +} + +/* free any arch/os-specific resources used by thread, which is now + * defunct. Not called on live threads + */ + +int arch_os_thread_cleanup(struct thread *thread) { + struct modify_ldt_ldt_s ldt_entry = { + 0, 0, 0, + 0, MODIFY_LDT_CONTENTS_DATA, 0, 0, 0, 0 + }; + + ldt_entry.entry_number=thread->tls_cookie; + if (__modify_ldt (1, &ldt_entry, sizeof (ldt_entry)) != 0) + /* modify_ldt call failed: something magical is not happening */ + return 0; + return 1; +} + + /* KLUDGE: As of kernel 2.2.14 on Red Hat 6.2, there's code in the * file to define symbolic names for offsets into diff --git a/src/runtime/x86-linux-os.h b/src/runtime/x86-linux-os.h index 90b34c0..a233223 100644 --- a/src/runtime/x86-linux-os.h +++ b/src/runtime/x86-linux-os.h @@ -8,7 +8,9 @@ static inline os_context_t *arch_os_get_context(void **void_context) { return (os_context_t *) *void_context; } +extern struct thread *arch_os_get_current_thread(); unsigned long os_context_fp_control(os_context_t *context); void os_restore_fp_control(os_context_t *context); +int arch_os_thread_init(struct thread *thread); #endif /* _X86_LINUX_OS_H */ diff --git a/version.lisp-expr b/version.lisp-expr index 51d0099..e4d7f00 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.pre8.27" +"0.pre8.28"