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   ;; A hashtable translating ENTRY-INFO structures to the corresponding actual
  22   ;; FUNCTIONs for functions in this compilation.
  23   (entry-table (make-hash-table :test 'eq) :type hash-table)
  24   ;; A hashtable translating ENTRY-INFO structures to a list of pairs
  25   ;; (<code object> . <offset>) describing the places that need to be
  26   ;; backpatched to point to the function for ENTRY-INFO.
  27   (patch-table (make-hash-table :test 'eq) :type hash-table)
  28   ;; A list of all the DEBUG-INFO objects created, kept so that we can
  29   ;; backpatch with the source info.
  30   (debug-info () :type list))
  31
  32 ;;; Note the existence of FUNCTION.
  33 (defun note-function (info function object)
  34   (declare (type function function)
  35            (type core-object object))
  36   (let ((patch-table (core-object-patch-table object)))
  37     (dolist (patch (gethash info patch-table))
  38       (setf (code-header-ref (car patch) (the index (cdr patch))) function))
  39     (remhash info patch-table))
  40   (setf (gethash info (core-object-entry-table object)) function)
  41   (values))
  42
  43 ;;; Do "load-time" fixups on the code vector.
  44 (defun do-core-fixups (code fixups)
  45   (declare (list fixups))
  46   (dolist (info fixups)
  47     (let* ((kind (first info))
  48            (fixup (second info))
  49            (name (fixup-name fixup))
  50            (flavor (fixup-flavor fixup))
  51            (offset (third info))
  52            (value (ecase flavor
  53                     (:assembly-routine
  54                      (assert (symbolp name))
  55                      (or (gethash name *assembler-routines*)
  56                          (error "undefined assembler routine: ~S" name)))
  57                     (:foreign
  58                      (assert (stringp name))
  59                      (or (sb!impl::foreign-symbol-address-as-integer name)
  60                          (error "unknown foreign symbol: ~S")))
  61                     #!+x86
  62                     (:code-object
  63                      (assert (null name))
  64                      (values (get-lisp-obj-address code) t)))))
  65       (sb!vm:fixup-code-object code offset value kind))))
  66
  67 ;;; Stick a reference to the function Fun in Code-Object at index I. If the
  68 ;;; function hasn't been compiled yet, make a note in the Patch-Table.
  69 (defun reference-core-function (code-obj i fun object)
  70   (declare (type core-object object) (type functional fun)
  71            (type index i))
  72   (let* ((info (leaf-info fun))
  73          (found (gethash info (core-object-entry-table object))))
  74     (if found
  75         (setf (code-header-ref code-obj i) found)
  76         (push (cons code-obj i)
  77               (gethash info (core-object-patch-table object)))))
  78   (values))
  79
  80 ;;; Call the top-level lambda function dumped for Entry, returning the
  81 ;;; values. Entry may be a :TOP-LEVEL-XEP functional.
  82 (defun core-call-top-level-lambda (entry object)
  83   (declare (type functional entry) (type core-object object))
  84   (funcall (or (gethash (leaf-info entry)
  85                         (core-object-entry-table object))
  86                (error "Unresolved forward reference."))))
  87
  88 ;;; Backpatch all the DEBUG-INFOs dumped so far with the specified
  89 ;;; SOURCE-INFO list. We also check that there are no outstanding forward
  90 ;;; references to functions.
  91 (defun fix-core-source-info (info object source-info)
  92   (declare (type source-info info) (type core-object object))
  93   (assert (zerop (hash-table-count (core-object-patch-table object))))
  94   (let ((res (debug-source-for-info info)))
  95     (dolist (sinfo res)
  96       (setf (debug-source-info sinfo) source-info))
  97     (dolist (info (core-object-debug-info object))
  98       (setf (compiled-debug-info-source info) res))
  99     (setf (core-object-debug-info object) ()))
 100   (values))