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 :identity 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 #-sb-xc-host ; There is no (SETF CODE-HEADER-REF) so this can't work.
  35 (defun note-fun (info function object)
  36   (declare (type function function)
  37            (type core-object object))
  38   (let ((patch-table (core-object-patch-table object)))
  39     (dolist (patch (gethash info patch-table))
  40       (setf (code-header-ref (car patch) (the index (cdr patch))) function))
  41     (remhash info patch-table))
  42   (setf (gethash info (core-object-entry-table object)) function)
  43   (values))
  44
  45 ;;; Do "load-time" fixups on the code vector.
  46 ;;; But the host never compiles to core, and there is no GET-LISP-OBJ-ADDRESS,
  47 ;;; FIXUP-CODE-OBJECT, or ENSURE-SYMBOL-TLS-INDEX.
  48 #-sb-xc-host
  49 (defun do-core-fixups (code fixup-notes)
  50   (declare (list fixup-notes))
  51   (dolist (note fixup-notes)
  52     (let* ((kind (fixup-note-kind note))
  53            (fixup (fixup-note-fixup note))
  54            (position (fixup-note-position note))
  55            (name (fixup-name fixup))
  56            (flavor (fixup-flavor fixup))
  57            (value (ecase flavor
  58                     (:assembly-routine
  59                      (or (get-asm-routine name)
  60                          (error "undefined assembler routine: ~S" name)))
  61                     (:foreign
  62                      (aver (stringp name))
  63                      ;; FOREIGN-SYMBOL-ADDRESS signals an error
  64                      ;; if the symbol isn't found.
  65                      (foreign-symbol-address name))
  66                     #!+linkage-table
  67                     (:foreign-dataref
  68                      (aver (stringp name))
  69                      (foreign-symbol-address name t))
  70                     #!+(or x86 x86-64)
  71                     (:code-object
  72                      (aver (null name))
  73                      (get-lisp-obj-address code))
  74                     #!+immobile-space
  75                     ((:immobile-object :layout)
  76                      (get-lisp-obj-address (the (or layout symbol) name)))
  77                     #!+immobile-code
  78                     (:named-call
  79                      (sb!vm::fdefn-entry-address name))
  80                     #!+immobile-code
  81                     (:static-call
  82                      (sb!vm::function-raw-address name))
  83                     (:symbol-tls-index
  84                      (ensure-symbol-tls-index (the symbol name))))))
  85       (sb!vm:fixup-code-object code position value kind flavor))))
  86
  87 ;;; Stick a reference to the function FUN in CODE-OBJECT at index I. If the
  88 ;;; function hasn't been compiled yet, make a note in the patch table.
  89 #-sb-xc-host ; no (SETF CODE-HEADER-REF)
  90 (defun reference-core-fun (code-obj i fun object)
  91   (declare (type core-object object) (type functional fun)
  92            (type index i))
  93   (let* ((info (leaf-info fun))
  94          (found (gethash info (core-object-entry-table object))))
  95     (if found
  96         (setf (code-header-ref code-obj i) found)
  97         (push (cons code-obj i)
  98               (gethash info (core-object-patch-table object)))))
  99   (values))
 100
 101 ;;; Call the top level lambda function dumped for ENTRY, returning the
 102 ;;; values. ENTRY may be a :TOPLEVEL-XEP functional.
 103 (defun core-call-toplevel-lambda (entry object)
 104   (declare (type functional entry) (type core-object object))
 105   (funcall (or (gethash (leaf-info entry)
 106                         (core-object-entry-table object))
 107                (error "Unresolved forward reference."))))
 108
 109 #!+(and immobile-code (host-feature sb-xc))
 110 (progn
 111   ;; Use FDEFINITION because it strips encapsulations - whether that's
 112   ;; the right behavior for it or not is a separate concern.
 113   ;; If somebody tries (TRACE LENGTH) for example, it should not cause
 114   ;; compilations to fail on account of LENGTH becoming a closure.
 115   (defun sb!vm::function-raw-address (name &aux (fun (fdefinition name)))
 116     (cond ((not fun)
 117            (error "Can't statically link to undefined function ~S" name))
 118           ((not (immobile-space-obj-p fun))
 119            (error "Can't statically link to ~S: code is movable" name))
 120           ((neq (fun-subtype fun) sb!vm:simple-fun-widetag)
 121            (error "Can't statically link to ~S: non-simple function" name))
 122           (t
 123            (let ((addr (get-lisp-obj-address fun)))
 124              (sap-ref-word (int-sap addr)
 125                            (- (ash sb!vm:simple-fun-self-slot sb!vm:word-shift)
 126                               sb!vm:fun-pointer-lowtag))))))
 127
 128   ;; Return the address to which to jump when calling NAME through its fdefn.
 129   (defun sb!vm::fdefn-entry-address (name)
 130     (let ((fdefn (find-or-create-fdefn name)))
 131       (+ (get-lisp-obj-address fdefn)
 132          (ash sb!vm:fdefn-raw-addr-slot sb!vm:word-shift)
 133          (- sb!vm:other-pointer-lowtag)))))