src/compiler/generic/core.lisp

   1 ;;;; stuff that knows how to load compiled code directly into core
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!C")
  13
  14 ;;; A CORE-OBJECT structure holds the state needed to resolve cross-component
  15 ;;; references during in-core compilation.
  16 (defstruct (core-object
  17             (:constructor make-core-object ())
  18             #-no-ansi-print-object
  19             (:print-object (lambda (x s)
  20                              (print-unreadable-object (x s :type t))))
  21             (:copier nil))
  22   ;; A hashtable translating ENTRY-INFO structures to the corresponding actual
  23   ;; FUNCTIONs for functions in this compilation.
  24   (entry-table (make-hash-table :test 'eq) :type hash-table)
  25   ;; A hashtable translating ENTRY-INFO structures to a list of pairs
  26   ;; (<code object> . <offset>) describing the places that need to be
  27   ;; backpatched to point to the function for ENTRY-INFO.
  28   (patch-table (make-hash-table :test 'eq) :type hash-table)
  29   ;; A list of all the DEBUG-INFO objects created, kept so that we can
  30   ;; backpatch with the source info.
  31   (debug-info () :type list))
  32
  33 ;;; Note the existence of FUNCTION.
  34 (defun note-fun (info function object)
  35   (declare (type function function)
  36            (type core-object object))
  37   (let ((patch-table (core-object-patch-table object)))
  38     (dolist (patch (gethash info patch-table))
  39       (setf (code-header-ref (car patch) (the index (cdr patch))) function))
  40     (remhash info patch-table))
  41   (setf (gethash info (core-object-entry-table object)) function)
  42   (values))
  43
  44 ;;; Do "load-time" fixups on the code vector.
  45 (defun do-core-fixups (code fixup-notes)
  46   (declare (list fixup-notes))
  47   (dolist (note fixup-notes)
  48     (let* ((kind (fixup-note-kind note))
  49            (fixup (fixup-note-fixup note))
  50            (position (fixup-note-position note))
  51            (name (fixup-name fixup))
  52            (flavor (fixup-flavor fixup))
  53            (value (ecase flavor
  54                     (:assembly-routine
  55                      (aver (symbolp name))
  56                      (or (gethash name *assembler-routines*)
  57                          (error "undefined assembler routine: ~S" name)))
  58                     (:foreign
  59                      (aver (stringp name))
  60                      ;; FOREIGN-SYMBOL-ADDRESS signals an error
  61                      ;; if the symbol isn't found.
  62                      (foreign-symbol-address name))
  63                     #!+linkage-table
  64                     (:foreign-dataref
  65                      (aver (stringp name))
  66                      (foreign-symbol-address name t))
  67                     #!+(or x86 x86-64)
  68                     (:code-object
  69                      (aver (null name))
  70                      (values (get-lisp-obj-address code) t)))))
  71       (sb!vm:fixup-code-object code position value kind))))
  72
  73 ;;; Stick a reference to the function FUN in CODE-OBJECT at index I. If the
  74 ;;; function hasn't been compiled yet, make a note in the patch table.
  75 (defun reference-core-fun (code-obj i fun object)
  76   (declare (type core-object object) (type functional fun)
  77            (type index i))
  78   (let* ((info (leaf-info fun))
  79          (found (gethash info (core-object-entry-table object))))
  80     (if found
  81         (setf (code-header-ref code-obj i) found)
  82         (push (cons code-obj i)
  83               (gethash info (core-object-patch-table object)))))
  84   (values))
  85
  86 ;;; Call the top level lambda function dumped for ENTRY, returning the
  87 ;;; values. ENTRY may be a :TOPLEVEL-XEP functional.
  88 (defun core-call-toplevel-lambda (entry object)
  89   (declare (type functional entry) (type core-object object))
  90   (funcall (or (gethash (leaf-info entry)
  91                         (core-object-entry-table object))
  92                (error "Unresolved forward reference."))))
  93
  94 ;;; Backpatch all the DEBUG-INFOs dumped so far with the specified
  95 ;;; SOURCE-INFO list. We also check that there are no outstanding
  96 ;;; forward references to functions.
  97 (defun fix-core-source-info (info object &optional function)
  98   (declare (type core-object object)
  99            (type (or null function) function))
 100   (aver (zerop (hash-table-count (core-object-patch-table object))))
 101   (let ((source (debug-source-for-info info :function function)))
 102     (dolist (info (core-object-debug-info object))
 103       (setf (debug-info-source info) source)))
 104   (setf (core-object-debug-info object) nil)
 105   (values))