common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

0.pre8.28

Browse source 
=== Threads merge, 100 metres ===

	This is the first commit of experimental native threads for
	SBCL.  Note that thread support is by default not compiled in
	- you need to add :sb-thread to target features.  Note also
	that non-x86 probably doesn't build in this version - that
	will be fixed imminently

	See log messages for dan_native_threads_branch,
	dan_native_threads_2_branch, dan_native_threads_3_branch for
	more information.  I'm not going to type it all in again
This commit is contained in:
Daniel Barlow 2003-04-02 11:15:10 +00:00
parent 7e00a27796
commit e365f2f7a9
54 changed files with 1222 additions and 495 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
build-order.lisp-expr
View file

@ -427,7 +427,8 @@
;; (and so that they don't cause lots of annoying compiler warnings
;; about undefined types).
("src/compiler/generic/core")
("src/code/cross-thread" :not-target)
("src/code/thread")
("src/code/load")
("src/code/fop") ; needs macros from code/load.lisp
@ -507,6 +508,7 @@
("src/compiler/early-aliencomp")
("src/compiler/target/c-call")
("src/compiler/target/cell")
("src/code/late-symbol" :not-host)
("src/compiler/target/values")
("src/compiler/target/alloc")
("src/compiler/target/call")
@ -602,6 +604,10 @@
; from "code/pathname"
("src/code/sharpm" :not-host) ; uses stuff from "code/reader"
#!+sb-thread
("src/code/target-thread" :not-host)
#!-sb-thread
("src/code/target-unithread" :not-host)
;; defines SB!DI:DO-DEBUG-FUN-BLOCKS, needed by target-disassem.lisp
("src/code/debug-int" :not-host)

8
src/assembly/x86/assem-rtns.lisp
View file

@ -197,7 +197,7 @@
(declare (ignore start count))
(load-symbol-value catch *current-catch-block*)
(load-tl-symbol-value catch *current-catch-block*)
LOOP
@ -232,7 +232,7 @@
(inst or block block) ; check for NULL pointer
(inst jmp :z error))
(load-symbol-value uwp *current-unwind-protect-block*)
(load-tl-symbol-value uwp *current-unwind-protect-block*)
;; Does *CURRENT-UNWIND-PROTECT-BLOCK* match the value stored in
;; argument's CURRENT-UWP-SLOT?
@ -247,7 +247,9 @@
(move block uwp)
;; Set next unwind protect context.
(loadw uwp uwp unwind-block-current-uwp-slot)
(store-symbol-value uwp *current-unwind-protect-block*)
;; we're about to reload ebp anyway, so let's borrow it here as a
;; temporary. Hope this works
(store-tl-symbol-value uwp *current-unwind-protect-block* ebp-tn)
DO-EXIT

7
src/code/cross-thread.lisp Normal file
View file

@ -0,0 +1,7 @@
(in-package :sb!thread)
(defun make-mutex (&key name value) nil)
(defmacro with-recursive-lock ((mutex) &body body)
`(progn ,@body))

27
src/code/debug-int.lisp
View file

@ -527,15 +527,20 @@
#!-sb-fluid (declaim (inline control-stack-pointer-valid-p))
(defun control-stack-pointer-valid-p (x)
(declare (type system-area-pointer x))
(let* ((control-stack-start
(descriptor-sap sb!vm::*control-stack-start*))
(control-stack-end
(sap+
(descriptor-sap sb!vm::*binding-stack-start*) -4)))
#!-stack-grows-downward-not-upward
(and (sap< x (current-sp))
(sap<= (int-sap control-stack-start)
(sap<= control-stack-start
x)
(zerop (logand (sap-int x) #b11)))
#!+stack-grows-downward-not-upward
(and (sap>= x (current-sp))
(sap> (int-sap control-stack-end) x)
(zerop (logand (sap-int x) #b11))))
(sap> control-stack-end x)
(zerop (logand (sap-int x) #b11)))))
#!+x86
(sb!alien:define-alien-routine component-ptr-from-pc (system-area-pointer)
@ -711,7 +716,7 @@
(when (control-stack-pointer-valid-p fp)
#!+x86
(multiple-value-bind (ra ofp) (x86-call-context fp)
(compute-calling-frame ofp ra frame))
(and ra (compute-calling-frame ofp ra frame)))
#!-x86
(compute-calling-frame
#!-alpha
@ -882,15 +887,21 @@
(if up-frame (1+ (frame-number up-frame)) 0)
escaped)))))
#!+x86
(defun nth-interrupt-context (n)
(declare (type (unsigned-byte 32) n)
(optimize (speed 3) (safety 0)))
(sb!alien:sap-alien (sb!vm::current-thread-offset-sap
(+ sb!vm::thread-interrupt-contexts-offset n))
(* os-context-t)))
#!+x86
(defun find-escaped-frame (frame-pointer)
(declare (type system-area-pointer frame-pointer))
(/noshow0 "entering FIND-ESCAPED-FRAME")
(dotimes (index *free-interrupt-context-index* (values nil 0 nil))
(sb!alien:with-alien
((lisp-interrupt-contexts (array (* os-context-t) nil) :extern))
(/noshow0 "at head of WITH-ALIEN")
(let ((context (sb!alien:deref lisp-interrupt-contexts index)))
(let ((context (nth-interrupt-context index)))
(/noshow0 "got CONTEXT")
(when (= (sap-int frame-pointer)
(sb!vm:context-register context sb!vm::cfp-offset))
@ -922,7 +933,7 @@
pc-offset code))
(/noshow0 "returning from FIND-ESCAPED-FRAME")
(return
(values code pc-offset context))))))))))
(values code pc-offset context)))))))))
#!-x86
(defun find-escaped-frame (frame-pointer)

12
src/code/debug.lisp
View file

@ -71,6 +71,7 @@
"Should the debugger display beginner-oriented help messages?")
(defun debug-prompt (stream)
(sb!thread::get-foreground)
(format stream
"~%~W~:[~;[~W~]] "
(sb!di:frame-number *current-frame*)
@ -650,6 +651,9 @@ Other commands:
(let ((*debugger-hook* nil))
(funcall old-hook condition old-hook))))
;; If we're a background thread and *background-threads-wait-for-debugger*
;; is NIL, this will invoke a restart
;; Note: CMU CL had (SB-UNIX:UNIX-SIGSETMASK 0) here. I deleted it
;; around sbcl-0.7.8.5 (by which time it had mutated to have a
;; #!-SUNOS prefix and a FIXME note observing that it wasn't needed
@ -703,6 +707,7 @@ reset to ~S."
(*readtable* *debug-readtable*)
(*print-readably* nil)
(*package* original-package)
(background-p nil)
(*print-pretty* original-print-pretty))
;; Before we start our own output, finish any pending output.
@ -747,6 +752,10 @@ reset to ~S."
;; older debugger code which was written to do i/o on whatever
;; stream was in fashion at the time, and not all of it has
;; been converted to behave this way. -- WHN 2000-11-16)
(setf background-p
(sb!thread::debugger-wait-until-foreground-thread *debug-io*))
(unwind-protect
(let (;; FIXME: Rebinding *STANDARD-OUTPUT* here seems wrong,
;; violating the principle of least surprise, and making
;; it impossible for the user to do reasonable things
@ -773,7 +782,8 @@ reset to ~S."
'*debug-condition*
'*debug-beginner-help-p*))
(show-restarts *debug-restarts* *debug-io*))
(internal-debug))))))
(internal-debug))
(when background-p (sb!thread::release-foreground)))))))
(defun show-restarts (restarts s)
(cond ((null restarts)

3
src/code/early-impl.lisp
View file

@ -22,6 +22,9 @@
*current-catch-block*
*current-unwind-protect-block*
sb!vm::*alien-stack*
#!+sb-thread sb!thread::*foreground-thread-stack*
sb!vm::*control-stack-start*
sb!vm::*binding-stack-start*
;; FIXME: The pseudo-atomic variable stuff should be
;; conditional on :SB-PSEUDO-ATOMIC-SYMBOLS, which
;; should be conditional on :X86, instead of the

9
src/code/exhaust.lisp
View file

@ -11,6 +11,11 @@
;;;; files for more information.
(in-package "SB!KERNEL")
(define-alien-routine "protect_control_stack_guard_page"
sb!alien:int (protect-p sb!alien:int))
(define-alien-routine ("protect_control_stack_guard_page"
%protect-control-stack-guard-page)
sb!alien:int (thread-id sb!alien:int) (protect-p sb!alien:int))
(defun protect-control-stack-guard-page (n)
(%protect-control-stack-guard-page
(sb!thread:current-thread-id) (if n 1 0)))

13
src/code/gc.lisp
View file

@ -280,10 +280,21 @@ function should notify the user that the system has finished GC'ing.")
(sb!alien:define-alien-routine clear-auto-gc-trigger sb!alien:void)
#!+sb-thread
(def-c-var-frob gc-thread-pid "gc_thread_pid")
#!+sb-thread
(defun other-thread-collect-garbage (gen)
(setf (sb!alien:extern-alien "maybe_gc_pending" (sb!alien:unsigned 32))
(1+ gen))
(sb!unix:unix-kill (gc-thread-pid) :SIGALRM))
;;; This variable contains the function that does the real GC. This is
;;; for low-level GC experimentation. Do not touch it if you do not
;;; know what you are doing.
(defvar *internal-gc* #'collect-garbage)
(defvar *internal-gc*
#!+sb-thread #'other-thread-collect-garbage
#!-sb-thread #'collect-garbage)
;;;; SUB-GC

40
src/code/load.lisp
View file

@ -16,6 +16,12 @@
(in-package "SB!FASL")
;;;; There looks to be an exciting amount of state being modified
;;;; here: certainly enough that I (dan, 2003.1.22) don't want to mess
;;;; around deciding how to thread-safetify it. So we use a Big Lock.
;;;; Because this code is mutually recursive with the compiler, we use
;;;; the *big-compiler-lock*
;;;; miscellaneous load utilities
;;; Output the current number of semicolons after a fresh-line.
@ -327,25 +333,21 @@
(when (zerop (file-length stream))
(error "attempt to load an empty FASL file:~% ~S" (namestring stream)))
(maybe-announce-load stream verbose)
(let* ((*fasl-input-stream* stream)
(*current-fop-table* (or (pop *free-fop-tables*) (make-array 1000)))
(*current-fop-table-size* (length *current-fop-table*))
(*fop-stack-pointer-on-entry* *fop-stack-pointer*))
(unwind-protect
;; FIXME: This should probably become
;; (LOOP WHILE (LOAD-FASL-GROUP-STREAM))
;; but as a LOOP newbie I don't want to do that until I can
;; test it.
(do ((loaded-group (load-fasl-group stream) (load-fasl-group stream)))
((not loaded-group)))
(setq *fop-stack-pointer* *fop-stack-pointer-on-entry*)
(push *current-fop-table* *free-fop-tables*)
;; NIL out the stack and table, so that we don't hold onto garbage.
;;
;; FIXME: Couldn't we just get rid of the free fop table pool so
;; that some of this NILing out would go away?
(fill *fop-stack* nil :end *fop-stack-pointer-on-entry*)
(fill *current-fop-table* nil)))
(sb!thread:with-recursive-lock (sb!c::*big-compiler-lock*)
(let* ((*fasl-input-stream* stream)
(*current-fop-table* (or (pop *free-fop-tables*) (make-array 1000)))
(*current-fop-table-size* (length *current-fop-table*))
(*fop-stack-pointer-on-entry* *fop-stack-pointer*))
(unwind-protect
(loop while (load-fasl-group stream))
(setq *fop-stack-pointer* *fop-stack-pointer-on-entry*)
(push *current-fop-table* *free-fop-tables*)
;; NIL out the stack and table, so that we don't hold onto garbage.
;;
;; FIXME: Couldn't we just get rid of the free fop table pool so
;; that some of this NILing out would go away?
(fill *fop-stack* nil :end *fop-stack-pointer-on-entry*)
(fill *current-fop-table* nil))))
t)
;;; This is used in in target-load and also genesis, using

6
src/code/symbol.lisp
View file

@ -35,8 +35,10 @@
(about-to-modify-symbol-value symbol)
(%set-symbol-value symbol new-value))
(defun %set-symbol-value (symbol new-value)
(%set-symbol-value symbol new-value))
;;; can't do this yet, the appropriate vop only gets defined in
;;; compiler/target/cell, 400 lines hence
;;;(defun %set-symbol-value (symbol new-value)
;;; (%set-symbol-value symbol new-value))
(defun makunbound (symbol)
#!+sb-doc

24
src/code/sysmacs.lisp
View file

@ -10,24 +10,30 @@
;;;; files for more information.
(in-package "SB!IMPL")
#!-sb-thread
(defmacro atomic-incf (symbol-name &optional (delta 1))
`(incf ,symbol-name ,delta))
(defmacro atomic-decf (place &optional (delta 1))
`(atomic-incf ,place ,(- delta)))
;;; FIXME Not the most sensible way to do this: we could just use
;;; LOCK ADD, given that we don't need the old version. This will
;;; do until we get around to writing new VOPs
;;; FIXME in fact we're not SMP-safe without LOCK anyway, but
;;; this will do us for UP systems
(defmacro atomic-incf/symbol (symbol-name &optional (delta 1))
#!-sb-thread
`(incf ,symbol-name ,delta)
#!+sb-thread
`(locally
(declare (optimize (safety 0) (speed 3)))
(sb!vm::fast-symbol-global-value-xadd ',symbol-name ,delta)
,symbol-name))
(defmacro without-gcing (&rest body)
#!+sb-doc
"Executes the forms in the body without doing a garbage collection."
`(unwind-protect
(progn
(atomic-incf *gc-inhibit*)
(atomic-incf/symbol *gc-inhibit*)
,@body)
(atomic-decf *gc-inhibit*)
(atomic-incf/symbol *gc-inhibit* -1)
(when (and *need-to-collect-garbage* (zerop *gc-inhibit*))
(maybe-gc nil))))

23
src/code/thread.lisp
View file

@ -1,14 +1,7 @@
(in-package :sb!thread)
#+sb-xc-host
(defun make-mutex (&key name value) nil)
#+sb-xc-host
(defmacro with-recursive-lock ((mutex) &body body)
`(progn ,@body))
#-sb-xc-host
(defmacro with-recursive-lock ((mutex) &body body)
(sb!xc:defmacro with-recursive-lock ((mutex) &body body)
#!+sb-thread
(let ((cfp (gensym "CFP")))
`(let ((,cfp (ash (sb!sys:sap-int (sb!vm::current-fp) ) -2)))
(unless (and (mutex-value ,mutex)
@ -17,15 +10,23 @@
(get-mutex ,mutex ,cfp))
(unwind-protect
(progn ,@body)
(when (eql (mutex-value ,mutex) ,cfp) (release-mutex ,mutex))))))
(when (eql (mutex-value ,mutex) ,cfp) (release-mutex ,mutex)))))
#!-sb-thread
`(progn ,@body))
#!+sb-thread
(defun get-foreground ()
(when (not (eql (mutex-value *session-lock*) (CURRENT-THREAD-ID)))
(when (not (eql (mutex-value *session-lock*) (current-thread-id)))
(get-mutex *session-lock*))
(sb!sys:enable-interrupt :sigint #'sb!unix::sigint-handler)
t)
#!-sb-thread
(defun get-foreground () t)
#!+sb-thread
(defun release-foreground ()
(sb!sys:enable-interrupt :sigint :ignore)
(release-mutex *session-lock*)
t)
#!-sb-thread
(defun release-foreground () t)

5
src/code/toplevel.lisp
View file

@ -206,7 +206,7 @@
#!+stack-grows-downward-not-upward
(let* ((csp (sap-int (sb!c::control-stack-pointer-sap)))
(end-of-stack (+ sb!vm:control-stack-start sb!c:*backend-page-size*))
(end-of-stack (+ sb!vm::*control-stack-start* sb!c:*backend-page-size*))
(initial-offset (logand csp (1- bytes-per-scrub-unit))))
(labels
((scrub (ptr offset count)
@ -296,7 +296,8 @@
(defun toplevel-init ()
(/show0 "entering TOPLEVEL-INIT")
(setf sb!thread::*session-lock* (sb!thread:make-mutex :name "the terminal"))
(sb!thread::get-foreground)
(let ((sysinit nil) ; value of --sysinit option
(userinit nil) ; value of --userinit option
(reversed-evals nil) ; values of --eval options, in reverse order; and

29
src/compiler/generic/objdef.lisp
View file

@ -326,7 +326,7 @@
;; subtract 3 from (sb-kernel:get-lisp-obj-address 'NIL) you get the
;; first data slot, and if you subtract 7 you get a symbol header.
(value :set-trans %set-symbol-value
(value #!-sb-thread :set-trans #!-sb-thread %set-symbol-value
:init :unbound) ;also the CAR of NIL-as-end-of-list
(hash) ;the CDR of NIL-as-end-of-list
@ -336,7 +336,8 @@
(name :ref-trans symbol-name :init :arg)
(package :ref-trans symbol-package
:set-trans %set-symbol-package
:init :null))
:init :null)
#!+sb-thread (tls-index))
(define-primitive-object (complex-single-float
:lowtag other-pointer-lowtag
@ -359,3 +360,27 @@
(real :c-type "long double" :length #!+x86 3 #!+sparc 4)
(imag :c-type "long double" :length #!+x86 3 #!+sparc 4))
;;; this isn't actually a lisp object at all, it's a c structure that lives
;;; in c-land. However, we need sight of so many parts of it from Lisp that
;;; it makes sense to define it here anyway, so that the GENESIS machinery
;;; can take care of maintaining Lisp and C versions.
;;; Hence the even-fixnum lowtag just so we don't get odd(sic) numbers
;;; added to the slot offsets
(define-primitive-object (thread :lowtag even-fixnum-lowtag)
;; unbound_marker is borrowed very briefly at thread startup to
;; pass the address of initial-function into new_thread_trampoline
(unbound-marker :init :unbound) ; tls[0] = UNBOUND_MARKER_WIDETAG
(binding-stack-start :c-type "lispobj *")
(binding-stack-pointer :c-type "lispobj *")
(control-stack-start :c-type "lispobj *")
(alien-stack-start :c-type "lispobj *")
(alien-stack-pointer :c-type "lispobj *")
(alloc-region :c-type "struct alloc_region" :length 5)
(pid :c-type "pid_t")
(tls-cookie) ; on x86, the LDT index
(this :c-type "struct thread *")
(next :c-type "struct thread *")
(pseudo-atomic-atomic)
(pseudo-atomic-interrupted)
(interrupt-data :c-type "struct interrupt_data *")
(interrupt-contexts :c-type "os_context_t *" :rest-p t))

28
src/compiler/main.lisp
View file

@ -87,6 +87,11 @@
;;; normally causes nested uses to be no-ops).
(defvar *in-compilation-unit* nil)
;;; This lock is siezed in the same situation: the compiler is not
;;; presently thread-safe
(defvar *big-compiler-lock*
(sb!thread:make-mutex :name "big compiler lock"))
;;; Count of the number of compilation units dynamically enclosed by
;;; the current active WITH-COMPILATION-UNIT that were unwound out of.
(defvar *aborted-compilation-unit-count*)
@ -127,7 +132,7 @@
;; Inside another WITH-COMPILATION-UNIT, a WITH-COMPILATION-UNIT is
;; ordinarily (unless OVERRIDE) basically a no-op.
(unwind-protect
(multiple-value-prog1 (funcall fn) (setf succeeded-p t))
(multiple-value-prog1 (funcall fn) (setf succeeded-p t))
(unless succeeded-p
(incf *aborted-compilation-unit-count*)))
;; FIXME: Now *COMPILER-FOO-COUNT* stuff is bound in more than
@ -140,16 +145,17 @@
(*compiler-note-count* 0)
(*undefined-warnings* nil)
(*in-compilation-unit* t))
(handler-bind ((parse-unknown-type
(lambda (c)
(note-undefined-reference
(parse-unknown-type-specifier c)
:type))))
(unwind-protect
(multiple-value-prog1 (funcall fn) (setf succeeded-p t))
(unless succeeded-p
(incf *aborted-compilation-unit-count*))
(summarize-compilation-unit (not succeeded-p))))))))
(sb!thread:with-recursive-lock (*big-compiler-lock*)
(handler-bind ((parse-unknown-type
(lambda (c)
(note-undefined-reference
(parse-unknown-type-specifier c)
:type))))
(unwind-protect
(multiple-value-prog1 (funcall fn) (setf succeeded-p t))
(unless succeeded-p
(incf *aborted-compilation-unit-count*))
(summarize-compilation-unit (not succeeded-p)))))))))
;;; This is to be called at the end of a compilation unit. It signals
;;; any residual warnings about unknown stuff, then prints the total

50
src/compiler/x86/c-call.lisp
View file

@ -209,27 +209,57 @@
(define-vop (alloc-alien-stack-space)
(:info amount)
#!+sb-thread (:temporary (:sc unsigned-reg) temp)
(:results (result :scs (sap-reg any-reg)))
#!+sb-thread
(:generator 0
(aver (not (location= result esp-tn)))
(unless (zerop amount)
(let ((delta (logandc2 (+ amount 3) 3)))
(inst sub (make-ea :dword
:disp (+ nil-value
(static-symbol-offset '*alien-stack*)
(ash symbol-value-slot word-shift)
(- other-pointer-lowtag)))
delta)))
(inst mov temp
(make-ea :dword
:disp (+ nil-value
(static-symbol-offset '*alien-stack*)
(ash symbol-tls-index-slot word-shift)
(- other-pointer-lowtag))))
(inst fs-segment-prefix)
(inst sub (make-ea :dword :scale 1 :index temp) delta)))
(load-tl-symbol-value result *alien-stack*))
#!-sb-thread
(:generator 0
(aver (not (location= result esp-tn)))
(unless (zerop amount)
(let ((delta (logandc2 (+ amount 3) 3)))
(inst sub (make-ea :dword
:disp (+ nil-value
(static-symbol-offset '*alien-stack*)
(ash symbol-value-slot word-shift)
(- other-pointer-lowtag)))
delta)))
(load-symbol-value result *alien-stack*)))
(define-vop (dealloc-alien-stack-space)
(:info amount)
#!+sb-thread (:temporary (:sc unsigned-reg) temp)
#!+sb-thread
(:generator 0
(unless (zerop amount)
(let ((delta (logandc2 (+ amount 3) 3)))
(inst add (make-ea :dword
(inst mov temp
(make-ea :dword
:disp (+ nil-value
(static-symbol-offset '*alien-stack*)
(ash symbol-value-slot word-shift)
(- other-pointer-lowtag)))
delta)))))
(ash symbol-tls-index-slot word-shift)
(- other-pointer-lowtag))))
(inst fs-segment-prefix)
(inst add (make-ea :dword :scale 1 :index temp) delta))))
#!-sb-thread
(:generator 0
(unless (zerop amount)
(let ((delta (logandc2 (+ amount 3) 3)))
(inst add (make-ea :dword
:disp (+ nil-value
(static-symbol-offset '*alien-stack*)
(ash symbol-value-slot word-shift)
(- other-pointer-lowtag)))
delta)))))

186
src/compiler/x86/cell.lisp
View file

@ -50,16 +50,45 @@
;; Else, value not immediate.
(storew value object offset lowtag))))
;;;; symbol hacking VOPs
;;; these next two cf the sparc version, by jrd.
;;; FIXME: Deref this ^ reference.
;;; The compiler likes to be able to directly SET symbols.
#!+sb-thread
(define-vop (set)
(:args (symbol :scs (descriptor-reg))
(value :scs (descriptor-reg any-reg)))
(:translate sb!kernel:%set-symbol-value)
(:temporary (:sc descriptor-reg ) tls)
;;(:policy :fast-safe)
(:generator 4
(let ((global-val (gen-label))
(done (gen-label)))
(loadw tls symbol symbol-tls-index-slot other-pointer-lowtag)
(inst or tls tls)
(inst jmp :z global-val)
(inst fs-segment-prefix)
(inst cmp (make-ea :dword :scale 1 :index tls) unbound-marker-widetag)
(inst jmp :z global-val)
(inst fs-segment-prefix)
(inst mov (make-ea :dword :scale 1 :index tls) value)
(inst jmp done)
(emit-label global-val)
(storew value symbol symbol-value-slot other-pointer-lowtag)
(emit-label done))))
;; unithreaded it's a lot simpler ...
#!-sb-thread
(define-vop (set cell-set)
(:variant symbol-value-slot other-pointer-lowtag))
;;; Do a cell ref with an error check for being unbound.
;;; XXX stil used? I can't see where -dan
(define-vop (checked-cell-ref)
(:args (object :scs (descriptor-reg) :target obj-temp))
(:results (value :scs (descriptor-reg any-reg)))
@ -70,6 +99,33 @@
;;; With Symbol-Value, we check that the value isn't the trap object. So
;;; Symbol-Value of NIL is NIL.
#!+sb-thread
(define-vop (symbol-value)
(:translate symbol-value)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg) :to (:result 1)))
(:results (value :scs (descriptor-reg any-reg)))
(:vop-var vop)
(:save-p :compute-only)
(:generator 9
(let* ((err-lab (generate-error-code vop unbound-symbol-error object))
(ret-lab (gen-label)))
(loadw value object symbol-tls-index-slot other-pointer-lowtag)
(inst fs-segment-prefix)
(inst mov value (make-ea :dword :index value :scale 1))
(inst cmp value unbound-marker-widetag)
(inst jmp :ne ret-lab)
(loadw value object symbol-value-slot other-pointer-lowtag)
(inst cmp value unbound-marker-widetag)
(inst jmp :e err-lab)
(emit-label ret-lab))))
#!+sb-thread
(define-vop (fast-symbol-value symbol-value)
(:policy :fast)
(:translate symbol-value))
#!-sb-thread
(define-vop (symbol-value)
(:translate symbol-value)
(:policy :fast-safe)
@ -83,18 +139,49 @@
(inst cmp value unbound-marker-widetag)
(inst jmp :e err-lab))))
#!-sb-thread
(define-vop (fast-symbol-value cell-ref)
(:variant symbol-value-slot other-pointer-lowtag)
(:policy :fast)
(:translate symbol-value))
(defknown fast-symbol-value-xadd (symbol fixnum) fixnum ())
(define-vop (fast-symbol-value-xadd cell-xadd)
(defknown fast-symbol-global-value-xadd (symbol fixnum) fixnum ())
(define-vop (fast-symbol-global-value-xadd cell-xadd)
(:variant symbol-value-slot other-pointer-lowtag)
(:policy :fast)
(:translate fast-symbol-value-xadd)
(:translate fast-symbol-global-value-xadd)
(:arg-types * tagged-num))
#!+sb-thread
(define-vop (boundp)
(:translate boundp)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg)))
(:conditional)
(:info target not-p)
(:temporary (:sc descriptor-reg #+nil(:from (:argument 0))) value)
(:generator 9
(if not-p
(let ((not-target (gen-label)))
(loadw value object symbol-value-slot other-pointer-lowtag)
(inst cmp value unbound-marker-widetag)
(inst jmp :ne not-target)
(loadw value object symbol-tls-index-slot other-pointer-lowtag)
(inst fs-segment-prefix)
(inst cmp (make-ea :dword :index value :scale 1) unbound-marker-widetag)
(inst jmp :e target)
(emit-label not-target))
(progn
(loadw value object symbol-value-slot other-pointer-lowtag)
(inst cmp value unbound-marker-widetag)
(inst jmp :ne target)
(loadw value object symbol-tls-index-slot other-pointer-lowtag)
(inst fs-segment-prefix)
(inst cmp (make-ea :dword :index value :scale 1) unbound-marker-widetag)
(inst jmp :ne target)))))
#!-sb-thread
(define-vop (boundp)
(:translate boundp)
(:policy :fast-safe)
@ -107,6 +194,7 @@
(inst cmp value unbound-marker-widetag)
(inst jmp (if not-p :e :ne) target)))
(define-vop (symbol-hash)
(:policy :fast-safe)
(:translate symbol-hash)
@ -176,9 +264,38 @@
;;; the symbol on the binding stack and stuff the new value into the
;;; symbol.
#!+sb-thread
(define-vop (bind)
(:args (val :scs (any-reg descriptor-reg))
(symbol :scs (descriptor-reg)))
(:temporary (:sc unsigned-reg) tls-index temp bsp)
(:generator 5
(let ((tls-index-valid (gen-label)))
(load-tl-symbol-value bsp *binding-stack-pointer*)
(loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
(inst add bsp (* binding-size n-word-bytes))
(store-tl-symbol-value bsp *binding-stack-pointer* temp)
(inst or tls-index tls-index)
(inst jmp :ne tls-index-valid)
;; allocate a new tls-index
(load-symbol-value tls-index *free-tls-index*)
(inst add tls-index 4) ;XXX surely we can do this more
(store-symbol-value tls-index *free-tls-index*) ;succintly
(inst sub tls-index 4)
(storew tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
(emit-label tls-index-valid)
(inst fs-segment-prefix)
(inst mov temp (make-ea :dword :scale 1 :index tls-index))
(storew temp bsp (- binding-value-slot binding-size))
(storew symbol bsp (- binding-symbol-slot binding-size))
(inst fs-segment-prefix)
(inst mov (make-ea :dword :scale 1 :index tls-index) val))))
#!-sb-thread
(define-vop (bind)
(:args (val :scs (any-reg descriptor-reg))
(symbol :scs (descriptor-reg)))
(:temporary (:sc unsigned-reg) temp bsp)
(:generator 5
(load-symbol-value bsp *binding-stack-pointer*)
@ -189,6 +306,26 @@
(storew symbol bsp (- binding-symbol-slot binding-size))
(storew val symbol symbol-value-slot other-pointer-lowtag)))
#!+sb-thread
(define-vop (unbind)
;; four temporaries?
(:temporary (:sc unsigned-reg) symbol value bsp tls-index)
(:generator 0
(load-tl-symbol-value bsp *binding-stack-pointer*)
(loadw symbol bsp (- binding-symbol-slot binding-size))
(loadw value bsp (- binding-value-slot binding-size))
(loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
(inst fs-segment-prefix)
(inst mov (make-ea :dword :scale 1 :index tls-index) value)
(storew 0 bsp (- binding-symbol-slot binding-size))
(inst sub bsp (* binding-size n-word-bytes))
;; we're done with value, so we can use it as a temp here
(store-tl-symbol-value bsp *binding-stack-pointer* value)))
#!-sb-thread
(define-vop (unbind)
(:temporary (:sc unsigned-reg) symbol value bsp)
(:generator 0
@ -200,11 +337,12 @@
(inst sub bsp (* binding-size n-word-bytes))
(store-symbol-value bsp *binding-stack-pointer*)))
(define-vop (unbind-to-here)
(:args (where :scs (descriptor-reg any-reg)))
(:temporary (:sc unsigned-reg) symbol value bsp)
(:temporary (:sc unsigned-reg) symbol value bsp #!+sb-thread tls-index)
(:generator 0
(load-symbol-value bsp *binding-stack-pointer*)
(load-tl-symbol-value bsp *binding-stack-pointer*)
(inst cmp where bsp)
(inst jmp :e done)
@ -213,17 +351,25 @@
(inst or symbol symbol)
(inst jmp :z skip)
(loadw value bsp (- binding-value-slot binding-size))
(storew value symbol symbol-value-slot other-pointer-lowtag)
#!-sb-thread (storew value symbol symbol-value-slot other-pointer-lowtag)
#!+sb-thread (loadw
tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
#!+sb-thread (inst fs-segment-prefix)
#!+sb-thread (inst mov (make-ea :dword :scale 1 :index tls-index) value)
(storew 0 bsp (- binding-symbol-slot binding-size))
SKIP
(inst sub bsp (* binding-size n-word-bytes))
(inst cmp where bsp)
(inst jmp :ne loop)
(store-symbol-value bsp *binding-stack-pointer*)
;; we're done with value, so can use it as a temporary
(store-tl-symbol-value bsp *binding-stack-pointer* value)
DONE))
;;;; closure indexing
(define-full-reffer closure-index-ref *
@ -284,6 +430,32 @@
(define-full-setter instance-index-set * instance-slots-offset
instance-pointer-lowtag (any-reg descriptor-reg) * %instance-set)
(defknown %instance-set-conditional (instance index t t) t
(unsafe))
(define-vop (instance-set-conditional)
(:translate %instance-set-conditional)
(:args (object :scs (descriptor-reg) :to :eval)
(slot :scs (any-reg) :to :result)
(old-value :scs (descriptor-reg any-reg) :target eax)
(new-value :scs (descriptor-reg any-reg)))
(:arg-types instance positive-fixnum * *)
(:temporary (:sc descriptor-reg :offset eax-offset
:from (:argument 2) :to :result :target result) eax)
(:results (result :scs (descriptor-reg any-reg)))
;(:guard (backend-featurep :i486))
(:policy :fast-safe)
(:generator 5
(move eax old-value)
(inst cmpxchg (make-ea :dword :base object :index slot :scale 1
:disp (- (* instance-slots-offset n-word-bytes)
instance-pointer-lowtag))
new-value)
(move result eax)))
;;;; code object frobbing

90
src/compiler/x86/macros.lisp
View file

@ -84,7 +84,35 @@
(- other-pointer-lowtag)))
,reg))
#!+sb-thread
(defmacro load-tl-symbol-value (reg symbol)
`(progn
(inst mov ,reg
(make-ea :dword
:disp (+ nil-value
(static-symbol-offset ',symbol)
(ash symbol-tls-index-slot word-shift)
(- other-pointer-lowtag))))
(inst fs-segment-prefix)
(inst mov ,reg (make-ea :dword :scale 1 :index ,reg))))
#!-sb-thread
(defmacro load-tl-symbol-value (reg symbol) `(load-symbol-value ,reg ,symbol))
#!+sb-thread
(defmacro store-tl-symbol-value (reg symbol temp)
`(progn
(inst mov ,temp
(make-ea :dword
:disp (+ nil-value
(static-symbol-offset ',symbol)
(ash symbol-tls-index-slot word-shift)
(- other-pointer-lowtag))))
(inst fs-segment-prefix)
(inst mov (make-ea :dword :scale 1 :index ,temp) ,reg)))
#!-sb-thread
(defmacro store-tl-symbol-value (reg symbol temp)
`(store-symbol-value ,reg ,symbol))
(defmacro load-type (target source &optional (offset 0))
#!+sb-doc
"Loads the type bits of a pointer into target independent of
@ -277,31 +305,53 @@
;;; FIXME: It appears that PSEUDO-ATOMIC is used to wrap operations which leave
;;; untagged memory lying around, but some documentation would be nice.
#!+sb-thread
(defmacro pseudo-atomic (&rest forms)
(let ((label (gensym "LABEL-")))
`(let ((,label (gen-label)))
(inst fs-segment-prefix)
(inst mov (make-ea :byte :disp (* 4 thread-pseudo-atomic-atomic-slot)) 1)
(inst fs-segment-prefix)
(inst mov (make-ea :byte
:disp (* 4 thread-pseudo-atomic-interrupted-slot)) 0)
,@forms
(inst fs-segment-prefix)
(inst mov (make-ea :byte :disp (* 4 thread-pseudo-atomic-atomic-slot)) 0)
(inst fs-segment-prefix)
(inst cmp (make-ea :byte
:disp (* 4 thread-pseudo-atomic-interrupted-slot)) 0)
(inst jmp :eq ,label)
;; if PAI was set, interrupts were disabled at the same time
;; using the process signal mask.
(inst break pending-interrupt-trap)
(emit-label ,label))))
#!-sb-thread
(defmacro pseudo-atomic (&rest forms)
(let ((label (gensym "LABEL-")))
`(let ((,label (gen-label)))
;; FIXME: The MAKE-EA noise should become a MACROLET macro or
;; something. (perhaps SVLB, for static variable low byte)
(inst mov (make-ea :byte :disp (+ nil-value
(static-symbol-offset
'*pseudo-atomic-interrupted*)
(ash symbol-value-slot word-shift)
;; FIXME: Use mask, not minus, to
;; take out type bits.
(- other-pointer-lowtag)))
(static-symbol-offset
'*pseudo-atomic-interrupted*)
(ash symbol-value-slot word-shift)
;; FIXME: Use mask, not minus, to
;; take out type bits.
(- other-pointer-lowtag)))
0)
(inst mov (make-ea :byte :disp (+ nil-value
(static-symbol-offset
'*pseudo-atomic-atomic*)
(ash symbol-value-slot word-shift)
(- other-pointer-lowtag)))
(static-symbol-offset
'*pseudo-atomic-atomic*)
(ash symbol-value-slot word-shift)
(- other-pointer-lowtag)))
(fixnumize 1))
,@forms
(inst mov (make-ea :byte :disp (+ nil-value
(static-symbol-offset
'*pseudo-atomic-atomic*)
(ash symbol-value-slot word-shift)
(- other-pointer-lowtag)))
(static-symbol-offset
'*pseudo-atomic-atomic*)
(ash symbol-value-slot word-shift)
(- other-pointer-lowtag)))
0)
;; KLUDGE: Is there any requirement for interrupts to be
;; handled in order? It seems as though an interrupt coming
@ -310,17 +360,19 @@
;; are pending? I wish I could find the documentation for
;; pseudo-atomics.. -- WHN 19991130
(inst cmp (make-ea :byte
:disp (+ nil-value
(static-symbol-offset
'*pseudo-atomic-interrupted*)
(ash symbol-value-slot word-shift)
(- other-pointer-lowtag)))
:disp (+ nil-value
(static-symbol-offset
'*pseudo-atomic-interrupted*)
(ash symbol-value-slot word-shift)
(- other-pointer-lowtag)))
0)
(inst jmp :eq ,label)
;; if PAI was set, interrupts were disabled at the same time
;; using the process signal mask.
(inst break pending-interrupt-trap)
(emit-label ,label))))
;;;; indexed references

35
src/compiler/x86/nlx.lisp
View file

@ -44,15 +44,16 @@
(:results (catch :scs (descriptor-reg))
(alien-stack :scs (descriptor-reg)))
(:generator 13
(load-symbol-value catch *current-catch-block*)
(load-symbol-value alien-stack *alien-stack*)))
(load-tl-symbol-value catch *current-catch-block*)
(load-tl-symbol-value alien-stack *alien-stack*)))
(define-vop (restore-dynamic-state)
(:args (catch :scs (descriptor-reg))
(alien-stack :scs (descriptor-reg)))
#!+sb-thread (:temporary (:sc unsigned-reg) temp)
(:generator 10
(store-symbol-value catch *current-catch-block*)
(store-symbol-value alien-stack *alien-stack*)))
(store-tl-symbol-value catch *current-catch-block* temp)
(store-tl-symbol-value alien-stack *alien-stack* temp)))
(define-vop (current-stack-pointer)
(:results (res :scs (any-reg control-stack)))
@ -62,7 +63,7 @@
(define-vop (current-binding-pointer)
(:results (res :scs (any-reg descriptor-reg)))
(:generator 1
(load-symbol-value res *binding-stack-pointer*)))
(load-tl-symbol-value res *binding-stack-pointer*)))
;;;; unwind block hackery
@ -75,7 +76,7 @@
(:results (block :scs (any-reg)))
(:generator 22
(inst lea block (catch-block-ea tn))
(load-symbol-value temp *current-unwind-protect-block*)
(load-tl-symbol-value temp *current-unwind-protect-block*)
(storew temp block unwind-block-current-uwp-slot)
(storew ebp-tn block unwind-block-current-cont-slot)
(storew (make-fixup nil :code-object entry-label)
@ -91,42 +92,42 @@
(:temporary (:sc descriptor-reg) temp)
(:generator 44
(inst lea block (catch-block-ea tn))
(load-symbol-value temp *current-unwind-protect-block*)
(load-tl-symbol-value temp *current-unwind-protect-block*)
(storew temp block unwind-block-current-uwp-slot)
(storew ebp-tn block unwind-block-current-cont-slot)
(storew (make-fixup nil :code-object entry-label)
block catch-block-entry-pc-slot)
(storew tag block catch-block-tag-slot)
(load-symbol-value temp *current-catch-block*)
(load-tl-symbol-value temp *current-catch-block*)
(storew temp block catch-block-previous-catch-slot)
(store-symbol-value block *current-catch-block*)))
(store-tl-symbol-value block *current-catch-block* temp)))
;;; Just set the current unwind-protect to TN's address. This instantiates an
;;; unwind block as an unwind-protect.
(define-vop (set-unwind-protect)
(:args (tn))
(:temporary (:sc unsigned-reg) new-uwp)
(:temporary (:sc unsigned-reg) new-uwp #!+sb-thread tls)
(:generator 7
(inst lea new-uwp (catch-block-ea tn))
(store-symbol-value new-uwp *current-unwind-protect-block*)))
(store-tl-symbol-value new-uwp *current-unwind-protect-block* tls)))
(define-vop (unlink-catch-block)
(:temporary (:sc unsigned-reg) block)
(:temporary (:sc unsigned-reg) #!+sb-thread tls block)
(:policy :fast-safe)
(:translate %catch-breakup)
(:generator 17
(load-symbol-value block *current-catch-block*)
(load-tl-symbol-value block *current-catch-block*)
(loadw block block catch-block-previous-catch-slot)
(store-symbol-value block *current-catch-block*)))
(store-tl-symbol-value block *current-catch-block* tls)))
(define-vop (unlink-unwind-protect)
(:temporary (:sc unsigned-reg) block)
(:temporary (:sc unsigned-reg) block #!+sb-thread tls)
(:policy :fast-safe)
(:translate %unwind-protect-breakup)
(:generator 17
(load-symbol-value block *current-unwind-protect-block*)
(load-tl-symbol-value block *current-unwind-protect-block*)
(loadw block block unwind-block-current-uwp-slot)
(store-symbol-value block *current-unwind-protect-block*)))
(store-tl-symbol-value block *current-unwind-protect-block* tls)))
;;;; NLX entry VOPs
(define-vop (nlx-entry)

19
src/compiler/x86/parms.lisp
View file

@ -144,11 +144,6 @@
(def!constant dynamic-space-start #x09000000)
(def!constant dynamic-space-end #x29000000)
(def!constant control-stack-start #x50000000)
(def!constant control-stack-end #x57fff000)
(def!constant binding-stack-start #x60000000)
(def!constant binding-stack-end #x67fff000)
(def!constant alternate-signal-stack-start #x58000000))
#!+bsd
@ -162,15 +157,6 @@
#!+openbsd #x28000000)
(def!constant static-space-end #x37fff000)
(def!constant binding-stack-start #x38000000)
(def!constant binding-stack-end #x3ffff000)
(def!constant control-stack-start
#!+freebsd #x40000000
#!+openbsd #x48000000)
(def!constant control-stack-end
#!+freebsd #x43fff000
#!+openbsd #x4bfff000)
(def!constant dynamic-space-start
#!+freebsd #x48000000
#!+openbsd #x50000000)
@ -268,8 +254,13 @@
sb!unix::*interrupt-pending*
*free-interrupt-context-index*
*free-tls-index*
sb!thread::*foreground-thread-stack*
*allocation-pointer*
*binding-stack-pointer*
*binding-stack-start*
*control-stack-start*
;; the floating point constants
*fp-constant-0d0*

25
src/compiler/x86/system.lisp
View file

@ -163,7 +163,7 @@
(:translate binding-stack-pointer-sap)
(:policy :fast-safe)
(:generator 1
(load-symbol-value int *binding-stack-pointer*)))
(load-tl-symbol-value int *binding-stack-pointer*)))
(defknown (setf binding-stack-pointer-sap)
(system-area-pointer) system-area-pointer ())
@ -173,10 +173,11 @@
(:arg-types system-area-pointer)
(:results (int :scs (sap-reg)))
(:result-types system-area-pointer)
#!+sb-thread (:temporary (:sc any-reg) temp)
(:translate (setf binding-stack-pointer-sap))
(:policy :fast-safe)
(:generator 1
(store-symbol-value new-value *binding-stack-pointer*)
(store-tl-symbol-value new-value *binding-stack-pointer* temp)
(move int new-value)))
(define-vop (control-stack-pointer-sap)
@ -273,6 +274,26 @@
(:generator 1
(inst break pending-interrupt-trap)))
(defknown current-thread-offset-sap ((unsigned-byte 32))
system-area-pointer (flushable))
(define-vop (current-thread-offset-sap)
(:results (sap :scs (sap-reg)))
(:result-types system-area-pointer)
(:translate current-thread-offset-sap)
(:args (n :scs (unsigned-reg) #!+sb-thread :target #!+sb-thread sap))
#!-sb-thread (:temporary (:sc unsigned-reg :target sap) temp)
(:arg-types unsigned-num)
(:policy :fast-safe)
#!+sb-thread
(:generator 2
(inst fs-segment-prefix)
(inst mov sap (make-ea :dword :disp 0 :index n :scale 4)))
#!-sb-thread
(:generator 2
(inst mov temp (make-fixup (extern-alien-name "all_threads") :foreign))
(inst mov sap (make-ea :dword :base temp :index n :scale 4))))
(define-vop (halt)
(:generator 1
(inst break halt-trap)))

2
src/runtime/GNUmakefile
View file

@ -39,7 +39,7 @@ C_SRCS =alloc.c backtrace.c breakpoint.c coreparse.c \
dynbind.c gc-common.c globals.c interr.c interrupt.c \
monitor.c parse.c print.c purify.c \
regnames.c run-program.c runtime.c save.c search.c \
time.c util.c validate.c vars.c wrap.c
thread.c time.c util.c validate.c vars.c wrap.c
SRCS= $(C_SRCS) ${ARCH_SRC} ${ASSEM_SRC} ${OS_SRC} ${GC_SRC}

12
src/runtime/alloc.c
View file

@ -23,12 +23,11 @@
#include "alloc.h"
#include "globals.h"
#include "gc.h"
#include "genesis/static-symbols.h"
#include "thread.h"
#include "genesis/vector.h"
#include "genesis/cons.h"
#include "genesis/bignum.h"
#include "genesis/sap.h"
#include "genesis/symbol.h"
#define GET_FREE_POINTER() dynamic_space_free_pointer
#define SET_FREE_POINTER(new_value) \
@ -45,11 +44,12 @@ lispobj *
pa_alloc(int bytes)
{
lispobj *result=0;
SetSymbolValue(PSEUDO_ATOMIC_INTERRUPTED, make_fixnum(0));
SetSymbolValue(PSEUDO_ATOMIC_ATOMIC, make_fixnum(1));
struct thread *th=arch_os_get_current_thread();
SetSymbolValue(PSEUDO_ATOMIC_INTERRUPTED, make_fixnum(0),th);
SetSymbolValue(PSEUDO_ATOMIC_ATOMIC, make_fixnum(1),th);
result=alloc(bytes);
SetSymbolValue(PSEUDO_ATOMIC_ATOMIC, make_fixnum(0));
if (SymbolValue(PSEUDO_ATOMIC_INTERRUPTED))
SetSymbolValue(PSEUDO_ATOMIC_ATOMIC, make_fixnum(0),th);
if (SymbolValue(PSEUDO_ATOMIC_INTERRUPTED,th))
/* even if we gc at this point, the new allocation will be
* protected from being moved, because result is on the c stack
* and points to it */

8
src/runtime/backtrace.c
View file

@ -21,6 +21,9 @@
#include "os.h"
#include "interrupt.h"
#include "lispregs.h"
#ifdef LISP_FEATURE_GENCGC
#include "gencgc-alloc-region.h"
#endif
#include "genesis/static-symbols.h"
#include "genesis/primitive-objects.h"
@ -148,6 +151,7 @@ static int
previous_info(struct call_info *info)
{
struct call_frame *this_frame;
struct thread *thread=arch_os_get_current_thread();
int free;
if (!cs_valid_pointer_p(info->frame)) {
@ -165,10 +169,10 @@ previous_info(struct call_info *info)
if (info->lra == NIL) {
/* We were interrupted. Find the correct signal context. */
free = SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX)>>2;
free = SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX,thread)>>2;
while (free-- > 0) {
os_context_t *context =
lisp_interrupt_contexts[free];
thread->interrupt_contexts[free];
if ((struct call_frame *)(*os_context_register_addr(context,
reg_CFP))
== info->frame) {

3
src/runtime/breakpoint.c
View file

@ -21,10 +21,9 @@
#include "globals.h"
#include "alloc.h"
#include "breakpoint.h"
#include "thread.h"
#include "genesis/code.h"
#include "genesis/fdefn.h"
#include "genesis/symbol.h"
#include "genesis/static-symbols.h"
#define REAL_LRA_SLOT 0
#ifndef __i386__

5
src/runtime/coreparse.c
View file

@ -33,8 +33,7 @@
#include "arch.h"
#include "interr.h"
#include "sbcl.h"
#include "genesis/symbol.h"
#include "genesis/static-symbols.h"
#include "thread.h"
unsigned char build_id[] =
#include "../../output/build-id.tmp"
@ -94,7 +93,7 @@ process_directory(int fd, u32 *ptr, int count)
* defined(__i386__)
* ? */
#if defined(LISP_FEATURE_X86)
SetSymbolValue(ALLOCATION_POINTER, (lispobj)free_pointer);
SetSymbolValue(ALLOCATION_POINTER, (lispobj)free_pointer,0);
#else
dynamic_space_free_pointer = free_pointer;
#endif

40
src/runtime/dynbind.c
View file

@ -17,35 +17,44 @@
#include "sbcl.h"
#include "globals.h"
#include "dynbind.h"
#include "thread.h"
#include "genesis/symbol.h"
#include "genesis/binding.h"
#include "genesis/static-symbols.h"
#include "genesis/thread.h"
#if defined(__i386__)
#define GetBSP() ((struct binding *)SymbolValue(BINDING_STACK_POINTER))
#define SetBSP(value) SetSymbolValue(BINDING_STACK_POINTER, (lispobj)(value))
#define GetBSP() ((struct binding *)SymbolValue(BINDING_STACK_POINTER,thread))
#define SetBSP(value) SetSymbolValue(BINDING_STACK_POINTER, (lispobj)(value),thread)
#else
#define GetBSP() ((struct binding *)current_binding_stack_pointer)
#define SetBSP(value) (current_binding_stack_pointer=(lispobj *)(value))
#endif
void bind_variable(lispobj symbol, lispobj value)
void bind_variable(lispobj symbol, lispobj value, void *th)
{
lispobj old_value;
lispobj old_tl_value;
struct binding *binding;
old_value = SymbolValue(symbol);
struct thread *thread=(struct thread *)th;
struct symbol *sym=(struct symbol *)native_pointer(symbol);
binding = GetBSP();
SetBSP(binding+1);
binding->value = old_value;
#ifdef LISP_FEATURE_SB_THREAD
if(!sym->tls_index) {
sym->tls_index=SymbolValue(FREE_TLS_INDEX,0);
SetSymbolValue(FREE_TLS_INDEX,
make_fixnum(fixnum_value(sym->tls_index)+1),0);
}
#endif
old_tl_value=SymbolTlValue(symbol,thread);
binding->value = old_tl_value;
binding->symbol = symbol;
SetSymbolValue(symbol, value);
SetTlSymbolValue(symbol, value,thread);
}
void
unbind(void)
unbind(void *th)
{
struct thread *thread=(struct thread *)th;
struct binding *binding;
lispobj symbol;
@ -53,7 +62,7 @@ unbind(void)
symbol = binding->symbol;
SetSymbolValue(symbol, binding->value);
SetTlSymbolValue(symbol, binding->value,thread);
binding->symbol = 0;
@ -61,8 +70,9 @@ unbind(void)
}
void
unbind_to_here(lispobj *bsp)
unbind_to_here(lispobj *bsp,void *th)
{
struct thread *thread=(struct thread *)th;
struct binding *target = (struct binding *)bsp;
struct binding *binding = GetBSP();
lispobj symbol;
@ -71,12 +81,10 @@ unbind_to_here(lispobj *bsp)
binding--;
symbol = binding->symbol;
if (symbol) {
SetSymbolValue(symbol, binding->value);
SetTlSymbolValue(symbol, binding->value,thread);
binding->symbol = 0;
}
}
SetBSP(binding);
}

6
src/runtime/dynbind.h
View file

@ -12,8 +12,8 @@
#ifndef _DYNBIND_H_
#define _DYNBIND_H_
extern void bind_variable(lispobj symbol, lispobj value);
extern void unbind(void);
extern void unbind_to_here(lispobj *bsp);
extern void bind_variable(lispobj symbol, lispobj value,void *thread);
extern void unbind(void *thread);
extern void unbind_to_here(lispobj *bsp,void *thread);
#endif

3
src/runtime/gc.h
View file

@ -25,5 +25,6 @@ extern void collect_garbage(unsigned last_gen);
extern void set_auto_gc_trigger(os_vm_size_t usage);
extern void clear_auto_gc_trigger(void);
extern boolean maybe_gc_pending;
extern int maybe_gc_pending;
extern int gc_thread_pid;
#endif /* _GC_H_ */

166
src/runtime/gencgc.c
View file

@ -38,11 +38,10 @@
#include "arch.h"
#include "gc.h"
#include "gc-internal.h"
#include "thread.h"
#include "genesis/vector.h"
#include "genesis/weak-pointer.h"
#include "genesis/simple-fun.h"
#include "genesis/static-symbols.h"
#include "genesis/symbol.h"
/* assembly language stub that executes trap_PendingInterrupt */
void do_pending_interrupt(void);
@ -246,6 +245,13 @@ unsigned int gencgc_oldest_gen_to_gc = NUM_GENERATIONS-1;
* search of the heap. XX Gencgc obviously needs to be better
* integrated with the Lisp code. */
static int last_free_page;
/* This lock is to prevent multiple threads from simultaneously
* allocating new regions which overlap each other. Note that the
* majority of GC is single-threaded, but alloc() may be called
* from >1 thread at a time and must be thread-safe */
static lispobj free_pages_lock=0;
/*
* miscellaneous heap functions
@ -490,7 +496,7 @@ gc_alloc_new_region(int nbytes, int unboxed, struct alloc_region *alloc_region)
gc_assert((alloc_region->first_page == 0)
&& (alloc_region->last_page == -1)
&& (alloc_region->free_pointer == alloc_region->end_addr));
get_spinlock(&free_pages_lock,alloc_region);
if (unboxed) {
first_page =
generations[gc_alloc_generation].alloc_unboxed_start_page;
@ -510,20 +516,6 @@ gc_alloc_new_region(int nbytes, int unboxed, struct alloc_region *alloc_region)
alloc_region->free_pointer = alloc_region->start_addr;
alloc_region->end_addr = alloc_region->start_addr + bytes_found;
if (gencgc_zero_check) {
int *p;
for (p = (int *)alloc_region->start_addr;
p < (int *)alloc_region->end_addr; p++) {
if (*p != 0) {
/* KLUDGE: It would be nice to use %lx and explicit casts
* (long) in code like this, so that it is less likely to
* break randomly when running on a machine with different
* word sizes. -- WHN 19991129 */
lose("The new region at %x is not zero.", p);
}
}
}
/* Set up the pages. */
/* The first page may have already been in use. */
@ -559,13 +551,30 @@ gc_alloc_new_region(int nbytes, int unboxed, struct alloc_region *alloc_region)
alloc_region->start_addr - page_address(i);
page_table[i].allocated |= OPEN_REGION_PAGE ;
}
/* Bump up last_free_page. */
if (last_page+1 > last_free_page) {
last_free_page = last_page+1;
SetSymbolValue(ALLOCATION_POINTER,
(lispobj)(((char *)heap_base) + last_free_page*4096));
(lispobj)(((char *)heap_base) + last_free_page*4096),
0);
}
free_pages_lock=0;
/* we can do this after releasing free_pages_lock */
if (gencgc_zero_check) {
int *p;
for (p = (int *)alloc_region->start_addr;
p < (int *)alloc_region->end_addr; p++) {
if (*p != 0) {
/* KLUDGE: It would be nice to use %lx and explicit casts
* (long) in code like this, so that it is less likely to
* break randomly when running on a machine with different
* word sizes. -- WHN 19991129 */
lose("The new region at %x is not zero.", p);
}
}
}
}
/* If the record_new_objects flag is 2 then all new regions created
@ -836,6 +845,8 @@ gc_alloc_large(int nbytes, int unboxed, struct alloc_region *alloc_region)
index ahead of the current region and bumped up here to save a
lot of re-scanning. */
get_spinlock(&free_pages_lock,alloc_region);
if (unboxed) {
first_page =
generations[gc_alloc_generation].alloc_large_unboxed_start_page;
@ -932,8 +943,9 @@ gc_alloc_large(int nbytes, int unboxed, struct alloc_region *alloc_region)
if (last_page+1 > last_free_page) {
last_free_page = last_page+1;
SetSymbolValue(ALLOCATION_POINTER,
(lispobj)(((char *)heap_base) + last_free_page*4096));
(lispobj)(((char *)heap_base) + last_free_page*4096),0);
}
free_pages_lock=0;
return((void *)(page_address(first_page)+orig_first_page_bytes_used));
}
@ -951,6 +963,7 @@ gc_find_freeish_pages(int *restart_page_ptr, int nbytes, int unboxed, struct all
int num_pages;
int large = !alloc_region && (nbytes >= large_object_size);
gc_assert(free_pages_lock);
/* Search for a contiguous free space of at least nbytes. If it's a
large object then align it on a page boundary by searching for a
free page. */
@ -2088,7 +2101,7 @@ static lispobj*
search_read_only_space(lispobj *pointer)
{
lispobj* start = (lispobj*)READ_ONLY_SPACE_START;
lispobj* end = (lispobj*)SymbolValue(READ_ONLY_SPACE_FREE_POINTER);
lispobj* end = (lispobj*)SymbolValue(READ_ONLY_SPACE_FREE_POINTER,0);
if ((pointer < start) || (pointer >= end))
return NULL;
return (search_space(start, (pointer+2)-start, pointer));
@ -2098,7 +2111,7 @@ static lispobj *
search_static_space(lispobj *pointer)
{
lispobj* start = (lispobj*)STATIC_SPACE_START;
lispobj* end = (lispobj*)SymbolValue(STATIC_SPACE_FREE_POINTER);
lispobj* end = (lispobj*)SymbolValue(STATIC_SPACE_FREE_POINTER,0);
if ((pointer < start) || (pointer >= end))
return NULL;
return (search_space(start, (pointer+2)-start, pointer));
@ -2163,7 +2176,10 @@ possibly_valid_dynamic_space_pointer(lispobj *pointer)
* (2) Perhaps find some other hack to protect against this, e.g.
* recording the result of the last call to allocate-lisp-memory,
* and returning true from this function when *pointer is
* a reference to that result. */
* a reference to that result.
*
* (surely pseudo-atomic is supposed to be used for exactly this?)
*/
switch (lowtag_of((lispobj)pointer)) {
case FUN_POINTER_LOWTAG:
/* Start_addr should be the enclosing code object, or a closure
@ -3231,7 +3247,7 @@ verify_space(lispobj *start, size_t words)
int is_in_dynamic_space = (find_page_index((void*)start) != -1);
int is_in_readonly_space =
(READ_ONLY_SPACE_START <= (unsigned)start &&
(unsigned)start < SymbolValue(READ_ONLY_SPACE_FREE_POINTER));
(unsigned)start < SymbolValue(READ_ONLY_SPACE_FREE_POINTER,0));
while (words > 0) {
size_t count = 1;
@ -3241,10 +3257,10 @@ verify_space(lispobj *start, size_t words)
int page_index = find_page_index((void*)thing);
int to_readonly_space =
(READ_ONLY_SPACE_START <= thing &&
thing < SymbolValue(READ_ONLY_SPACE_FREE_POINTER));
thing < SymbolValue(READ_ONLY_SPACE_FREE_POINTER,0));
int to_static_space =
(STATIC_SPACE_START <= thing &&
thing < SymbolValue(STATIC_SPACE_FREE_POINTER));
thing < SymbolValue(STATIC_SPACE_FREE_POINTER,0));
/* Does it point to the dynamic space? */
if (page_index != -1) {
@ -3439,18 +3455,20 @@ verify_gc(void)
* to grep for all foo_size and rename the appropriate ones to
* foo_count. */
int read_only_space_size =
(lispobj*)SymbolValue(READ_ONLY_SPACE_FREE_POINTER)
(lispobj*)SymbolValue(READ_ONLY_SPACE_FREE_POINTER,0)
- (lispobj*)READ_ONLY_SPACE_START;
int static_space_size =
(lispobj*)SymbolValue(STATIC_SPACE_FREE_POINTER)
(lispobj*)SymbolValue(STATIC_SPACE_FREE_POINTER,0)
- (lispobj*)STATIC_SPACE_START;
struct thread *th;
for_each_thread(th) {
int binding_stack_size =
(lispobj*)SymbolValue(BINDING_STACK_POINTER)
- (lispobj*)BINDING_STACK_START;
(lispobj*)SymbolValue(BINDING_STACK_POINTER,th)
- (lispobj*)th->binding_stack_start;
verify_space(th->binding_stack_start, binding_stack_size);
}
verify_space((lispobj*)READ_ONLY_SPACE_START, read_only_space_size);
verify_space((lispobj*)STATIC_SPACE_START , static_space_size);
verify_space((lispobj*)BINDING_STACK_START , binding_stack_size);
}
static void
@ -3588,7 +3606,7 @@ garbage_collect_generation(int generation, int raise)
unsigned long bytes_freed;
unsigned long i;
unsigned long static_space_size;
struct thread *th;
gc_assert(generation <= (NUM_GENERATIONS-1));
/* The oldest generation can't be raised. */
@ -3630,11 +3648,33 @@ garbage_collect_generation(int generation, int raise)
* be un-protected anyway before unmapping later. */
unprotect_oldspace();
/* Scavenge the stack's conservative roots. */
{
/* Scavenge the stacks' conservative roots. */
for_each_thread(th) {
void **ptr;
for (ptr = (void **)CONTROL_STACK_END - 1;
#ifdef LISP_FEATURE_SB_THREAD
struct user_regs_struct regs;
if(ptrace(PTRACE_GETREGS,th->pid,0,&regs)){
/* probably doesn't exist any more. */
fprintf(stderr,"child pid %d, %s\n",th->pid,strerror(errno));
perror("PTRACE_GETREGS");
}
preserve_pointer(regs.ebx);
preserve_pointer(regs.ecx);
preserve_pointer(regs.edx);
preserve_pointer(regs.esi);
preserve_pointer(regs.edi);
preserve_pointer(regs.ebp);
preserve_pointer(regs.eax);
#endif
for (ptr = ((void **)
((void *)th->control_stack_start
+ THREAD_CONTROL_STACK_SIZE)
-1);
#ifdef LISP_FEATURE_SB_THREAD
ptr > regs.esp;
#else
ptr > (void **)&raise;
#endif
ptr--) {
preserve_pointer(*ptr);
}
@ -3656,18 +3696,31 @@ garbage_collect_generation(int generation, int raise)
/* Scavenge the Lisp functions of the interrupt handlers, taking
* care to avoid SIG_DFL and SIG_IGN. */
for_each_thread(th) {
struct interrupt_data *data=th->interrupt_data;
for (i = 0; i < NSIG; i++) {
union interrupt_handler handler = interrupt_handlers[i];
union interrupt_handler handler = data->interrupt_handlers[i];
if (!ARE_SAME_HANDLER(handler.c, SIG_IGN) &&
!ARE_SAME_HANDLER(handler.c, SIG_DFL)) {
scavenge((lispobj *)(interrupt_handlers + i), 1);
scavenge((lispobj *)(data->interrupt_handlers + i), 1);
}
}
}
/* Scavenge the binding stacks. */
{
struct thread *th;
for_each_thread(th) {
long len= (lispobj *)SymbolValue(BINDING_STACK_POINTER,th) -
th->binding_stack_start;
scavenge((lispobj *) th->binding_stack_start,len);
#ifdef LISP_FEATURE_SB_THREAD
/* do the tls as well */
len=fixnum_value(SymbolValue(FREE_TLS_INDEX,0)) -
(sizeof (struct thread))/(sizeof (lispobj));
scavenge((lispobj *) (th+1),len);
#endif
}
}
/* Scavenge the binding stack. */
scavenge((lispobj *) BINDING_STACK_START,
(lispobj *)SymbolValue(BINDING_STACK_POINTER) -
(lispobj *)BINDING_STACK_START);
/* The original CMU CL code had scavenge-read-only-space code
* controlled by the Lisp-level variable
@ -3690,7 +3743,7 @@ garbage_collect_generation(int generation, int raise)
/* Scavenge static space. */
static_space_size =
(lispobj *)SymbolValue(STATIC_SPACE_FREE_POINTER) -
(lispobj *)SymbolValue(STATIC_SPACE_FREE_POINTER,0) -
(lispobj *)STATIC_SPACE_START;
if (gencgc_verbose > 1) {
FSHOW((stderr,
@ -3801,7 +3854,7 @@ update_x86_dynamic_space_free_pointer(void)
last_free_page = last_page+1;
SetSymbolValue(ALLOCATION_POINTER,
(lispobj)(((char *)heap_base) + last_free_page*4096));
(lispobj)(((char *)heap_base) + last_free_page*4096),0);
return 0; /* dummy value: return something ... */
}
@ -4005,7 +4058,7 @@ gc_free_heap(void)
gc_set_region_empty(&unboxed_region);
last_free_page = 0;
SetSymbolValue(ALLOCATION_POINTER, (lispobj)((char *)heap_base));
SetSymbolValue(ALLOCATION_POINTER, (lispobj)((char *)heap_base),0);
if (verify_after_free_heap) {
/* Check whether purify has left any bad pointers. */
@ -4076,7 +4129,7 @@ gencgc_pickup_dynamic(void)
{
int page = 0;
int addr = DYNAMIC_SPACE_START;
int alloc_ptr = SymbolValue(ALLOCATION_POINTER);
int alloc_ptr = SymbolValue(ALLOCATION_POINTER,0);
/* Initialize the first region. */
do {
@ -4120,18 +4173,20 @@ extern boolean maybe_gc_pending ;
char *
alloc(int nbytes)
{
struct alloc_region *region= &boxed_region;
struct thread *th=arch_os_get_current_thread();
struct alloc_region *region=
th ? &(th->alloc_region) : &boxed_region;
void *new_obj;
void *new_free_pointer;
/* Check for alignment allocation problems. */
gc_assert((((unsigned)region->free_pointer & 0x7) == 0)
&& ((nbytes & 0x7) == 0));
/* At this point we should either be in pseudo-atomic, or early
* enough in cold initn that interrupts are not yet enabled anyway.
* It would be nice to assert same.
*/
gc_assert(SymbolValue(PSEUDO_ATOMIC_ATOMIC));
if(all_threads)
/* there are a few places in the C code that allocate data in the
* heap before Lisp starts. This is before interrupts are enabled,
* so we don't need to check for pseudo-atomic */
gc_assert(SymbolValue(PSEUDO_ATOMIC_ATOMIC,th));
/* maybe we can do this quickly ... */
new_free_pointer = region->free_pointer + nbytes;
@ -4149,7 +4204,7 @@ alloc(int nbytes)
/* set things up so that GC happens when we finish the PA
* section. */
maybe_gc_pending=1;
SetSymbolValue(PSEUDO_ATOMIC_INTERRUPTED, make_fixnum(1));
SetSymbolValue(PSEUDO_ATOMIC_INTERRUPTED, make_fixnum(1),th);
}
new_obj = gc_alloc_with_region(nbytes,0,region,0);
return (new_obj);
@ -4260,6 +4315,9 @@ unhandled_sigmemoryfault()
gc_alloc_update_all_page_tables(void)
{
/* Flush the alloc regions updating the tables. */
struct thread *th;
for_each_thread(th)
gc_alloc_update_page_tables(0, &th->alloc_region);
gc_alloc_update_page_tables(1, &unboxed_region);
gc_alloc_update_page_tables(0, &boxed_region);
}

21
src/runtime/gencgc.h
View file

@ -16,6 +16,8 @@
#ifndef _GENCGC_H_
#define _GENCGC_H_
#include "genesis/code.h"
void gc_free_heap(void);
inline int find_page_index(void *);
inline void *page_address(int);
@ -81,22 +83,6 @@ struct page {
#define NUM_PAGES ((DYNAMIC_SPACE_SIZE+4095)/4096)
extern struct page page_table[NUM_PAGES];
/* Abstract out the data for an allocation region allowing a single
* routine to be used for allocation and closing. */
struct alloc_region {
/* These two are needed for quick allocation. */
void *free_pointer;
void *end_addr; /* pointer to the byte after the last usable byte */
/* These are needed when closing the region. */
int first_page;
int last_page;
void *start_addr;
};
extern struct alloc_region boxed_region;
extern struct alloc_region unboxed_region;
void gencgc_pickup_dynamic(void);
@ -105,5 +91,6 @@ void sniff_code_object(struct code *code, unsigned displacement);
int update_x86_dynamic_space_free_pointer(void);
void gc_alloc_update_page_tables(int unboxed,
struct alloc_region *alloc_region);
void gc_alloc_update_all_page_tables(void);
void gc_set_region_empty(struct alloc_region *region);
#endif _GENCGC_H_

13
src/runtime/globals.c
View file

@ -59,16 +59,7 @@ void globals_init(void)
/* Set foreign function call active. */
foreign_function_call_active = 1;
/* Initialize the current Lisp state. */
#ifdef LISP_FEATURE_STACK_GROWS_DOWNWARD_NOT_UPWARD
current_control_stack_pointer = (lispobj *)CONTROL_STACK_END;
#else
current_control_stack_pointer = (lispobj *)CONTROL_STACK_START;
#endif
current_control_frame_pointer = (lispobj *)0;
#ifndef BINDING_STACK_POINTER
current_binding_stack_pointer = native_pointer(BINDING_STACK_START);
#ifdef LISP_FEATURE_SB_THREAD
parent_pid=getpid();
#endif
}

4
src/runtime/globals.h
View file

@ -14,9 +14,12 @@
#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;
@ -31,6 +34,7 @@ extern lispobj *current_auto_gc_trigger;
#endif
extern lispobj *current_dynamic_space;
extern pid_t parent_pid;
extern void globals_init(void);

220
src/runtime/interrupt.c
View file

@ -31,10 +31,8 @@
#include "alloc.h"
#include "dynbind.h"
#include "interr.h"
#include "genesis/simple-fun.h"
#include "genesis/fdefn.h"
#include "genesis/symbol.h"
#include "genesis/static-symbols.h"
#include "genesis/simple-fun.h"
void sigaddset_blockable(sigset_t *s)
{
@ -64,7 +62,7 @@ void sigaddset_blockable(sigset_t *s)
* becomes 'yes'.) */
boolean internal_errors_enabled = 0;
os_context_t *lisp_interrupt_contexts[MAX_INTERRUPTS];
struct interrupt_data * global_interrupt_data;
/* As far as I can tell, what's going on here is:
*
@ -93,16 +91,6 @@ os_context_t *lisp_interrupt_contexts[MAX_INTERRUPTS];
* - WHN 20000728, dan 20010128 */
void (*interrupt_low_level_handlers[NSIG]) (int, siginfo_t*, void*) = {0};
union interrupt_handler interrupt_handlers[NSIG];
/* signal number, siginfo_t, and old mask information for pending signal
*
* pending_signal=0 when there is no pending signal. */
static int pending_signal = 0;
static siginfo_t pending_info;
static sigset_t pending_mask;
boolean maybe_gc_pending = 0;
/*
@ -110,7 +98,7 @@ boolean maybe_gc_pending = 0;
*/
void
build_fake_control_stack_frames(os_context_t *context)
build_fake_control_stack_frames(struct thread *th,os_context_t *context)
{
#ifndef LISP_FEATURE_X86
@ -164,6 +152,7 @@ void
fake_foreign_function_call(os_context_t *context)
{
int context_index;
struct thread *thread=arch_os_get_current_thread();
/* Get current Lisp state from context. */
#ifdef reg_ALLOC
@ -180,24 +169,21 @@ fake_foreign_function_call(os_context_t *context)
(lispobj *)(*os_context_register_addr(context, reg_BSP));
#endif
build_fake_control_stack_frames(context);
build_fake_control_stack_frames(thread,context);
/* Do dynamic binding of the active interrupt context index
* and save the context in the context array. */
context_index = SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX)>>2;
/* FIXME: Ick! Why use abstract "make_fixnum" in some places if
* you're going to convert from fixnum by bare >>2 in other
* places? Use fixnum_value(..) here, and look for other places
* which do bare >> and << for fixnum_value and make_fixnum. */
context_index =
fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX,thread));
if (context_index >= MAX_INTERRUPTS) {
lose("maximum interrupt nesting depth (%d) exceeded", MAX_INTERRUPTS);
}
bind_variable(FREE_INTERRUPT_CONTEXT_INDEX,
make_fixnum(context_index + 1));
make_fixnum(context_index + 1),thread);
lisp_interrupt_contexts[context_index] = context;
thread->interrupt_contexts[context_index] = context;
/* no longer in Lisp now */
foreign_function_call_active = 1;
@ -206,6 +192,7 @@ fake_foreign_function_call(os_context_t *context)
void
undo_fake_foreign_function_call(os_context_t *context)
{
struct thread *thread=arch_os_get_current_thread();
/* Block all blockable signals. */
sigset_t block;
sigemptyset(&block);
@ -222,7 +209,7 @@ undo_fake_foreign_function_call(os_context_t *context)
* perhaps yes, unbind_to_here() really would be clearer and less
* fragile.. */
/* dan (2001.08.10) thinks the above supposition is probably correct */
unbind();
unbind(thread);
#ifdef reg_ALLOC
/* Put the dynamic space free pointer back into the context. */
@ -281,14 +268,20 @@ interrupt_internal_error(int signal, siginfo_t *info, os_context_t *context,
void
interrupt_handle_pending(os_context_t *context)
{
struct thread *thread;
struct interrupt_data *data;
#ifndef __i386__
boolean were_in_lisp = !foreign_function_call_active;
#endif
SetSymbolValue(INTERRUPT_PENDING, NIL);
#ifdef LISP_FEATURE_SB_THREAD
while(stop_the_world) kill(getpid(),SIGSTOP);
#endif
thread=arch_os_get_current_thread();
data=thread->interrupt_data;
SetSymbolValue(INTERRUPT_PENDING, NIL,thread);
if (maybe_gc_pending) {
maybe_gc_pending = 0;
#ifndef __i386__
if (were_in_lisp)
#endif
@ -332,12 +325,12 @@ interrupt_handle_pending(os_context_t *context)
memcpy(os_context_sigmask_addr(context), &pending_mask,
4 /* sizeof(sigset_t) */ );
#endif
sigemptyset(&pending_mask);
if (pending_signal) {
int signal = pending_signal;
sigemptyset(&data->pending_mask);
if (data->pending_signal) {
int signal = data->pending_signal;
siginfo_t info;
memcpy(&info, &pending_info, sizeof(siginfo_t));
pending_signal = 0;
memcpy(&info, &data->pending_info, sizeof(siginfo_t));
data->pending_signal = 0;
interrupt_handle_now(signal, &info, context);
}
}
@ -361,6 +354,7 @@ void
interrupt_handle_now(int signal, siginfo_t *info, void *void_context)
{
os_context_t *context = (os_context_t*)void_context;
struct thread *thread=arch_os_get_current_thread();
#ifndef __i386__
boolean were_in_lisp;
#endif
@ -372,7 +366,7 @@ interrupt_handle_now(int signal, siginfo_t *info, void *void_context)
delivered we appear to have a null FPU control word. */
os_restore_fp_control(context);
#endif
handler = interrupt_handlers[signal];
handler = thread->interrupt_data->interrupt_handlers[signal];
if (ARE_SAME_HANDLER(handler.c, SIG_IGN)) {
return;
@ -444,51 +438,41 @@ interrupt_handle_now(int signal, siginfo_t *info, void *void_context)
#endif
}
static void
store_signal_data_for_later (struct interrupt_data *data, int signal,
siginfo_t *info, os_context_t *context)
{
data->pending_signal = signal;
memcpy(&(data->pending_info), info, sizeof(siginfo_t));
memcpy(&(data->pending_mask),
os_context_sigmask_addr(context),
sizeof(sigset_t));
sigaddset_blockable(os_context_sigmask_addr(context));
}
static void
maybe_now_maybe_later(int signal, siginfo_t *info, void *void_context)
{
os_context_t *context = arch_os_get_context(&void_context);
struct thread *thread=arch_os_get_current_thread();
struct interrupt_data *data=thread->interrupt_data;
#ifdef LISP_FEATURE_LINUX
os_restore_fp_control(context);
#endif
/* see comments at top of code/signal.lisp for what's going on here
* with INTERRUPTS_ENABLED/INTERRUPT_HANDLE_NOW
*/
if (SymbolValue(INTERRUPTS_ENABLED) == NIL) {
/* FIXME: This code is exactly the same as the code in the
* other leg of the if(..), and should be factored out into
* a shared function. */
pending_signal = signal;
memcpy(&pending_info, info, sizeof(siginfo_t));
memcpy(&pending_mask,
os_context_sigmask_addr(context),
sizeof(sigset_t));
sigaddset_blockable(os_context_sigmask_addr(context));
SetSymbolValue(INTERRUPT_PENDING, T);
if (SymbolValue(INTERRUPTS_ENABLED,thread) == NIL) {
store_signal_data_for_later(data,signal,info,context);
SetSymbolValue(INTERRUPT_PENDING, T,thread);
} else if (
#ifndef __i386__
(!foreign_function_call_active) &&
#endif
arch_pseudo_atomic_atomic(context)) {
/* FIXME: It would probably be good to replace these bare
* memcpy(..) calls with calls to cpy_siginfo_t and
* cpy_sigset_t, so that we only have to get the sizeof
* expressions right in one place, and after that static type
* checking takes over. */
pending_signal = signal;
memcpy(&pending_info, info, sizeof(siginfo_t));
memcpy(&pending_mask,
os_context_sigmask_addr(context),
sizeof(sigset_t));
sigaddset_blockable(os_context_sigmask_addr(context));
store_signal_data_for_later(data,signal,info,context);
arch_set_pseudo_atomic_interrupted(context);
} else {
interrupt_handle_now(signal, info, context);
}
@ -525,16 +509,17 @@ gc_trigger_hit(int signal, siginfo_t *info, os_context_t *context)
boolean handle_control_stack_guard_triggered(os_context_t *context,void *addr)
{
struct thread *th=arch_os_get_current_thread();
/* note the os_context hackery here. When the signal handler returns,
* it won't go back to what it was doing ... */
if(addr>=(void *)CONTROL_STACK_GUARD_PAGE &&
addr<(void *)(CONTROL_STACK_GUARD_PAGE+os_vm_page_size)) {
if(addr>=(void *)CONTROL_STACK_GUARD_PAGE(th) &&
addr<(void *)(CONTROL_STACK_GUARD_PAGE(th)+os_vm_page_size)) {
void *fun;
void *code;
/* fprintf(stderr, "hit end of control stack\n"); */
/* we hit the end of the control stack. disable protection
* temporarily so the error handler has some headroom */
protect_control_stack_guard_page(0);
protect_control_stack_guard_page(th->pid,0L);
fun = (void *)
native_pointer((lispobj) SymbolFunction(CONTROL_STACK_EXHAUSTED_ERROR));
@ -542,7 +527,7 @@ boolean handle_control_stack_guard_triggered(os_context_t *context,void *addr)
/* Build a stack frame showing `interrupted' so that the
* user's backtrace makes (as much) sense (as usual) */
build_fake_control_stack_frames(context);
build_fake_control_stack_frames(th,context);
/* signal handler will "return" to this error-causing function */
*os_context_pc_addr(context) = code;
#ifdef LISP_FEATURE_X86
@ -640,46 +625,29 @@ interrupt_maybe_gc(int signal, siginfo_t *info, void *void_context)
* noise to install handlers
*/
/*
* what low-level signal handlers looked like before
* undoably_install_low_level_interrupt_handler() got involved
*/
struct low_level_signal_handler_state {
int was_modified;
void (*handler)(int, siginfo_t*, void*);
} old_low_level_signal_handler_states[NSIG];
/* SBCL used to have code to restore signal handlers on exit, which
* has been removed from the threaded version until we decide: exit of
* _what_ ? */
/* SBCL comment: The "undoably" aspect is because we also arrange with
* atexit() for the handler to be restored to its old value. This is
* for tidiness: it shouldn't matter much ordinarily, but it does
* remove a window where e.g. memory fault signals (SIGSEGV or SIGBUS,
* which in ordinary operation of SBCL are sent to the generational
* garbage collector, then possibly onward to Lisp code) or SIGINT
* (which is ordinarily passed to Lisp code) could otherwise be
* handled bizarrely/brokenly because the Lisp code would try to deal
* with them using machinery (like stream output buffers) which has
* already been dismantled. */
/* I'm not sure (a) whether this is a real concern, (b) how it helps
anyway */
void
uninstall_low_level_interrupt_handlers_atexit(void)
{
int signal;
for (signal = 0; signal < NSIG; ++signal) {
struct low_level_signal_handler_state
*old_low_level_signal_handler_state =
old_low_level_signal_handler_states + signal;
if (old_low_level_signal_handler_state->was_modified) {
struct sigaction sa;
sa.sa_sigaction = old_low_level_signal_handler_state->handler;
sigemptyset(&sa.sa_mask);
sa.sa_flags = SA_SIGINFO | SA_RESTART;
sigaction(signal, &sa, NULL);
}
}
}
/* Undoably install a special low-level handler for signal; or if
* handler is SIG_DFL, remove any special handling for signal.
*
* The "undoably" aspect is because we also arrange with atexit() for
* the handler to be restored to its old value. This is for tidiness:
* it shouldn't matter much ordinarily, but it does remove a window
* where e.g. memory fault signals (SIGSEGV or SIGBUS, which in
* ordinary operation of SBCL are sent to the generational garbage
* collector, then possibly onward to Lisp code) or SIGINT (which is
* ordinarily passed to Lisp code) could otherwise be handled
* bizarrely/brokenly because the Lisp code would try to deal with
* them using machinery (like stream output buffers) which has already
* been dismantled. */
void
undoably_install_low_level_interrupt_handler (int signal,
void handler(int,
@ -687,8 +655,9 @@ undoably_install_low_level_interrupt_handler (int signal,
void*))
{
struct sigaction sa;
struct low_level_signal_handler_state *old_low_level_signal_handler_state =
old_low_level_signal_handler_states + signal;
struct thread *th=arch_os_get_current_thread();
struct interrupt_data *data=
th ? th->interrupt_data : global_interrupt_data;
if (0 > signal || signal >= NSIG) {
lose("bad signal number %d", signal);
@ -699,31 +668,11 @@ undoably_install_low_level_interrupt_handler (int signal,
sigaddset_blockable(&sa.sa_mask);
sa.sa_flags = SA_SIGINFO | SA_RESTART;
#ifdef LISP_FEATURE_C_STACK_IS_CONTROL_STACK
/* Signal handlers are run on the control stack, so if it is exhausted
* we had better use an alternate stack for whatever signal tells us
* we've exhausted it */
if(signal==SIG_MEMORY_FAULT) {
stack_t sigstack;
sigstack.ss_sp=(void *) ALTERNATE_SIGNAL_STACK_START;
sigstack.ss_flags=0;
sigstack.ss_size = SIGSTKSZ;
sigaltstack(&sigstack,0);
sa.sa_flags|=SA_ONSTACK;
}
if(signal==SIG_MEMORY_FAULT) sa.sa_flags|= SA_ONSTACK;
#endif
/* In the case of interrupt handlers which are modified more than
* once, we only save the original unmodified copy. */
if (!old_low_level_signal_handler_state->was_modified) {
struct sigaction *old_handler =
(struct sigaction*) &old_low_level_signal_handler_state->handler;
old_low_level_signal_handler_state->was_modified = 1;
sigaction(signal, &sa, old_handler);
} else {
sigaction(signal, &sa, NULL);
}
interrupt_low_level_handlers[signal] =
data->interrupt_low_level_handlers[signal] =
(ARE_SAME_HANDLER(handler, SIG_DFL) ? 0 : handler);
}
@ -734,6 +683,9 @@ install_handler(int signal, void handler(int, siginfo_t*, void*))
struct sigaction sa;
sigset_t old, new;
union interrupt_handler oldhandler;
struct thread *th=arch_os_get_current_thread();
struct interrupt_data *data=
th ? th->interrupt_data : global_interrupt_data;
FSHOW((stderr, "/entering POSIX install_handler(%d, ..)\n", signal));
@ -746,7 +698,7 @@ install_handler(int signal, void handler(int, siginfo_t*, void*))
FSHOW((stderr, "/interrupt_low_level_handlers[signal]=%d\n",
interrupt_low_level_handlers[signal]));
if (interrupt_low_level_handlers[signal]==0) {
if (data->interrupt_low_level_handlers[signal]==0) {
if (ARE_SAME_HANDLER(handler, SIG_DFL) ||
ARE_SAME_HANDLER(handler, SIG_IGN)) {
sa.sa_sigaction = handler;
@ -759,12 +711,11 @@ install_handler(int signal, void handler(int, siginfo_t*, void*))
sigemptyset(&sa.sa_mask);
sigaddset_blockable(&sa.sa_mask);
sa.sa_flags = SA_SIGINFO | SA_RESTART;
sigaction(signal, &sa, NULL);
}
oldhandler = interrupt_handlers[signal];
interrupt_handlers[signal].c = handler;
oldhandler = data->interrupt_handlers[signal];
data->interrupt_handlers[signal].c = handler;
sigprocmask(SIG_SETMASK, &old, 0);
@ -774,18 +725,15 @@ install_handler(int signal, void handler(int, siginfo_t*, void*))
}
void
interrupt_init(void)
interrupt_init()
{
int i;
SHOW("entering interrupt_init()");
/* Set up for recovery from any installed low-level handlers. */
atexit(&uninstall_low_level_interrupt_handlers_atexit);
global_interrupt_data=calloc(sizeof(struct interrupt_data), 1);
/* Set up high level handler information. */
for (i = 0; i < NSIG; i++) {
interrupt_handlers[i].c =
global_interrupt_data->interrupt_handlers[i].c =
/* (The cast here blasts away the distinction between
* SA_SIGACTION-style three-argument handlers and
* signal(..)-style one-argument handlers, which is OK

18
src/runtime/interrupt.h
View file

@ -19,16 +19,26 @@
* Note: In CMU CL, this was 4096, but there was no explanation given,
* and it's hard to see why we'd need that many nested interrupts, so
* I've scaled it back to see what happens. -- WHN 20000730 */
#define MAX_INTERRUPTS 256
extern os_context_t *lisp_interrupt_contexts[MAX_INTERRUPTS];
#define MAX_INTERRUPTS 8
union interrupt_handler {
lispobj lisp;
void (*c)(int, siginfo_t*, void*);
};
extern void interrupt_init(void);
struct interrupt_data {
void (*interrupt_low_level_handlers[NSIG]) (int, siginfo_t*, void*) ;
union interrupt_handler interrupt_handlers[NSIG];
/* signal number, siginfo_t, and old mask information for pending
* signal. pending_signal=0 when there is no pending signal. */
int pending_signal ;
siginfo_t pending_info;
sigset_t pending_mask;
};
extern void interrupt_init();
extern void fake_foreign_function_call(os_context_t* context);
extern void undo_fake_foreign_function_call(os_context_t* context);
extern void interrupt_handle_now(int, siginfo_t*, void*);

1
src/runtime/ldso-stubs.S
View file

@ -165,6 +165,7 @@ ldso_stub__ ## fct: ; \
LDSO_STUBIFY(send)
LDSO_STUBIFY(setitimer)
LDSO_STUBIFY(setpgrp)
LDSO_STUBIFY(setsid)
#if !defined(SVR4)
LDSO_STUBIFY(sigsetmask)
#endif

27
src/runtime/linux-os.c
View file

@ -42,6 +42,7 @@
#include <unistd.h>
#include "validate.h"
#include "thread.h"
size_t os_vm_page_size;
#include "gc.h"
@ -228,12 +229,19 @@ in_range_p(os_vm_address_t a, lispobj sbeg, size_t slen)
boolean
is_valid_lisp_addr(os_vm_address_t addr)
{
return
in_range_p(addr, READ_ONLY_SPACE_START, READ_ONLY_SPACE_SIZE) ||
struct thread *th;
if(in_range_p(addr, READ_ONLY_SPACE_START, READ_ONLY_SPACE_SIZE) ||
in_range_p(addr, STATIC_SPACE_START , STATIC_SPACE_SIZE) ||
in_range_p(addr, DYNAMIC_SPACE_START , DYNAMIC_SPACE_SIZE) ||
in_range_p(addr, CONTROL_STACK_START , CONTROL_STACK_SIZE) ||
in_range_p(addr, BINDING_STACK_START , BINDING_STACK_SIZE);
in_range_p(addr, DYNAMIC_SPACE_START , DYNAMIC_SPACE_SIZE))
return 1;
for_each_thread(th) {
if(in_range_p(addr, th->control_stack_start,
THREAD_CONTROL_STACK_SIZE) ||
in_range_p(addr, th->binding_stack_start,
BINDING_STACK_SIZE))
return 1;
}
return 0;
}
/*
@ -289,10 +297,19 @@ sigsegv_handler(int signal, siginfo_t *info, void* void_context)
}
#endif
void sigcont_handler(int signal, siginfo_t *info, void *void_context)
{
/* we need to have a handler installed for this signal so that
* sigwaitinfo() for it actually returns at the appropriate time
*/
}
void
os_install_interrupt_handlers(void)
{
undoably_install_low_level_interrupt_handler(SIG_MEMORY_FAULT,
sigsegv_handler);
undoably_install_low_level_interrupt_handler(SIGCONT,
sigcont_handler);
}

14
src/runtime/monitor.c
View file

@ -33,6 +33,7 @@
#include "globals.h"
#include "lispregs.h"
#include "interrupt.h"
#include "thread.h"
#include "genesis/static-symbols.h"
#include "genesis/primitive-objects.h"
@ -178,6 +179,7 @@ regs_cmd(char **ptr)
#if !defined(__i386__)
printf("BSP\t=\t0x%08X\n", (unsigned long)current_binding_stack_pointer);
#endif
#if 0
#ifdef __i386__
printf("BSP\t=\t0x%08lx\n",
(unsigned long)SymbolValue(BINDING_STACK_POINTER));
@ -196,7 +198,7 @@ regs_cmd(char **ptr)
(unsigned long)SymbolValue(STATIC_SPACE_FREE_POINTER));
printf("RDONLY\t=\t0x%08lx\n",
(unsigned long)SymbolValue(READ_ONLY_SPACE_FREE_POINTER));
#endif /* 0 */
#ifdef MIPS
printf("FLAGS\t=\t0x%08x\n", current_flags_register);
#endif
@ -332,8 +334,9 @@ static void
print_context_cmd(char **ptr)
{
int free;
struct thread *thread=arch_os_get_current_thread();
free = SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX)>>2;
free = SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX,thread)>>2;
if (more_p(ptr)) {
int index;
@ -343,7 +346,7 @@ print_context_cmd(char **ptr)
if ((index >= 0) && (index < free)) {
printf("There are %d interrupt contexts.\n", free);
printf("printing context %d\n", index);
print_context(lisp_interrupt_contexts[index]);
print_context(thread->interrupt_contexts[index]);
} else {
printf("There aren't that many/few contexts.\n");
printf("There are %d interrupt contexts.\n", free);
@ -354,7 +357,7 @@ print_context_cmd(char **ptr)
else {
printf("There are %d interrupt contexts.\n", free);
printf("printing context %d\n", free - 1);
print_context(lisp_interrupt_contexts[free - 1]);
print_context(thread->interrupt_contexts[free - 1]);
}
}
}
@ -378,8 +381,9 @@ static void
catchers_cmd(char **ptr)
{
struct catch_block *catch;
struct thread *thread=arch_os_get_current_thread();
catch = (struct catch_block *)SymbolValue(CURRENT_CATCH_BLOCK);
catch = (struct catch_block *)SymbolValue(CURRENT_CATCH_BLOCK,thread);
if (catch == NULL)
printf("There are no active catchers!\n");

10
src/runtime/parse.c
View file

@ -29,6 +29,7 @@
#include "monitor.h"
#include "arch.h"
#include "search.h"
#include "thread.h"
#include "genesis/simple-fun.h"
#include "genesis/fdefn.h"
@ -248,7 +249,7 @@ static boolean lookup_symbol(char *name, lispobj *result)
/* Search static space. */
headerptr = (lispobj *)STATIC_SPACE_START;
count =
(lispobj *)SymbolValue(STATIC_SPACE_FREE_POINTER) -
(lispobj *)SymbolValue(STATIC_SPACE_FREE_POINTER,0) -
(lispobj *)STATIC_SPACE_START;
if (search_for_symbol(name, &headerptr, &count)) {
*result = make_lispobj(headerptr,OTHER_POINTER_LOWTAG);
@ -263,7 +264,7 @@ static boolean lookup_symbol(char *name, lispobj *result)
(lispobj *)DYNAMIC_SPACE_START;
#else
count =
(lispobj *)SymbolValue(ALLOCATION_POINTER) -
(lispobj *)SymbolValue(ALLOCATION_POINTER,0) -
(lispobj *)DYNAMIC_SPACE_START;
#endif
if (search_for_symbol(name, &headerptr, &count)) {
@ -307,6 +308,7 @@ parse_regnum(char *s)
lispobj parse_lispobj(ptr)
char **ptr;
{
struct thread *thread=arch_os_get_current_thread();
char *token = parse_token(ptr);
long pointer;
lispobj result;
@ -320,14 +322,14 @@ char **ptr;
int regnum;
os_context_t *context;
free = SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX)>>2;
free = SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX,thread)>>2;
if (free == 0) {
printf("Variable ``%s'' is not valid -- there is no current interrupt context.\n", token);
throw_to_monitor();
}
context = lisp_interrupt_contexts[free - 1];
context = thread->interrupt_contexts[free - 1];
regnum = parse_regnum(token);
if (regnum < 0) {

11
src/runtime/print.c
View file

@ -30,9 +30,14 @@
#include "monitor.h"
#include "vars.h"
#include "os.h"
#include "gencgc-alloc-region.h" /* genesis/thread.h needs this */
#include "genesis/static-symbols.h"
#include "genesis/primitive-objects.h"
#include "genesis/static-symbols.h"
static int max_lines = 20, cur_lines = 0;
static int max_depth = 5, brief_depth = 2, cur_depth = 0;
static int max_length = 5;
@ -413,7 +418,11 @@ static void print_slots(char **slots, int count, lispobj *ptr)
* on the values in sbcl.h (or perhaps be generated automatically
* by GENESIS as part of sbcl.h). */
static char *symbol_slots[] = {"value: ", "unused: ",
"plist: ", "name: ", "package: ", NULL};
"plist: ", "name: ", "package: ",
#ifdef LISP_FEATURE_SB_THREAD
"tls-index: " ,
#endif
NULL};
static char *ratio_slots[] = {"numer: ", "denom: ", NULL};
static char *complex_slots[] = {"real: ", "imag: ", NULL};
static char *code_slots[] = {"words: ", "entry: ", "debug: ", NULL};

61
src/runtime/purify.c
View file

@ -17,6 +17,9 @@
#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"
@ -28,6 +31,7 @@
#include "interr.h"
#include "gc.h"
#include "gc-internal.h"
#include "thread.h"
#include "genesis/primitive-objects.h"
#include "genesis/static-symbols.h"
@ -1301,7 +1305,7 @@ purify(lispobj static_roots, lispobj read_only_roots)
lispobj *clean;
int count, i;
struct later *laters, *next;
struct thread *thread;
#ifdef PRINTNOISE
printf("[doing purification:");
@ -1310,7 +1314,8 @@ purify(lispobj static_roots, lispobj read_only_roots)
#ifdef LISP_FEATURE_GENCGC
gc_alloc_update_all_page_tables();
#endif
if (fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX)) != 0) {
for_each_thread(thread)
if (fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX,thread)) != 0) {
/* FIXME: 1. What does this mean? 2. It shouldn't be reporting
* its error simply by a. printing a string b. to stdout instead
* of stderr. */
@ -1321,23 +1326,42 @@ purify(lispobj static_roots, lispobj read_only_roots)
#if defined(__i386__)
dynamic_space_free_pointer =
(lispobj*)SymbolValue(ALLOCATION_POINTER);
(lispobj*)SymbolValue(ALLOCATION_POINTER,0);
#endif
read_only_end = read_only_free =
(lispobj *)SymbolValue(READ_ONLY_SPACE_FREE_POINTER);
(lispobj *)SymbolValue(READ_ONLY_SPACE_FREE_POINTER,0);
static_end = static_free =
(lispobj *)SymbolValue(STATIC_SPACE_FREE_POINTER);
(lispobj *)SymbolValue(STATIC_SPACE_FREE_POINTER,0);
#ifdef PRINTNOISE
printf(" roots");
fflush(stdout);
#endif
#if 0
/* can't do this unless the threads in question are suspended with
* ptrace
*/
#if (defined(LISP_FEATURE_GENCGC) && defined(LISP_FEATURE_X86))
gc_assert((lispobj *)CONTROL_STACK_END > ((&read_only_roots)+1));
setup_i386_stack_scav(((&static_roots)-2), (lispobj *)CONTROL_STACK_END);
for_each_thread(thread) {
void **ptr;
struct user_regs_struct regs;
if(ptrace(PTRACE_GETREGS,thread->pid,0,&regs)){
fprintf(stderr,"child pid %d, %s\n",thread->pid,strerror(errno));
lose("PTRACE_GETREGS");
}
setup_i386_stack_scav(regs.ebp,
((void *)thread->control_stack_start)
+THREAD_CONTROL_STACK_SIZE);
}
#endif
#endif
setup_i386_stack_scav(((&static_roots)-2),
((void *)all_threads->control_stack_start)
+THREAD_CONTROL_STACK_SIZE);
pscav(&static_roots, 1, 0);
pscav(&read_only_roots, 1, 1);
@ -1346,8 +1370,9 @@ purify(lispobj static_roots, lispobj read_only_roots)
printf(" handlers");
fflush(stdout);
#endif
pscav((lispobj *) interrupt_handlers,
sizeof(interrupt_handlers) / sizeof(lispobj),
pscav((lispobj *) all_threads->interrupt_data->interrupt_handlers,
sizeof(all_threads->interrupt_data->interrupt_handlers)
/ sizeof(lispobj),
0);
#ifdef PRINTNOISE
@ -1373,10 +1398,18 @@ purify(lispobj static_roots, lispobj read_only_roots)
(lispobj *)current_binding_stack_pointer - (lispobj *)BINDING_STACK_START,
0);
#else
pscav( (lispobj *)BINDING_STACK_START,
(lispobj *)SymbolValue(BINDING_STACK_POINTER) -
(lispobj *)BINDING_STACK_START,
for_each_thread(thread) {
pscav( (lispobj *)thread->binding_stack_start,
(lispobj *)SymbolValue(BINDING_STACK_POINTER,thread) -
(lispobj *)thread->binding_stack_start,
0);
pscav( (lispobj *) (thread+1),
fixnum_value(SymbolValue(FREE_TLS_INDEX,0)) -
(sizeof (struct thread))/(sizeof (lispobj)),
0);
}
#endif
/* The original CMU CL code had scavenge-read-only-space code
@ -1449,8 +1482,8 @@ purify(lispobj static_roots, lispobj read_only_roots)
/* It helps to update the heap free pointers so that free_heap can
* verify after it's done. */
SetSymbolValue(READ_ONLY_SPACE_FREE_POINTER, (lispobj)read_only_free);
SetSymbolValue(STATIC_SPACE_FREE_POINTER, (lispobj)static_free);
SetSymbolValue(READ_ONLY_SPACE_FREE_POINTER, (lispobj)read_only_free,0);
SetSymbolValue(STATIC_SPACE_FREE_POINTER, (lispobj)static_free,0);
#if !defined(__i386__)
dynamic_space_free_pointer = current_dynamic_space;

161
src/runtime/runtime.c
View file

@ -17,11 +17,16 @@
#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>
@ -44,6 +49,7 @@
#include "core.h"
#include "save.h"
#include "lispregs.h"
#include "thread.h"
#include "genesis/static-symbols.h"
#include "genesis/symbol.h"
@ -174,6 +180,10 @@ See the COPYING file in the distribution for more information.\n\
More information about SBCL is available at <http://sbcl.sourceforge.net/>.\n\
", SBCL_VERSION_STRING);
}
int gc_thread_pid;
FILE *stdlog;
int
main(int argc, char *argv[], char *envp[])
@ -333,35 +343,150 @@ main(int argc, char *argv[], char *envp[])
gc_initialize_pointers();
#ifdef BINDING_STACK_POINTER
SetSymbolValue(BINDING_STACK_POINTER, BINDING_STACK_START);
#endif
interrupt_init();
arch_install_interrupt_handlers();
os_install_interrupt_handlers();
#ifdef PSEUDO_ATOMIC_ATOMIC
/* Turn on pseudo atomic for when we call into Lisp. */
SHOW("turning on pseudo atomic");
SetSymbolValue(PSEUDO_ATOMIC_ATOMIC, make_fixnum(1));
SetSymbolValue(PSEUDO_ATOMIC_INTERRUPTED, make_fixnum(0));
#endif
/* Convert remaining argv values to something that Lisp can grok. */
SHOW("setting POSIX-ARGV symbol value");
SetSymbolValue(POSIX_ARGV, alloc_string_list(argv));
SetSymbolValue(POSIX_ARGV, alloc_string_list(argv),0);
/* Install a handler to pick off SIGINT until the Lisp system gets
* far enough along to install its own handler. */
sigint_init();
FSHOW((stderr, "/funcalling initial_function=0x%lx\n", initial_function));
funcall0(initial_function);
/* initial_function() is not supposed to return. */
lose("Lisp initial_function gave up control.");
return 0; /* dummy value: return something */
create_thread(initial_function);
/* in a unithread build, create_thread never returns */
#ifdef LISP_FEATURE_SB_THREAD
gc_thread_pid=getpid();
parent_loop();
#endif
}
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

14
src/runtime/runtime.h
View file

@ -102,19 +102,15 @@ native_pointer(lispobj obj)
/* Too bad ANSI C doesn't define "bool" as C++ does.. */
typedef int boolean;
/* FIXME: There seems to be no reason that SymbolValue, SetSymbolValue,
* and SymbolFunction can't be defined as (possibly inline) functions
* instead of macros. */
#define SymbolValue(sym) \
(((struct symbol *)((sym)-OTHER_POINTER_LOWTAG))->value)
#define SetSymbolValue(sym,val) \
(((struct symbol *)((sym)-OTHER_POINTER_LOWTAG))->value = (val))
/* FIXME: There seems to be no reason that SymbolFunction can't be
* defined as (possibly inline) functions instead of macros. */
static inline lispobj SymbolValue(u32 sym, void *thread);
static inline void SetSymbolValue(u32 sym, lispobj val, void *thread);
/* This only works for static symbols. */
/* FIXME: should be called StaticSymbolFunction, right? */
#define SymbolFunction(sym) \
(((struct fdefn *)(native_pointer(SymbolValue(sym))))->fun)
(((struct fdefn *)(native_pointer(SymbolValue(sym,0))))->fun)
/* KLUDGE: As far as I can tell there's no ANSI C way of saying
* "this function never returns". This is the way that you do it

16
src/runtime/save.c
View file

@ -24,6 +24,7 @@
#include "lispregs.h"
#include "validate.h"
#include "gc-internal.h"
#include "thread.h"
#include "genesis/static-symbols.h"
#include "genesis/symbol.h"
@ -83,6 +84,7 @@ boolean
save(char *filename, lispobj init_function)
{
FILE *file;
struct thread *th;
/* Open the output file. We don't actually need the file yet, but
* the fopen() might fail for some reason, and we want to detect
@ -99,9 +101,11 @@ save(char *filename, lispobj init_function)
* being SAVE-LISP-AND-DIE instead of SAVE-LISP-AND-GO-ON). */
printf("[undoing binding stack and other enclosing state... ");
fflush(stdout);
unbind_to_here((lispobj *)BINDING_STACK_START);
SetSymbolValue(CURRENT_CATCH_BLOCK, 0);
SetSymbolValue(CURRENT_UNWIND_PROTECT_BLOCK, 0);
for_each_thread(th) { /* XXX really? */
unbind_to_here((lispobj *)th->binding_stack_start,th);
SetSymbolValue(CURRENT_CATCH_BLOCK, 0,th);
SetSymbolValue(CURRENT_UNWIND_PROTECT_BLOCK, 0,th);
}
printf("done]\n");
fflush(stdout);
@ -135,11 +139,11 @@ save(char *filename, lispobj init_function)
output_space(file,
READ_ONLY_CORE_SPACE_ID,
(lispobj *)READ_ONLY_SPACE_START,
(lispobj *)SymbolValue(READ_ONLY_SPACE_FREE_POINTER));
(lispobj *)SymbolValue(READ_ONLY_SPACE_FREE_POINTER,0));
output_space(file,
STATIC_CORE_SPACE_ID,
(lispobj *)STATIC_SPACE_START,
(lispobj *)SymbolValue(STATIC_SPACE_FREE_POINTER));
(lispobj *)SymbolValue(STATIC_SPACE_FREE_POINTER,0));
#ifdef reg_ALLOC
output_space(file,
DYNAMIC_CORE_SPACE_ID,
@ -154,7 +158,7 @@ save(char *filename, lispobj init_function)
output_space(file,
DYNAMIC_CORE_SPACE_ID,
(lispobj *)DYNAMIC_SPACE_START,
(lispobj *)SymbolValue(ALLOCATION_POINTER));
(lispobj *)SymbolValue(ALLOCATION_POINTER,0));
#endif
putw(INITIAL_FUN_CORE_ENTRY_TYPE_CODE, file);

1
src/runtime/search.c
View file

@ -15,6 +15,7 @@
#include "sbcl.h"
#include "os.h"
#include "search.h"
#include "thread.h"
#include "genesis/primitive-objects.h"
boolean search_for_type(int type, lispobj **start, int *count)

37
src/runtime/thread.c
View file

@ -41,6 +41,7 @@ int
new_thread_trampoline(struct thread *th)
{
lispobj function;
lispobj *args = NULL;
function = th->unbound_marker;
if(go==0) {
fprintf(stderr, "/pausing 0x%lx(%d,%d) before new_thread_trampoline(0x%lx)\n",
@ -54,7 +55,11 @@ new_thread_trampoline(struct thread *th)
if(arch_os_thread_init(th)==0)
return 1; /* failure. no, really */
return funcall0(function);
#ifdef LISP_FEATURE_SB_THREAD
return call_into_lisp(function,args,0);
#else
return call_into_lisp_first_time(function,args,0);
#endif
}
/* this is called from any other thread to create the new one, and
@ -99,6 +104,7 @@ pid_t create_thread(lispobj initial_function) {
make_fixnum(MAX_INTERRUPTS+
sizeof(struct thread)/sizeof(lispobj)),
0);
#ifdef LISP_FEATURE_SB_THREAD
#define STATIC_TLS_INIT(sym,field) \
((struct symbol *)(sym-OTHER_POINTER_LOWTAG))->tls_index= \
make_fixnum(THREAD_SLOT_OFFSET_WORDS(field))
@ -110,6 +116,7 @@ pid_t create_thread(lispobj initial_function) {
STATIC_TLS_INIT(PSEUDO_ATOMIC_ATOMIC,pseudo_atomic_atomic);
STATIC_TLS_INIT(PSEUDO_ATOMIC_INTERRUPTED,pseudo_atomic_interrupted);
#undef STATIC_TLS_INIT
#endif
}
th->control_stack_start = spaces;
@ -131,6 +138,21 @@ pid_t create_thread(lispobj initial_function) {
* sure why, but it appears to help */
th->pseudo_atomic_atomic=make_fixnum(1);
gc_set_region_empty(&th->alloc_region);
#ifndef LISP_FEATURE_SB_THREAD
/* the tls-points-into-struct-thread trick is only good for threaded
* sbcl, because unithread sbcl doesn't have tls. So, we copy the
* appropriate values from struct thread here, and make sure that
* we use the appropriate SymbolValue macros to access any of the
* variable quantities from the C runtime. It's not quite OAOOM,
* it just feels like it */
SetSymbolValue(BINDING_STACK_START,th->binding_stack_start,th);
SetSymbolValue(BINDING_STACK_POINTER,th->binding_stack_pointer,th);
SetSymbolValue(CONTROL_STACK_START,th->control_stack_start,th);
SetSymbolValue(ALIEN_STACK,th->alien_stack_pointer,th);
SetSymbolValue(PSEUDO_ATOMIC_ATOMIC,th->pseudo_atomic_atomic,th);
SetSymbolValue(PSEUDO_ATOMIC_INTERRUPTED,th->pseudo_atomic_interrupted,th);
#endif
bind_variable(CURRENT_CATCH_BLOCK,make_fixnum(0),th);
bind_variable(CURRENT_UNWIND_PROTECT_BLOCK,make_fixnum(0),th);
@ -146,9 +168,9 @@ pid_t create_thread(lispobj initial_function) {
memcpy(th->interrupt_data,global_interrupt_data,
sizeof (struct interrupt_data));
#if defined(LISP_FEATURE_X86) && defined (LISP_FEATURE_LINUX)
th->unbound_marker=initial_function;
#ifdef LISP_FEATURE_SB_THREAD
#if defined(LISP_FEATURE_X86) && defined (LISP_FEATURE_LINUX)
kid_pid=
clone(new_thread_trampoline,
(((void*)th->control_stack_start)+THREAD_CONTROL_STACK_SIZE-4),
@ -159,7 +181,9 @@ pid_t create_thread(lispobj initial_function) {
#else
#error this stuff presently only works on x86 Linux
#endif
#else
kid_pid=getpid();
#endif
get_spinlock(&all_threads_lock,kid_pid);
th->next=all_threads;
all_threads=th;
@ -169,6 +193,11 @@ pid_t create_thread(lispobj initial_function) {
protect_control_stack_guard_page(th->pid,1);
all_threads_lock=0;
th->pid=kid_pid; /* child will not start until this is set */
#ifndef LISP_FEATURE_SB_THREAD
new_thread_trampoline(all_threads); /* call_into_lisp */
lose("Clever child? Idiot savant, verging on the.");
#endif
return th->pid;
cleanup:
/* if(th && th->tls_cookie>=0) os_free_tls_pointer(th); */

18
src/runtime/thread.h
View file

@ -29,29 +29,42 @@ extern struct thread *all_threads;
extern int dynamic_values_bytes;
extern struct thread *find_thread_by_pid(pid_t pid);
#ifdef LISP_FEATURE_SB_THREAD
#define for_each_thread(th) for(th=all_threads;th;th=th->next)
#else
/* there's some possibility a SSC could notice this never actually
* loops */
#define for_each_thread(th) for(th=all_threads;th;th=0)
#endif
static inline lispobj SymbolValue(u32 tagged_symbol_pointer, void *thread) {
struct symbol *sym= (struct symbol *)
(tagged_symbol_pointer-OTHER_POINTER_LOWTAG);
#ifdef LISP_FEATURE_SB_THREAD
if(thread && sym->tls_index) {
lispobj r=
((union per_thread_data *)thread)
->dynamic_values[fixnum_value(sym->tls_index)];
if(r!=UNBOUND_MARKER_WIDETAG) return r;
}
#endif
return sym->value;
}
static inline lispobj SymbolTlValue(u32 tagged_symbol_pointer, void *thread) {
struct symbol *sym= (struct symbol *)
(tagged_symbol_pointer-OTHER_POINTER_LOWTAG);
#ifdef LISP_FEATURE_SB_THREAD
return ((union per_thread_data *)thread)
->dynamic_values[fixnum_value(sym->tls_index)];
#else
return sym->value;
#endif
}
static inline void SetSymbolValue(u32 tagged_symbol_pointer,lispobj val, void *thread) {
struct symbol *sym= (struct symbol *)
(tagged_symbol_pointer-OTHER_POINTER_LOWTAG);
#ifdef LISP_FEATURE_SB_THREAD
if(thread && sym->tls_index) {
lispobj *pr= &(((union per_thread_data *)thread)
->dynamic_values[fixnum_value(sym->tls_index)]);
@ -60,14 +73,19 @@ static inline void SetSymbolValue(u32 tagged_symbol_pointer,lispobj val, void *t
return;
}
}
#endif
sym->value = val;
}
static inline void SetTlSymbolValue(u32 tagged_symbol_pointer,lispobj val, void *thread) {
#ifdef LISP_FEATURE_SB_THREAD
struct symbol *sym= (struct symbol *)
(tagged_symbol_pointer-OTHER_POINTER_LOWTAG);
((union per_thread_data *)thread)
->dynamic_values[fixnum_value(sym->tls_index)]
=val;
#else
SetSymbolValue(tagged_symbol_pointer,val,thread) ;
#endif
}

8
src/runtime/validate.c
View file

@ -72,8 +72,6 @@ validate(void)
ensure_space( (lispobj *)DYNAMIC_0_SPACE_START , DYNAMIC_SPACE_SIZE);
ensure_space( (lispobj *)DYNAMIC_1_SPACE_START , DYNAMIC_SPACE_SIZE);
#endif
ensure_space( (lispobj *)CONTROL_STACK_START , CONTROL_STACK_SIZE);
ensure_space( (lispobj *)BINDING_STACK_START , BINDING_STACK_SIZE);
#ifdef LISP_FEATURE_C_STACK_IS_CONTROL_STACK
ensure_space( (lispobj *) ALTERNATE_SIGNAL_STACK_START, SIGSTKSZ);
#endif
@ -85,11 +83,11 @@ validate(void)
#ifdef PRINTNOISE
printf(" done.\n");
#endif
protect_control_stack_guard_page(1);
}
void protect_control_stack_guard_page(int protect_p) {
os_protect(CONTROL_STACK_GUARD_PAGE,
void protect_control_stack_guard_page(pid_t t_id, int protect_p) {
struct thread *th= find_thread_by_pid(t_id);
os_protect(CONTROL_STACK_GUARD_PAGE(th),
os_vm_page_size,protect_p ?
(OS_VM_PROT_READ|OS_VM_PROT_EXECUTE) : OS_VM_PROT_ALL);
}

19
src/runtime/validate.h
View file

@ -13,21 +13,22 @@
#define _INCLUDE_VALIDATE_H_
/* constants derived from the fundamental constants in passed by GENESIS */
#define BINDING_STACK_SIZE ( BINDING_STACK_END - BINDING_STACK_START)
#define CONTROL_STACK_SIZE ( CONTROL_STACK_END - CONTROL_STACK_START)
#define BINDING_STACK_SIZE (1024*1024) /* chosen at random */
#define DYNAMIC_SPACE_SIZE ( DYNAMIC_SPACE_END - DYNAMIC_SPACE_START)
#define READ_ONLY_SPACE_SIZE (READ_ONLY_SPACE_END - READ_ONLY_SPACE_START)
#define STATIC_SPACE_SIZE ( STATIC_SPACE_END - STATIC_SPACE_START)
#ifdef LISP_FEATURE_STACK_GROWS_DOWNWARD_NOT_UPWARD
#define CONTROL_STACK_GUARD_PAGE (CONTROL_STACK_START)
#else
#define CONTROL_STACK_GUARD_PAGE (CONTROL_STACK_END - os_vm_page_size)
#endif
#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(th) ((void *)(th->control_stack_start))
#else
#define CONTROL_STACK_GUARD_PAGE(th) (((void *)(th->control_stack_start))+THREAD_CONTROL_STACK_SIZE - os_vm_page_size)
#endif
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

7
src/runtime/x86-arch.c
View file

@ -24,6 +24,7 @@
#include "interr.h"
#include "breakpoint.h"
#include "monitor.h"
#include "thread.h"
#include "genesis/static-symbols.h"
#include "genesis/symbol.h"
@ -115,13 +116,14 @@ arch_internal_error_arguments(os_context_t *context)
boolean
arch_pseudo_atomic_atomic(os_context_t *context)
{
return SymbolValue(PSEUDO_ATOMIC_ATOMIC);
return SymbolValue(PSEUDO_ATOMIC_ATOMIC,arch_os_get_current_thread());
}
void
arch_set_pseudo_atomic_interrupted(os_context_t *context)
{
SetSymbolValue(PSEUDO_ATOMIC_INTERRUPTED, make_fixnum(1));
SetSymbolValue(PSEUDO_ATOMIC_INTERRUPTED, make_fixnum(1),
arch_os_get_current_thread());
}
/*
@ -316,6 +318,7 @@ call_into_lisp(lispobj fun, lispobj *args, int nargs);
* could be in registers depending on what the compiler likes. So we
* copy the args into a portable vector and let the assembly language
* call-in function figure it out. */
lispobj
funcall0(lispobj function)
{

41
src/runtime/x86-assem.S
View file

@ -19,8 +19,8 @@
#include "genesis/closure.h"
#include "genesis/fdefn.h"
#include "genesis/static-symbols.h"
#include "genesis/symbol.h"
#include "genesis/symbol.h"
#include "genesis/thread.h"
/* Minimize conditionalization for different OS naming schemes. */
#if defined __linux__ || defined __FreeBSD__ /* (but *not* OpenBSD) */
@ -43,6 +43,7 @@
.text
.global GNAME(foreign_function_call_active)
.global GNAME(all_threads)
/*
@ -125,6 +126,27 @@ Lfp_rtn_value:
.size GNAME(call_into_c), . - GNAME(call_into_c)
.text
.global GNAME(call_into_lisp_first_time)
.type GNAME(call_into_lisp_first_time),@function
/* The *ALIEN-STACK* pointer is set up on the first call_into_lisp when
* the stack changes. We don't worry too much about saving registers
* here, because we never expect to return from the initial call to lisp
* anyway */
.align align_16byte,0x90
GNAME(call_into_lisp_first_time):
pushl %ebp # Save old frame pointer.
movl %esp,%ebp # Establish new frame.
movl %esp,ALIEN_STACK + SYMBOL_VALUE_OFFSET
movl all_threads,%eax
movl THREAD_CONTROL_STACK_START_OFFSET(%eax) ,%esp
/* don't think too hard about what happens if we get interrupted
* here */
addl $THREAD_CONTROL_STACK_SIZE-4,%esp
jmp Lstack
.text
.global GNAME(call_into_lisp)
@ -132,14 +154,12 @@ Lfp_rtn_value:
/* The C conventions require that ebx, esi, edi, and ebp be preserved
* across function calls. */
/* The *ALIEN-STACK* pointer is set up on the first call_into_lisp when
* the stack changes. */
.align align_16byte,0x90
GNAME(call_into_lisp):
pushl %ebp # Save old frame pointer.
movl %esp,%ebp # Establish new frame.
Lstack:
/* Save the NPX state */
fwait # Catch any pending NPX exceptions.
subl $108,%esp # Make room for the NPX state.
@ -178,15 +198,6 @@ GNAME(call_into_lisp):
movl %eax, GNAME(foreign_function_call_active)
movl %esp,%ebx # remember current stack
cmpl $CONTROL_STACK_START,%esp
jbe ChangeToLispStack
cmpl $CONTROL_STACK_END,%esp
jbe OnLispStack
ChangeToLispStack:
/* Setup the *alien-stack* pointer */
movl %esp,ALIEN_STACK + SYMBOL_VALUE_OFFSET
movl $CONTROL_STACK_END,%esp # new stack
OnLispStack:
pushl %ebx # Save entry stack on (maybe) new stack.
/* Establish Lisp args. */
@ -662,7 +673,7 @@ GNAME(alloc_16_to_edi):
#ifdef LISP_FEATURE_GENCGC_INLINE_ALLOC /* disabled at present */
#ifdef GENCGC_INLINE_ALLOC /* LISP_FEATURE_GENCGC */
/* These routines are called from Lisp when an inline allocation
* overflows. Every register except the result needs to be preserved.

99
src/runtime/x86-linux-os.c
View file

@ -15,8 +15,12 @@
*/
#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"
@ -34,10 +38,105 @@
#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

2
src/runtime/x86-linux-os.h
View file

@ -8,7 +8,9 @@ static inline os_context_t *arch_os_get_context(void **void_context) {
return (os_context_t *) *void_context;
}
extern struct thread *arch_os_get_current_thread();
unsigned long os_context_fp_control(os_context_t *context);
void os_restore_fp_control(os_context_t *context);
int arch_os_thread_init(struct thread *thread);
#endif /* _X86_LINUX_OS_H */

2
version.lisp-expr
View file

@ -18,4 +18,4 @@
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
"0.pre8.27"
"0.pre8.28"