src/code/foreign-load.lisp

   1 ;;;; Loading shared object files
   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!ALIEN")
  13
  14 (define-unsupported-fun load-foreign
  15     "Unsupported as of SBCL 0.8.13. See LOAD-SHARED-OBJECT."
  16   "~S is unsupported as of SBCL 0.8.13. See LOAD-SHARED-OBJECT."
  17   (load-foreign))
  18
  19 (define-unsupported-fun load-1-foreign
  20     "Unsupported as of SBCL 0.8.13. Please use LOAD-SHARED-OBJECT."
  21   "~S is unsupported as of SBCL 0.8.13. Please use LOAD-SHARED-OBJECT."
  22   (load-1-foreign))
  23
  24 (define-alien-routine dlopen system-area-pointer
  25   (file c-string) (mode int))
  26
  27 (define-alien-routine dlclose int
  28   (handle system-area-pointer))
  29
  30 (define-alien-routine dlerror c-string)
  31
  32 (define-alien-routine dlsym system-area-pointer
  33   (handle system-area-pointer)
  34   (symbol c-string))
  35
  36 (defvar *runtime-dlhandle*)
  37 (defvar *shared-objects*)
  38
  39 (defstruct shared-object file sap)
  40
  41 (defun dlopen-or-lose (filename)
  42   (dlerror) ; clear old errors
  43   (let ((sap (dlopen filename (logior rtld-global rtld-now))))
  44     (when (zerop (sap-int sap))
  45       (error "Could not open ~:[runtime~;~:*shared object ~S~]: ~A"
  46              filename (dlerror)))
  47     sap))
  48
  49 (defun load-shared-object (file)
  50   "Load a shared library/dynamic shared ob\0ject file/general
  51 dlopenable alien container, such as a .so on an ELF platform.
  52
  53 References to foreign symbols in loaded shared objects do not survive
  54 intact through SB-EXT:SAVE-LISP-AND die on all platforms. See
  55 SB-EXT:SAVE-LISP-AND-DIE for details."
  56   (let* ((real-file (or (unix-namestring file) file))
  57          (sap (dlopen-or-lose real-file))
  58          (obj (make-shared-object :file real-file :sap sap)))
  59     (unless (member sap *shared-objects*
  60                     :test #'sap= :key #'shared-object-sap)
  61       (setf *shared-objects* (append *shared-objects* (list obj))))
  62     (pathname real-file)))
  63
  64 (defun try-reopen-shared-object (obj)
  65   (restart-case
  66       (let ((sap (dlopen-or-lose (shared-object-file obj))))
  67         (setf (shared-object-sap obj) sap)
  68         obj)
  69     (skip ()
  70       :report "Skip this shared object and continue. References to ~
  71                foreign symbols in this shared object will fail, ~
  72                causing potential corruption."
  73       *runtime-dlhandle*)))
  74
  75 ;;; Open libraries in *SHARED-OBJECTS* and the runtime. Called during
  76 ;;; initialization.
  77 (defun reopen-shared-objects ()
  78   ;; Ensure that the runtime is present in the list
  79   (setf *runtime-dlhandle* (dlopen-or-lose nil)
  80         *shared-objects* (mapcar #'try-reopen-shared-object *shared-objects*)))
  81
  82 ;;; Close all dlopened libraries and clear out sap entries in
  83 ;;; *SHARED-OBJECTS*.
  84 (defun close-shared-objects ()
  85   (dolist (obj (reverse *shared-objects*))
  86     (dlclose (shared-object-sap obj))
  87     (setf (shared-object-sap obj) nil))
  88   (dlclose *runtime-dlhandle*)
  89   (setf *runtime-dlhandle* nil))
  90
  91 (defun get-dynamic-foreign-symbol-address (symbol)
  92   (dlerror) ; clear old errors
  93   (let ((result (sap-int (dlsym *runtime-dlhandle* symbol)))
  94         (err (dlerror)))
  95     (if (or (not (zerop result)) (not err))
  96         result
  97         (dolist (obj *shared-objects*)
  98           (setf result (sap-int (dlsym (shared-object-sap obj) symbol))
  99                 err (dlerror))
 100           (when (or (not (zerop result)) (not err))
 101             (return result))))))