;; (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
("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")
; 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)
(declare (ignore start count))
- (load-symbol-value catch *current-catch-block*)
+ (load-tl-symbol-value catch *current-catch-block*)
LOOP
(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?
(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
--- /dev/null
+(in-package :sb!thread)
+
+(defun make-mutex (&key name value) nil)
+
+(defmacro with-recursive-lock ((mutex) &body body)
+ `(progn ,@body))
+
#!-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)
(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
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))
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)
"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*)
(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
(*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.
;; 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
'*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)
*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
;;;; 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)))
+
(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)
+
\f
;;;; SUB-GC
(in-package "SB!FASL")
\f
+;;;; 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.
(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
(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
;;;; files for more information.
(in-package "SB!IMPL")
-\f
-
-#!-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))))
(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)
(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)
#!+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)
(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
;; 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
(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
(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))
;;; 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*)
;; 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
(*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
(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)))))
;; Else, value not immediate.
(storew value object offset lowtag))))
\f
+
+
;;;; 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)))
;;; 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)
(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)
(inst cmp value unbound-marker-widetag)
(inst jmp (if not-p :e :ne) target)))
+
(define-vop (symbol-hash)
(:policy :fast-safe)
(:translate symbol-hash)
;;; 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*)
(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
(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)
(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))
\f
+
+\f
;;;; closure indexing
(define-full-reffer closure-index-ref *
(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)))
+
+
\f
;;;; code object frobbing
(- 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
;;; 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
;; 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))))
+
+
\f
;;;; indexed references
(: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)))
(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*)))
\f
;;;; unwind block hackery
(: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)
(: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)))
\f
;;;; NLX entry VOPs
(define-vop (nlx-entry)
(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
#!+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)
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*
(: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 ())
(: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)
(: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)))
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}
#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) \
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 */
#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"
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)) {
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) {
#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__
#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"
* 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
#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;
symbol = binding->symbol;
- SetSymbolValue(symbol, binding->value);
+ SetTlSymbolValue(symbol, binding->value,thread);
binding->symbol = 0;
}
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;
binding--;
symbol = binding->symbol;
-
if (symbol) {
- SetSymbolValue(symbol, binding->value);
+ SetTlSymbolValue(symbol, binding->value,thread);
binding->symbol = 0;
}
-
}
SetBSP(binding);
}
#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
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_ */
#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);
* integrated with the Lisp code. */
static int last_free_page;
\f
+/* 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;
+
+\f
/*
* miscellaneous heap functions
*/
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;
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. */
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.
*
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;
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));
}
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. */
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));
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));
* (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
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;
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) {
* 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
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. */
* 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);
}
/* 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
/* 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,
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 ... */
}
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. */
{
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 {
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;
/* 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);
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);
}
#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);
#define NUM_PAGES ((DYNAMIC_SPACE_SIZE+4095)/4096)
extern struct page page_table[NUM_PAGES];
\f
-/* 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;
\f
void gencgc_pickup_dynamic(void);
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_
/* 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
}
#ifndef LANGUAGE_ASSEMBLY
+#include <sys/types.h>
+#include <unistd.h>
#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;
#endif
extern lispobj *current_dynamic_space;
+extern pid_t parent_pid;
extern void globals_init(void);
#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)
{
* 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:
*
* - 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;
\f
/*
*/
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
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
(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;
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);
* 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. */
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
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);
}
}
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
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;
}
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);
}
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));
/* 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
* 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,
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);
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);
}
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));
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;
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);
}
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
* 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*);
LDSO_STUBIFY(send)
LDSO_STUBIFY(setitimer)
LDSO_STUBIFY(setpgrp)
+ LDSO_STUBIFY(setsid)
#if !defined(SVR4)
LDSO_STUBIFY(sigsetmask)
#endif
#include <unistd.h>
#include "validate.h"
+#include "thread.h"
size_t os_vm_page_size;
#include "gc.h"
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;
}
\f
/*
}
#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);
}
#include "globals.h"
#include "lispregs.h"
#include "interrupt.h"
+#include "thread.h"
#include "genesis/static-symbols.h"
#include "genesis/primitive-objects.h"
#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));
(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
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;
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);
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]);
}
}
}
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");
#include "monitor.h"
#include "arch.h"
#include "search.h"
+#include "thread.h"
#include "genesis/simple-fun.h"
#include "genesis/fdefn.h"
/* 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);
(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)) {
lispobj parse_lispobj(ptr)
char **ptr;
{
+ struct thread *thread=arch_os_get_current_thread();
char *token = parse_token(ptr);
long pointer;
lispobj result;
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) {
#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;
* 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};
#include <sys/types.h>
#include <stdlib.h>
#include <strings.h>
+#include <sys/ptrace.h>
+#include <linux/user.h>
+#include <errno.h>
#include "runtime.h"
#include "os.h"
#include "interr.h"
#include "gc.h"
#include "gc-internal.h"
+#include "thread.h"
#include "genesis/primitive-objects.h"
#include "genesis/static-symbols.h"
lispobj *clean;
int count, i;
struct later *laters, *next;
-
+ struct thread *thread;
#ifdef PRINTNOISE
printf("[doing purification:");
#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. */
#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);
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
(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
/* 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;
#include <string.h>
#include <libgen.h>
#include <sys/types.h>
+#include <sys/wait.h>
#include <stdlib.h>
#include <unistd.h>
#include <sys/file.h>
#include <sys/param.h>
#include <sys/stat.h>
+#include <signal.h>
+#include <sys/ptrace.h>
+#include <sched.h>
+#include <errno.h>
#if defined(SVR4) || defined(__linux__)
#include <time.h>
#include "core.h"
#include "save.h"
#include "lispregs.h"
+#include "thread.h"
#include "genesis/static-symbols.h"
#include "genesis/symbol.h"
", SBCL_VERSION_STRING);
}
\f
+int gc_thread_pid;
+FILE *stdlog;
+
+\f
int
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
/* 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
#include "lispregs.h"
#include "validate.h"
#include "gc-internal.h"
+#include "thread.h"
#include "genesis/static-symbols.h"
#include "genesis/symbol.h"
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
* 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);
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,
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);
#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)
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",
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
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))
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;
* 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);
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),
#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;
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); */
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)]);
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
}
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
#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);
}
#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 <thread.h>
#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
#include "interr.h"
#include "breakpoint.h"
#include "monitor.h"
+#include "thread.h"
#include "genesis/static-symbols.h"
#include "genesis/symbol.h"
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());
}
\f
/*
* 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)
{
#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) */
.text
.global GNAME(foreign_function_call_active)
+ .global GNAME(all_threads)
\f
/*
\f
.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
+\f
+ .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.
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. */
\f
-#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.
*/
#include <stdio.h>
+#include <stddef.h>
#include <sys/param.h>
#include <sys/file.h>
+#include <sys/types.h>
+#include <unistd.h>
+
#include "./signal.h"
#include "os.h"
#include "arch.h"
#include <sys/time.h>
#include <sys/stat.h>
#include <unistd.h>
+#include <asm/ldt.h>
+#include <linux/unistd.h>
+#include <sys/mman.h>
+#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
* <sys/ucontext.h> file to define symbolic names for offsets into
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 */
;;; 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"
projects / sbcl.git / commitdiff