(setf (svref *!load-time-values* (third toplevel-thing))
(funcall (second toplevel-thing))))
(:load-time-value-fixup
- #!-gengc
(setf (sap-ref-32 (second toplevel-thing) 0)
(get-lisp-obj-address
(svref *!load-time-values* (third toplevel-thing)))))
(setf *cold-init-complete-p* t)
;; The system is finally ready for GC.
- #!-gengc (setf *already-maybe-gcing* nil)
+ (setf *already-maybe-gcing* nil)
(/show0 "enabling GC")
(gc-on)
(/show0 "doing first GC")
(defun stack-ref (s n) (stack-ref s n))
(defun %set-stack-ref (s n value) (%set-stack-ref s n value))
(defun function-code-header (fun) (function-code-header fun))
-#!-gengc (defun lra-code-header (lra) (lra-code-header lra))
+(defun lra-code-header (lra) (lra-code-header lra))
(defun make-lisp-obj (value) (make-lisp-obj value))
(defun get-lisp-obj-address (thing) (get-lisp-obj-address thing))
(defun function-word-offset (fun) (function-word-offset fun))
(sap> (int-sap control-stack-end) x)
(zerop (logand (sap-int x) #b11))))
-#!+(or gengc x86)
+#!+x86
(sb!alien:def-alien-routine component-ptr-from-pc (system-area-pointer)
(pc system-area-pointer))
-#!+(or gengc x86)
+#!+x86
(defun component-from-component-ptr (component-ptr)
(declare (type system-area-pointer component-ptr))
(make-lisp-obj (logior (sap-int component-ptr)
;;; Note: Sometimes LRA is actually a fixnum. This happens when lisp
;;; calls into C. In this case, the code object is stored on the stack
;;; after the LRA, and the LRA is the word offset.
-#!-(or gengc x86)
+#!-x86
(defun compute-calling-frame (caller lra up-frame)
(declare (type system-area-pointer caller))
(when (cstack-pointer-valid-p caller)
;;; Find the code object corresponding to the object represented by
;;; bits and return it. We assume bogus functions correspond to the
;;; undefined-function.
-#!-gengc
(defun code-object-from-bits (bits)
(declare (type (unsigned-byte 32) bits))
(let ((object (make-lisp-obj bits)))
(sap-ref-32 catch
(* sb!vm:catch-block-current-cont-slot
sb!vm:word-bytes))))
- (let* (#!-(or gengc x86)
+ (let* (#!-x86
(lra (stack-ref catch sb!vm:catch-block-entry-pc-slot))
- #!+(or gengc x86)
+ #!+x86
(ra (sap-ref-sap
catch (* sb!vm:catch-block-entry-pc-slot
sb!vm:word-bytes)))
(let ((code (%primitive sb!c:allocate-code-object box-num code-length))
(index (+ sb!vm:code-trace-table-offset-slot box-num)))
(declare (type index index))
- #!-gengc (setf (%code-debug-info code) (pop-stack))
+ (setf (%code-debug-info code) (pop-stack))
(dotimes (i box-num)
(declare (fixnum i))
(setf (code-header-ref code (decf index)) (pop-stack)))
;;; FIXME: The DEFVAR here is redundant with the (DECLAIM (SPECIAL ..))
;;; of all static symbols in early-impl.lisp.
-#!-gengc
(progn
(defvar *current-catch-block*)
(defvar *current-unwind-protect-block*)
(:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
(:temporary (:scs (non-descriptor-reg)) temp)
(:generator 5
- (let (#!-gengc (label (gen-label))
+ (let ((label (gen-label))
(cur-nfp (current-nfp-tn vop)))
(when cur-nfp
(store-stack-tn nfp-save cur-nfp))
;; 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
- ;; hardwired to be empty. So we might be able to get rid of
- ;; trace tables? However, we should probably wait for the first
- ;; port to a system where CMU CL uses GENGC to see whether GENGC
- ;; is really gone. (I.e. maybe other non-X86 ports will want to
- ;; use it, just as in CMU CL.)
+ ;; hardwired to be empty. And SBCL doesn't have GENGC (and as
+ ;; far as I know no modern CMU CL does either -- WHN
+ ;; 2001-10-05). So might we be able to get rid of trace tables?
;; Dump the constants, noting any :entries that have to be fixed up.
(do ((i sb!vm:code-constants-offset (1+ i)))
(defun dump-assembler-routines (code-segment length fixups routines file)
(dump-fop 'fop-assembler-code file)
- (dump-unsigned-32 #!+gengc (ceiling length 4)
- #!-gengc length
- file)
+ (dump-unsigned-32 length file)
(write-segment-contents code-segment (fasl-output-stream file))
(dolist (routine routines)
(dump-fop 'fop-normal-load file)
(remhash entry (fasl-output-patch-table file)))))))
(values))
-(defun dump-byte-code-object (segment code-length constants file)
- (declare (type sb!assem:segment segment)
- (type index code-length)
- (type vector constants)
- (type fasl-output file))
- (collect ((entry-patches))
-
- ;; Dump the debug info.
- #!+gengc
- (let ((info (sb!c::make-debug-info
- :name (sb!c::component-name *component-being-compiled*)))
- (*dump-only-valid-structures* nil))
- (dump-object info file)
- (let ((info-handle (dump-pop file)))
- (dump-push info-handle file)
- (push info-handle (fasl-output-debug-info file))))
-
- ;; The "trace table" is initialized by loader to hold a list of
- ;; all byte functions in this code object (for debug info.)
- (dump-object nil file)
-
- ;; Dump the constants.
- ;;
- ;; FIXME: There's a family resemblance between this and the
- ;; corresponding code in DUMP-CODE-OBJECT. Could some be shared?
- (dotimes (i (length constants))
- (let ((entry (aref constants i)))
- (etypecase entry
- (constant
- (dump-object (sb!c::constant-value entry) file))
- (null
- (dump-fop 'fop-misc-trap file))
- (list
- (ecase (car entry)
- (:entry
- (let* ((info (sb!c::leaf-info (cdr entry)))
- (handle (gethash info
- (fasl-output-entry-table file))))
- (cond
- (handle
- (dump-push handle file))
- (t
- (entry-patches (cons info
- (+ i sb!vm:code-constants-offset)))
- (dump-fop 'fop-misc-trap file)))))
- (:load-time-value
- (dump-push (cdr entry) file))
- (:fdefinition
- (dump-object (cdr entry) file)
- (dump-fop 'fop-fdefinition file))
- (:type-predicate
- (dump-object 'load-type-predicate file)
- (let ((*unparse-function-type-simplify* t))
- (dump-object (type-specifier (cdr entry)) file))
- (dump-fop 'fop-funcall file)
- (dump-byte 1 file)))))))
-
- ;; Dump the debug info.
- #!-gengc
- (let ((info (sb!c::make-debug-info :name
- (sb!c::component-name
- *component-being-compiled*)))
- (*dump-only-valid-structures* nil))
- (dump-object info file)
- (let ((info-handle (dump-pop file)))
- (dump-push info-handle file)
- (push info-handle (fasl-output-debug-info file))))
-
- (let ((num-consts #!+gengc (+ (length constants) 2)
- #!-gengc (1+ (length constants)))
- (code-length #!+gengc (ceiling code-length 4)
- #!-gengc code-length))
- (cond ((and (< num-consts #x100) (< code-length #x10000))
- (dump-fop 'fop-small-code file)
- (dump-byte num-consts file)
- (dump-integer-as-n-bytes code-length 2 file))
- (t
- (dump-fop 'fop-code file)
- (dump-unsigned-32 num-consts file)
- (dump-unsigned-32 code-length file))))
- (dump-segment segment code-length file)
- (let ((code-handle (dump-pop file))
- (patch-table (fasl-output-patch-table file)))
- (dolist (patch (entry-patches))
- (push (cons code-handle (cdr patch))
- (gethash (car patch) patch-table)))
- code-handle)))
-
-;;; Dump a byte-component. This is similar to FASL-DUMP-COMPONENT, but
-;;; different.
-(defun fasl-dump-byte-component (segment length constants xeps file)
- (declare (type sb!assem:segment segment)
- (type index length)
- (type vector constants)
- (type list xeps)
- (type fasl-output file))
-
- (let ((code-handle (dump-byte-code-object segment length constants file)))
- (dolist (noise xeps)
- (let* ((lambda (car noise))
- (info (sb!c::lambda-info lambda))
- (xep (cdr noise)))
- (dump-byte-function xep code-handle file)
- (let* ((entry-handle (dump-pop file))
- (patch-table (fasl-output-patch-table file))
- (old (gethash info patch-table)))
- (setf (gethash info (fasl-output-entry-table file))
- entry-handle)
- (when old
- (dolist (patch old)
- (dump-alter-code-object (car patch)
- (cdr patch)
- entry-handle
- file))
- (remhash info patch-table))))))
- (values))
-
(defun dump-push-previously-dumped-fun (fun fasl-output)
(declare (type sb!c::clambda fun))
(let ((handle (gethash (sb!c::leaf-info fun)
byte-code-function
byte-code-closure
closure-function-header
- #!-gengc return-pc-header
- #!+gengc forwarding-pointer
+ return-pc-header
value-cell-header
symbol-header
base-char
unbound-marker
weak-pointer
instance-header
- fdefn
- )
+ fdefn)
;;; the different vector subtypes
(defenum (:prefix vector- :suffix -subtype)
(define-primitive-object (function :type function
:lowtag function-pointer-type
:header function-header-type)
- #!-(or gengc x86) (self :ref-trans %function-self
- :set-trans (setf %function-self))
+ #!-x86 (self :ref-trans %function-self
+ :set-trans (setf %function-self))
#!+x86 (self
;; KLUDGE: There's no :SET-KNOWN, :SET-TRANS, :REF-KNOWN, or
;; :REF-TRANS here in this case. Instead, there's separate
;; stuff here in order to allow this old hack to work in the
;; new world. -- WHN 2001-08-82
)
- #!+gengc (entry-point :c-type "char *")
(next :type (or function null)
:ref-known (flushable)
:ref-trans %function-next
:set-trans (setf %function-type))
(code :rest-p t :c-type "unsigned char"))
-#!-gengc
(define-primitive-object (return-pc :lowtag other-pointer-type :header t)
(return-point :c-type "unsigned char" :rest-p t))
(define-primitive-object (closure :lowtag function-pointer-type
:header closure-header-type)
- #!-gengc (function :init :arg :ref-trans %closure-function)
- #!+gengc (entry-point :c-type "char *")
+ (function :init :arg :ref-trans %closure-function)
(info :rest-p t))
(define-primitive-object (funcallable-instance
:lowtag function-pointer-type
:header funcallable-instance-header-type
:alloc-trans %make-funcallable-instance)
- #!-(or gengc x86)
+ #!-x86
(function
:ref-known (flushable) :ref-trans %funcallable-instance-function
:set-known (unsafe) :set-trans (setf %funcallable-instance-function))
;; the new world of sbcl-0.6.12.63, where multiple DEFKNOWNs for
;; the same operator cause an error (instead of silently deleting
;; all information associated with the old DEFKNOWN, as before).
- ;; It's definitely not very clean, with too many #!+ conditionals,
- ;; too little documentation, and an implicit assumption that GENGC
- ;; and X86 are mutually exclusive, but I have more urgent things to
+ ;; It's definitely not very clean, with too many #!+ conditionals and
+ ;; too little documentation, but I have more urgent things to
;; clean up right now, so I've just left it as a literal
;; translation without trying to fix it. -- WHN 2001-08-02
)
- #!+gengc (entry-point :c-type "char *")
(lexenv :ref-known (flushable) :ref-trans %funcallable-instance-lexenv
:set-known (unsafe) :set-trans (setf %funcallable-instance-lexenv))
(layout :init :arg
\f
;;;; symbols
-#!+gengc
-(defknown %make-symbol (index simple-string) symbol
- (flushable movable))
-
-#!+gengc
-(defknown symbol-hash (symbol) index
- (flushable movable))
-
#!+x86
(defknown symbol-hash (symbol) (integer 0 #.*target-most-positive-fixnum*)
(flushable movable))
(define-primitive-object (symbol :lowtag other-pointer-type
:header symbol-header-type
- #!-x86 :alloc-trans
- #!-(or gengc x86) make-symbol
- #!+gengc %make-symbol)
+ #!-x86 :alloc-trans #!-x86 make-symbol)
(value :set-trans %set-symbol-value
:init :unbound)
- #!-(or gengc x86) unused
- #!+gengc (hash :init :arg)
#!+x86 (hash)
(plist :ref-trans symbol-plist
:set-trans %set-symbol-plist
name offset lowtag res)
(move-continuation-result node block locs cont)))
-#!+gengc
-(defun needs-remembering (cont)
- (if (csubtypep (continuation-type cont)
- (load-time-value (specifier-type '(or fixnum character
- (member t nil)))))
- nil
- t))
-
(defoptimizer ir2-convert-setter ((object value) node block name offset lowtag)
(let ((value-tn (continuation-tn node block value)))
(vop set-slot node block (continuation-tn node block object) value-tn
- name offset lowtag #!+gengc (needs-remembering value))
+ name offset lowtag)
(move-continuation-result node block (list value-tn) (node-cont node))))
(defoptimizer ir2-convert-setfer ((value object) node block name offset lowtag)
(let ((value-tn (continuation-tn node block value)))
(vop set-slot node block (continuation-tn node block object) value-tn
- name offset lowtag #!+gengc (needs-remembering value))
+ name offset lowtag)
(move-continuation-result node block (list value-tn) (node-cont node))))
(defun do-inits (node block name result lowtag inits args)
tn))))
(:null
(emit-constant nil)))
- name slot lowtag #!+gengc nil))))
+ name slot lowtag))))
(aver (null args)))
(defun do-fixed-alloc (node block name words type lowtag result)
- #!-gengc
- (vop fixed-alloc node block name words type lowtag result)
- #!+gengc
- (if (>= words sb!vm:large-object-cutoff)
- (vop large-alloc node block (emit-constant (logandc2 (1+ words) 1))
- (emit-constant lowtag) (emit-constant type) (emit-constant 0) name
- result)
- (vop fixed-alloc node block name words type lowtag result)))
+ (vop fixed-alloc node block name words type lowtag result))
(defoptimizer ir2-convert-fixed-allocation
((&rest args) node block name words type lowtag inits)
type lowtag result))
(do-inits node block name result lowtag inits args)
(move-continuation-result node block locs cont)))
-
-
-\f
-;;;; other allocation support
-
-#!+gengc
-(defoptimizer (make-array-header ir2-convert) ((type rank) node block)
- (let* ((cont (node-cont node))
- (locs (continuation-result-tns cont
- (list *backend-t-primitive-type*)))
- (result (first locs)))
- (if (and (constant-continuation-p type)
- (constant-continuation-p rank))
- (do-fixed-alloc node block 'make-array-header
- (+ (continuation-value rank)
- sb!vm:array-dimensions-offset)
- (continuation-value type)
- sb!vm:other-pointer-type result)
- (vop make-array-header node block (continuation-tn node block type)
- (continuation-tn node block rank) result))
- (move-continuation-result node block locs cont)))
-\f
-;;;; replacements for stuff in ir2tran to make gengc work
-
-#!+gengc
-(defun ir2-convert-closure (node block leaf res)
- (declare (type ref node) (type ir2-block block)
- (type functional leaf) (type tn res))
- (unless (leaf-info leaf)
- (setf (leaf-info leaf) (make-entry-info)))
- (let ((entry (make-load-time-constant-tn :entry leaf))
- (closure (etypecase leaf
- (clambda
- (environment-closure (get-lambda-environment leaf)))
- (functional
- (aver (eq (functional-kind leaf) :top-level-xep))
- nil))))
- (if closure
- (let ((this-env (node-environment node)))
- #!+gengc (let ((temp (make-normal-tn *backend-t-primitive-type*)))
- (do-fixed-alloc node block 'make-closure
- (+ (length closure)
- sb!vm:closure-info-offset)
- sb!vm:closure-header-type
- sb!vm:function-pointer-type
- res)
- (emit-move node block entry temp)
- (vop %set-function-self node block temp res temp))
- ;; KLUDGE: #!-GENGC nested inside #!+GENGC doesn't make much sense;
- ;; it's just a literal translation of the CMU CL distinction between
- ;; host and backend. If GENGC code is ever revived, this should be
- ;; cleaned up.
- #!-gengc (vop make-closure node block entry (length closure) res)
- (loop for what in closure and n from 0 do
- (unless (and (lambda-var-p what)
- (null (leaf-refs what)))
- (vop closure-init node block
- res
- (find-in-environment what this-env)
- n
- nil))))
- (emit-move node block entry res)))
- (values))
-
-#!+gengc
-(defun ir2-convert-set (node block)
- (declare (type cset node) (type ir2-block block))
- (let* ((cont (node-cont node))
- (leaf (set-var node))
- (value (set-value node))
- (val-tn (continuation-tn node block value))
- (locs (if (continuation-info cont)
- (continuation-result-tns
- cont (list (primitive-type (leaf-type leaf))))
- nil)))
- (etypecase leaf
- (lambda-var
- (when (leaf-refs leaf)
- (let ((tn (find-in-environment leaf (node-environment node))))
- (if (lambda-var-indirect leaf)
- (vop value-cell-set node block tn val-tn
- (needs-remembering value))
- (emit-move node block val-tn tn)))))
- (global-var
- (ecase (global-var-kind leaf)
- ((:special :global)
- (aver (symbolp (leaf-name leaf)))
- (vop set node block (emit-constant (leaf-name leaf)) val-tn
- (needs-remembering value))))))
-
- (when locs
- (emit-move node block val-tn (first locs))
- (move-continuation-result node block locs cont)))
- (values))
-
-#!+gengc
-(defoptimizer (%lexical-exit-breakup ir2-convert) ((info) node block)
- (vop value-cell-set node block
- (find-in-environment (continuation-value info) (node-environment node))
- (emit-constant 0)
- nil))
-
-#!+gengc
-(defoptimizer (%slot-setter ir2-convert) ((value str) node block)
- (let ((val (continuation-tn node block value)))
- (vop instance-set node block
- (continuation-tn node block str)
- val
- (dsd-index
- (slot-accessor-slot
- (ref-leaf
- (continuation-use
- (combination-fun node)))))
- (needs-remembering value))
-
- (move-continuation-result node block (list val) (node-cont node))))
;;; the called function, since local call analysis converts all
;;; closure references. If a TL-XEP, we know it is not a closure.
;;;
-;;; If a closed-over lambda-var has no refs (is deleted), then we
+;;; If a closed-over LAMBDA-VAR has no refs (is deleted), then we
;;; don't initialize that slot. This can happen with closures over
;;; top-level variables, where optimization of the closure deleted the
;;; variable. Since we committed to the closure format when we
;;; pre-analyzed the top-level code, we just leave an empty slot.
-#!-gengc
(defun ir2-convert-closure (node block leaf res)
(declare (type ref node) (type ir2-block block)
(type functional leaf) (type tn res))
(declaim (ftype (function (list) (simple-array tt-entry 1)) pack-trace-table))
(defun pack-trace-table (entries)
(declare (list entries))
- #!-gengc (declare (ignore entries))
- #!+gengc (let ((result (make-array (logandc2 (1+ (length entries)) 1)
- :element-type 'tt-entry))
- (index 0)
- (last-posn 0)
- (last-state 0))
- (declare (type index index last-posn)
- (type tt-state last-state))
- (flet ((push-entry (offset state)
- (declare (type tt-offset offset)
- (type tt-state state))
- (when (>= index (length result))
- (setf result
- (replace (make-array
- (truncate (* (length result) 5) 4)
- :element-type
- 'tt-entry)
- result)))
- (setf (aref result index)
- (logior (ash offset tt-bits-per-state) state))
- (incf index)))
- (dolist (entry entries)
- (let* ((posn (label-position (car entry)))
- (state (cdr entry)))
- (declare (type index posn) (type tt-state state))
- (aver (<= last-posn posn))
- (do ((offset (- posn last-posn) (- offset tt-max-offset)))
- ((< offset tt-max-offset)
- (push-entry offset state))
- (push-entry tt-max-offset last-state))
- (setf last-posn posn)
- (setf last-state state)))
- (when (oddp index)
- (push-entry 0 last-state)))
- (if (eql (length result) index)
- result
- (subseq result 0 index)))
- #!-gengc (make-array 0 :element-type 'tt-entry))
+ (declare (ignore entries))
+ ;; (This was interesting under the old CMU CL generational garbage
+ ;; collector (GENGC) but is trivial under the GC implementations
+ ;; used in SBCL.)
+ (make-array 0 :element-type 'tt-entry))
(inst jmp :o bignum)
(emit-label done)
;; KLUDGE: The sequence above leaves a DESCRIPTOR-REG Y in a
- ;; non-descriptor state for a while. Does that matter? Does it matter in
- ;; GENGC but not in GENCGC? Is this written down anywhere?
+ ;; non-descriptor state for a while. Does that matter? Does it
+ ;; matter in GENGC but not in GENCGC? Is this written down
+ ;; anywhere?
;; -- WHN 19990916
;;
;; Also, the sequence above seems rather twisty. Why not something
;;; for internal versions, especially for internal versions off the
;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.pre7.47"
+"0.pre7.48"
projects / sbcl.git / commitdiff