X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fcore.lisp;h=c5d941159e499bce1e4b5563bf55a3946091ee4d;hb=f12f2c5a8ae794dc414dd6a42e0b25740d576aa1;hp=7ca43577f21a7f7d40089e4b8b5793e6103cc7b2;hpb=3bd7a97d1b11a2b0aee086ef211cae807f3dfc35;p=sbcl.git diff --git a/src/compiler/generic/core.lisp b/src/compiler/generic/core.lisp index 7ca4357..c5d9411 100644 --- a/src/compiler/generic/core.lisp +++ b/src/compiler/generic/core.lisp @@ -14,11 +14,11 @@ ;;; A CORE-OBJECT structure holds the state needed to resolve cross-component ;;; references during in-core compilation. (defstruct (core-object - (:constructor make-core-object ()) - #-no-ansi-print-object - (:print-object (lambda (x s) - (print-unreadable-object (x s :type t)))) - (:copier nil)) + (:constructor make-core-object ()) + #-no-ansi-print-object + (:print-object (lambda (x s) + (print-unreadable-object (x s :type t)))) + (:copier nil)) ;; A hashtable translating ENTRY-INFO structures to the corresponding actual ;; FUNCTIONs for functions in this compilation. (entry-table (make-hash-table :test 'eq) :type hash-table) @@ -31,9 +31,9 @@ (debug-info () :type list)) ;;; Note the existence of FUNCTION. -(defun note-function (info function object) +(defun note-fun (info function object) (declare (type function function) - (type core-object object)) + (type core-object object)) (let ((patch-table (core-object-patch-table object))) (dolist (patch (gethash info patch-table)) (setf (code-header-ref (car patch) (the index (cdr patch))) function)) @@ -42,60 +42,65 @@ (values)) ;;; Do "load-time" fixups on the code vector. -(defun do-core-fixups (code fixups) - (declare (list fixups)) - (dolist (info fixups) - (let* ((kind (first info)) - (fixup (second info)) - (name (fixup-name fixup)) - (flavor (fixup-flavor fixup)) - (offset (third info)) - (value (ecase flavor - (:assembly-routine - (aver (symbolp name)) - (or (gethash name *assembler-routines*) - (error "undefined assembler routine: ~S" name))) - (:foreign - (aver (stringp name)) - (or (foreign-symbol-address-as-integer name) - (error "unknown foreign symbol: ~S"))) - #!+x86 - (:code-object - (aver (null name)) - (values (get-lisp-obj-address code) t))))) - (sb!vm:fixup-code-object code offset value kind)))) +(defun do-core-fixups (code fixup-notes) + (declare (list fixup-notes)) + (dolist (note fixup-notes) + (let* ((kind (fixup-note-kind note)) + (fixup (fixup-note-fixup note)) + (position (fixup-note-position note)) + (name (fixup-name fixup)) + (flavor (fixup-flavor fixup)) + (value (ecase flavor + (:assembly-routine + (aver (symbolp name)) + (or (gethash name *assembler-routines*) + (error "undefined assembler routine: ~S" name))) + (:foreign + (aver (stringp name)) + ;; FOREIGN-SYMBOL-ADDRESS signals an error + ;; if the symbol isn't found. + (foreign-symbol-address name)) + #!+linkage-table + (:foreign-dataref + (aver (stringp name)) + (foreign-symbol-address name t)) + #!+(or x86 x86-64) + (:code-object + (aver (null name)) + (values (get-lisp-obj-address code) t))))) + (sb!vm:fixup-code-object code position value kind)))) -;;; Stick a reference to the function Fun in Code-Object at index I. If the -;;; function hasn't been compiled yet, make a note in the Patch-Table. -(defun reference-core-function (code-obj i fun object) +;;; Stick a reference to the function FUN in CODE-OBJECT at index I. If the +;;; function hasn't been compiled yet, make a note in the patch table. +(defun reference-core-fun (code-obj i fun object) (declare (type core-object object) (type functional fun) - (type index i)) + (type index i)) (let* ((info (leaf-info fun)) - (found (gethash info (core-object-entry-table object)))) + (found (gethash info (core-object-entry-table object)))) (if found - (setf (code-header-ref code-obj i) found) - (push (cons code-obj i) - (gethash info (core-object-patch-table object))))) + (setf (code-header-ref code-obj i) found) + (push (cons code-obj i) + (gethash info (core-object-patch-table object))))) (values)) -;;; Call the top-level lambda function dumped for Entry, returning the -;;; values. Entry may be a :TOP-LEVEL-XEP functional. -(defun core-call-top-level-lambda (entry object) +;;; Call the top level lambda function dumped for ENTRY, returning the +;;; values. ENTRY may be a :TOPLEVEL-XEP functional. +(defun core-call-toplevel-lambda (entry object) (declare (type functional entry) (type core-object object)) (funcall (or (gethash (leaf-info entry) - (core-object-entry-table object)) - (error "Unresolved forward reference.")))) + (core-object-entry-table object)) + (error "Unresolved forward reference.")))) ;;; Backpatch all the DEBUG-INFOs dumped so far with the specified -;;; SOURCE-INFO list. We also check that there are no outstanding forward -;;; references to functions. -(defun fix-core-source-info (info object &optional source-info) - (declare (type source-info info) (type core-object object)) +;;; SOURCE-INFO list. We also check that there are no outstanding +;;; forward references to functions. +(defun fix-core-source-info (info object &optional function) + (declare (type core-object object) + (type (or null function) function)) (aver (zerop (hash-table-count (core-object-patch-table object)))) - (let ((res (debug-source-for-info info))) - (dolist (sinfo res) - (setf (debug-source-info sinfo) source-info)) + (let ((source (debug-source-for-info info))) + (setf (debug-source-function source) function) (dolist (info (core-object-debug-info object)) - (setf (compiled-debug-info-source info) res)) - (setf (core-object-debug-info object) ())) + (setf (debug-info-source info) source))) + (setf (core-object-debug-info object) nil) (values))