deleted various long-unused GENGC stuff..
..deleted #!+GENGC conditional code
..made #!-GENGC code unconditional
;; the underlying x86 hardware tries).
:ieee-floating-point
- ;; This seems to be the pre-GENCGC garbage collector for CMU CL, which was
- ;; AFAIK never supported for the X86.
- ; :gengc
-
;; CMU CL had, and we inherited, code to support 80-bit LONG-FLOAT on the x86
;; architecture. Nothing has been done to actively destroy the long float
;; support, but it hasn't been thoroughly maintained, and needs at least
#+x86 "*PSEUDO-ATOMIC-INTERRUPTED*"
"PUNT-PRINT-IF-TOO-LONG"
"READER-PACKAGE-ERROR"
- #!+gengc "*SAVED-STATE-CHAIN*"
"SCALE-DOUBLE-FLOAT" "SCALE-LONG-FLOAT"
"SCALE-SINGLE-FLOAT"
"SEQUENCE-END" "SEQUENCE-OF-CHECKED-LENGTH-GIVEN-TYPE"
(system-area-pointer :codes (#.sb!vm:sap-type))
(weak-pointer :codes (#.sb!vm:weak-pointer-type))
(code-component :codes (#.sb!vm:code-header-type))
- #!-gengc (lra :codes (#.sb!vm:return-pc-header-type))
+ (lra :codes (#.sb!vm:return-pc-header-type))
(fdefn :codes (#.sb!vm:fdefn-type))
(random-class) ; used for unknown type codes
(%primitive print "too early in cold init to recover from errors")
(%halt))
-#!+gengc
-(defun !do-load-time-value-fixup (object offset index)
- (declare (type index offset))
- (let ((value (svref *!load-time-values* index)))
- (typecase object
- (list
- (case offset
- (0 (setf (car object) value))
- (1 (setf (cdr object) value))
- (t (!cold-lose "bogus offset in cons cell"))))
- (instance
- (setf (%instance-ref object (- offset sb!vm:instance-slots-offset))
- value))
- (code-component
- (setf (code-header-ref object offset) value))
- (simple-vector
- (setf (svref object (- offset sb!vm:vector-data-offset)) value))
- (t
- (!cold-lose "unknown kind of object for load-time-value fixup")))))
-
(eval-when (:compile-toplevel :execute)
;; FIXME: Perhaps we should make SHOW-AND-CALL-AND-FMAKUNBOUND, too,
;; and use it for most of the cold-init functions. (Just be careful
;; !UNIX-COLD-INIT. And *TYPE-SYSTEM-INITIALIZED* could be changed to
;; *TYPE-SYSTEM-INITIALIZED-WHEN-BOUND* so that it doesn't need to
;; be explicitly set in order to be meaningful.
- (setf *gc-notify-stream* nil)
- (setf *before-gc-hooks* nil)
- (setf *after-gc-hooks* nil)
- #!+gengc (setf *handler-clusters* nil)
- #!-gengc (setf *already-maybe-gcing* t
- *gc-inhibit* t
- *need-to-collect-garbage* nil
- sb!unix::*interrupts-enabled* t
- sb!unix::*interrupt-pending* nil)
- (setf *break-on-signals* nil)
- (setf *maximum-error-depth* 10)
- (setf *current-error-depth* 0)
- (setf *cold-init-complete-p* nil)
- (setf *type-system-initialized* nil)
+ (setf *gc-notify-stream* nil
+ *before-gc-hooks* nil
+ *after-gc-hooks* nil
+ *already-maybe-gcing* t
+ *gc-inhibit* t
+ *need-to-collect-garbage* nil
+ sb!unix::*interrupts-enabled* t
+ sb!unix::*interrupt-pending* nil
+ *break-on-signals* nil
+ *maximum-error-depth* 10
+ *current-error-depth* 0
+ *cold-init-complete-p* nil
+ *type-system-initialized* nil)
;; Anyone might call RANDOM to initialize a hash value or something;
;; and there's nothing which needs to be initialized in order for
#!-gengc
(setf (sap-ref-32 (second toplevel-thing) 0)
(get-lisp-obj-address
- (svref *!load-time-values* (third toplevel-thing))))
- #!+gengc
- (!do-load-time-value-fixup (second toplevel-thing)
- (third toplevel-thing)
- (fourth toplevel-thing)))
+ (svref *!load-time-values* (third toplevel-thing)))))
#!+(and x86 gencgc)
(:load-time-code-fixup
(sb!vm::!do-load-time-code-fixup (second toplevel-thing)
(:include frame)
(:constructor make-compiled-frame
(pointer up debug-function code-location number
- #!+gengc saved-state-chain
&optional escaped))
(:copier nil))
;; This indicates whether someone interrupted the frame.
;; (unexported). If escaped, this is a pointer to the state that was
- ;; saved when we were interrupted. On the non-gengc system, this is
- ;; a pointer to an os_context_t, i.e. the third argument to an
- ;; SA_SIGACTION-style signal handler. On the gengc system, this is a
- ;; state pointer from SAVED-STATE-CHAIN.
- escaped
- ;; a list of SAPs to saved states. Each time we unwind past an
- ;; exception, we pop the next entry off this list. When we get to
- ;; the end of the list, there is nothing else on the stack.
- #!+gengc (saved-state-chain nil :type list))
+ ;; saved when we were interrupted, an os_context_t, i.e. the third
+ ;; argument to an SA_SIGACTION-style signal handler.
+ escaped)
(def!method print-object ((obj compiled-frame) str)
(print-unreadable-object (obj str :type t)
(format str
(declare (type system-area-pointer x))
#!-x86 ; stack grows toward high address values
(and (sap< x (current-sp))
- (sap<= #!-gengc (int-sap control-stack-start)
- #!+gengc (mutator-control-stack-base)
+ (sap<= (int-sap control-stack-start)
x)
(zerop (logand (sap-int x) #b11)))
#!+x86 ; stack grows toward low address values
(/show0 "entering TOP-FRAME")
(multiple-value-bind (fp pc) (%caller-frame-and-pc)
(possibly-an-interpreted-frame
- (compute-calling-frame (descriptor-sap fp)
- #!-gengc pc #!+gengc (descriptor-sap pc)
- nil)
+ (compute-calling-frame (descriptor-sap fp) pc nil)
nil)))
;;; Flush all of the frames above FRAME, and renumber all the frames
(get-context-value
real sb!vm::ocfp-save-offset
(sb!c::compiled-debug-function-old-fp c-d-f)))
- #!-gengc
(get-context-value
real sb!vm::lra-save-offset
(sb!c::compiled-debug-function-return-pc c-d-f))
- #!+gengc
- (descriptor-sap
- (get-context-value
- real sb!vm::ra-save-offset
- (sb!c::compiled-debug-function-return-pc c-d-f)))
frame)
frame)))
(bogus-debug-function
(sap-ref-32 fp (* sb!vm::ocfp-save-offset
sb!vm:word-bytes)))
- #!-gengc
(stack-ref fp sb!vm::lra-save-offset)
- #!+gengc
- (sap-ref-sap fp (* sb!vm::ra-save-offset
- sb!vm:word-bytes))
+
frame)))))))
down)))
(lra-code-header object))
(t
nil))))))))
-
-;;; SB!KERNEL:*SAVED-STATE-CHAIN* -- maintained by the C code as a
-;;; list of SAPs, each SAP pointing to a saved exception state.
-#!+gengc
-(declaim (special *saved-state-chain*))
-
-;;; CMU CL had
-;;; (DEFUN LOOKUP-TRACE-TABLE-ENTRY (COMPONENT PC) ..)
-;;; for this case, but it hasn't been maintained in SBCL.
-#!+gengc
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (error "hopelessly stale"))
-
-;;; CMU CL had
-;;; (DEFUN EXTRACT-INFO-FROM-STATE (STATE) ..)
-;;; for this case, but it hasn't been maintained in SBCL.
-#!+gengc
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (error "hopelessly stale"))
-
-;;; CMU CL had
-;;; (DEFUN COMPUTE-CALLING-FRAME (OCFP RA UP-FRAME) ..)
-;;; for this case, but it hasn't been maintained in SBCL.
-#!+gengc
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (error "hopelessly stale"))
\f
;;;; frame utilities
;;; CODE-LOCATIONs at which execution would continue with frame as the
;;; top frame if someone threw to the corresponding tag.
(defun frame-catches (frame)
- (let ((catch
- #!-gengc (descriptor-sap *current-catch-block*)
- #!+gengc (mutator-current-catch-block))
+ (let ((catch (descriptor-sap *current-catch-block*))
(res nil)
(fp (frame-pointer (frame-real-frame frame))))
(loop
(component (component-from-component-ptr
(component-ptr-from-pc ra)))
(offset
- #!-(or gengc x86)
+ #!-x86
(* (- (1+ (get-header-data lra))
(get-header-data component))
sb!vm:word-bytes)
- #!+gengc
- (+ (- (sap-int ra)
- (get-lisp-obj-address component)
- (get-header-data component))
- sb!vm:other-pointer-type)
#!+x86
(- (sap-int ra)
(- (get-lisp-obj-address component)
(multiple-value-bind (lra component offset)
(make-bogus-lra
(get-context-value frame
- #!-gengc sb!vm::lra-save-offset
- #!+gengc sb!vm::ra-save-offset
+ sb!vm::lra-save-offset
lra-sc-offset))
(setf (get-context-value frame
- #!-gengc sb!vm::lra-save-offset
- #!+gengc sb!vm::ra-save-offset
+ sb!vm::lra-save-offset
lra-sc-offset)
lra)
(let ((end-bpts (breakpoint-%info starter-bpt)))
(when (and (compiled-frame-p frame)
(eq lra
(get-context-value frame
- #!-gengc sb!vm::lra-save-offset
- #!+gengc sb!vm::ra-save-offset
+ sb!vm::lra-save-offset
lra-sc-offset)))
(return t)))))
\f
;;; saved value. When that hander returns, the original signal mask is
;;; installed, allowing any other pending signals to be handled.
;;;
-;;; This means that the cost of without-interrupts is just a special
+;;; This means that the cost of WITHOUT-INTERRUPTS is just a special
;;; binding in the case when no signals are delivered (the normal
;;; case). It's only when a signal is actually delivered that we use
;;; any system calls, and by then the cost of the extra system calls
;;; are lost in the noise when compared with the cost of delivering
;;; the signal in the first place.
-#!-gengc (progn
-
(defvar *interrupts-enabled* t)
(defvar *interrupt-pending* nil)
(when *interrupt-pending*
(do-pending-interrupt))
(,name))))))
-
-) ; PROGN
-
-;;; On the GENGC system, we have to do it slightly differently because of the
-;;; existence of threads. Each thread has a suspends_disabled_count in its
-;;; mutator structure. When this value is other then zero, the low level stuff
-;;; will not suspend the thread, but will instead set the suspend_pending flag
-;;; (also in the mutator). So when we finish the without-interrupts, we just
-;;; check the suspend_pending flag and trigger a do-pending-interrupt if
-;;; necessary.
-
-#!+gengc
-(defmacro without-interrupts (&body body)
- `(unwind-protect
- (progn
- (locally
- (declare (optimize (speed 3) (safety 0)))
- (incf (sb!kernel:mutator-interrupts-disabled-count)))
- ,@body)
- (locally
- (declare (optimize (speed 3) (safety 0)))
- (when (and (zerop (decf (sb!kernel:mutator-interrupts-disabled-count)))
- (not (zerop (sb!kernel:mutator-interrupt-pending))))
- (do-pending-interrupt)))))
\f
;;;; utilities for dealing with signal names and numbers
(defun make-symbol (string)
#!+sb-doc
"Make and return a new symbol with the STRING as its print name."
- #!-gengc (make-symbol string)
- #!+gengc (%make-symbol (random most-positive-fixnum) string))
+ (make-symbol string))
(defun get (symbol indicator &optional (default nil))
#!+sb-doc
(in-package "SB!IMPL")
\f
-#!-gengc
(defmacro without-gcing (&rest body)
#!+sb-doc
"Executes the forms in the body without doing a garbage collection."
,@body)
(when (and *need-to-collect-garbage* (not *gc-inhibit*))
(maybe-gc nil))))
-
-#!+gengc
-(defmacro without-gcing (&rest body)
- #!+sb-doc
- "Executes the forms in the body without doing a garbage collection."
- `(without-interrupts ,@body))
\f
;;; EOF-OR-LOSE is a useful macro that handles EOF.
(defmacro eof-or-lose (stream eof-error-p eof-value)
(declare (fixnum box-num code-length))
(with-fop-stack t
(let ((code (%primitive sb!c:allocate-code-object box-num code-length))
- (index (+ #!-gengc sb!vm:code-trace-table-offset-slot
- #!+gengc sb!vm:code-debug-info-slot
- box-num)))
+ (index (+ sb!vm:code-trace-table-offset-slot box-num)))
(declare (type index index))
#!-gengc (setf (%code-debug-info code) (pop-stack))
(dotimes (i box-num)
(read-n-bytes *fasl-input-stream*
(code-instructions code)
0
- #!-gengc code-length
- #!+gengc (* code-length sb!vm:word-bytes)))
+ code-length))
code)))
;;; Moving native code during a GC or purify is not so trivial on the
\f
;;; specials initialized by !COLD-INIT
-;;; FIXME: These could be converted to DEFVARs, and the stuff shared
-;;; in both #!+GENGC and #!-GENGC (actually everything in #!+GENGC)
-;;; could be made non-conditional.
-(declaim
- #!-gengc
- (special *gc-inhibit* *already-maybe-gcing*
- *need-to-collect-garbage*
- *gc-notify-stream*
- *before-gc-hooks* *after-gc-hooks*
- #!+x86 *pseudo-atomic-atomic*
- #!+x86 *pseudo-atomic-interrupted*
- sb!unix::*interrupts-enabled*
- sb!unix::*interrupt-pending*
- *type-system-initialized*)
- #!+gengc
- (special *before-gc-hooks* *after-gc-hooks*
- *gc-notify-stream*
- *type-system-initialized*))
+;;; FIXME: These could be converted to DEFVARs.
+(declaim (special *gc-inhibit* *already-maybe-gcing*
+ *need-to-collect-garbage*
+ *gc-notify-stream*
+ *before-gc-hooks* *after-gc-hooks*
+ #!+x86 *pseudo-atomic-atomic*
+ #!+x86 *pseudo-atomic-interrupted*
+ sb!unix::*interrupts-enabled*
+ sb!unix::*interrupt-pending*
+ *type-system-initialized*))
(defvar *cold-init-complete-p*)
;;; Return a wired TN describing the N'th full call argument passing
;;; location.
-;;;
(!def-vm-support-routine standard-argument-location (n)
(declare (type unsigned-byte n))
(if (< n register-arg-count)
;;; is true, then use the standard (full call) location, otherwise use
;;; any legal location. Even in the non-standard case, this may be
;;; restricted by a desire to use a subroutine call instruction.
-;;;
(!def-vm-support-routine make-return-pc-passing-location (standard)
- #!+gengc (declare (ignore standard))
- #!-gengc
(if standard
(make-wired-tn *backend-t-primitive-type* register-arg-scn lra-offset)
- (make-restricted-tn *backend-t-primitive-type* register-arg-scn))
- #!+gengc
- (make-wired-tn *fixnum-primitive-type* immediate-arg-scn ra-offset))
+ (make-restricted-tn *backend-t-primitive-type* register-arg-scn)))
-;;; This is similar to Make-Return-PC-Passing-Location, but makes a
-;;; location to pass Old-FP in. This is (obviously) wired in the
+;;; This is similar to MAKE-RETURN-PC-PASSING-LOCATION, but makes a
+;;; location to pass OLD-FP in. This is (obviously) wired in the
;;; standard convention, but is totally unrestricted in non-standard
;;; conventions, since we can always fetch it off of the stack using
;;; the arg pointer.
-;;;
(!def-vm-support-routine make-old-fp-passing-location (standard)
(if standard
(make-wired-tn *fixnum-primitive-type* immediate-arg-scn ocfp-offset)
control-stack-arg-scn
ocfp-save-offset)))
(!def-vm-support-routine make-return-pc-save-location (env)
- (let ((ptype #!-gengc *backend-t-primitive-type*
- #!+gengc *fixnum-primitive-type*))
+ (let ((ptype *backend-t-primitive-type*))
(specify-save-tn
(environment-debug-live-tn (make-normal-tn ptype) env)
- (make-wired-tn ptype control-stack-arg-scn
- #!-gengc lra-save-offset #!+gengc ra-save-offset))))
+ (make-wired-tn ptype control-stack-arg-scn lra-save-offset))))
;;; Make a TN for the standard argument count passing location. We
;;; only need to make the standard location, since a count is never
(move ocfp-tn csp-tn)
(inst nop))
(when lra-label
- #!-gengc (inst compute-code-from-lra code-tn code-tn lra-label temp)
- #!+gengc (inst compute-code-from-ra code-tn ra-tn lra-label temp)))
+ (inst compute-code-from-lra code-tn code-tn lra-label temp)))
(let ((regs-defaulted (gen-label))
(defaulting-done (gen-label))
(default-stack-vals (gen-label)))
(store-stack-tn (cdr def) null-tn)))))))
(when lra-label
- #!-gengc (inst compute-code-from-lra code-tn code-tn lra-label temp)
- #!+gengc (inst compute-code-from-ra code-tn ra-tn lra-label temp))))
+ (inst compute-code-from-lra code-tn code-tn lra-label temp))))
(values))
\f
;;;; unknown values receiving
(inst nop))
(when lra-label
- #!-gengc (inst compute-code-from-lra code-tn code-tn lra-label temp)
- #!+gengc (inst compute-code-from-ra code-tn ra-tn lra-label temp))
+ (inst compute-code-from-lra code-tn code-tn lra-label temp))
(inst addq csp-tn 4 csp-tn)
(storew (first *register-arg-tns*) csp-tn -1)
(inst subq csp-tn 4 start)
(assemble (*elsewhere*)
(emit-label variable-values)
(when lra-label
- #!-gengc (inst compute-code-from-lra code-tn code-tn lra-label temp)
- #!+gengc (inst compute-code-from-ra code-tn ra-tn lra-label temp))
+ (inst compute-code-from-lra code-tn code-tn lra-label temp))
(do ((arg *register-arg-tns* (rest arg))
(i 0 (1+ i)))
((null arg))
(return-pc :target return-pc-temp)
(vals :more t))
(:temporary (:sc any-reg :from (:argument 0)) ocfp-temp)
- (:temporary (:sc #!-gengc descriptor-reg #!+gengc any-reg
- :from (:argument 1))
+ (:temporary (:sc descriptor-reg any-reg :from (:argument 1))
return-pc-temp)
- #!-gengc (:temporary (:scs (interior-reg)) lip)
+ (:temporary (:scs (interior-reg)) lip)
(:move-args :known-return)
(:info val-locs)
(:ignore val-locs vals)
(move ocfp-temp cfp-tn)
(inst ret zero-tn lip 1)
(trace-table-entry trace-table-normal)))
-
\f
;;;; full call:
;;;;
(error "internal error, code-length=~D, nwritten=~D"
code-length
nwritten)))
- ;; KLUDGE: It's not clear what this is trying to do, but it looks as
- ;; though it's an implicit undocumented dependence on a 4-byte
- ;; wordsize which could be painful in porting. Note also that there
- ;; are other undocumented modulo-4 things scattered throughout the
- ;; code and conditionalized with GENGC, and I don't know what those
- ;; do either. -- WHN 19990323
- #!+gengc (unless (zerop (logand code-length 3))
- (dotimes (i (- 4 (logand code-length 3)))
- (dump-byte 0 fasl-output)))
(values))
;;; Dump all the fixups. Currently there are three flavors of fixup:
(collect ((patches))
- ;; Dump the debug info.
- #!+gengc
- (let ((info (sb!c::debug-info-for-component component))
- (*dump-only-valid-structures* nil))
- (dump-object info fasl-output)
- (let ((info-handle (dump-pop fasl-output)))
- (dump-push info-handle fasl-output)
- (push info-handle (fasl-output-debug-info fasl-output))))
-
;; Dump the offset of the trace table.
(dump-object code-length fasl-output)
;; FIXME: As long as we don't have GENGC, the trace table is
(dump-fop 'fop-misc-trap fasl-output)))))
;; Dump the debug info.
- #!-gengc
(let ((info (sb!c::debug-info-for-component component))
(*dump-only-valid-structures* nil))
(dump-object info fasl-output)
(dump-push info-handle fasl-output)
(push info-handle (fasl-output-debug-info fasl-output))))
- (let ((num-consts #!+gengc (- header-length
- sb!vm:code-debug-info-slot)
- #!-gengc (- header-length
- sb!vm:code-trace-table-offset-slot))
- (total-length #!+gengc (ceiling total-length 4)
- #!-gengc total-length))
+ (let ((num-consts (- header-length sb!vm:code-trace-table-offset-slot)))
(cond ((and (< num-consts #x100) (< total-length #x10000))
(dump-fop 'fop-small-code fasl-output)
(dump-byte num-consts fasl-output)
("src/code/target-misc" :not-host)
("src/code/misc")
- #!-gengc ("src/code/room" :not-host)
- #!-gengc ("src/code/gc" :not-host)
- #!-gengc ("src/code/purify" :not-host)
-
- #!+gengc ("src/code/gengc" :not-host)
+ ("src/code/room" :not-host)
+ ("src/code/gc" :not-host)
+ ("src/code/purify" :not-host)
("src/code/stream" :not-host)
("src/code/print" :not-host)
("src/compiler/entry")
("src/compiler/ir2tran")
- ;; KLUDGE: This has #!+GENGC things in it which are intended to
- ;; overwrite code in ir2tran.lisp, so it has to come after ir2tran.lisp.
- ;;
- ;; FIXME: Those things should probably be ir2tran.lisp instead, and the
- ;; things they now overwrite should instead be #!-GENGC so they're never
- ;; generated in the first place.
("src/compiler/generic/vm-ir2tran")
("src/compiler/copyprop")
;;; for internal versions, especially for internal versions off the
;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.pre7.46"
+"0.pre7.47"
projects / sbcl.git / commitdiff