0.8.12.38:
[sbcl.git] / src / code / foreign.lisp
index 29d1d7a..fc4a3b8 100644 (file)
 
 (in-package "SB-ALIEN") ; (SB-ALIEN, not SB!ALIEN, since we're in warm load.)
 
-;;; SEMI-KLUDGE: Preferable would be to use something like O_NOFOLLOW
-;;; which will refuse to open() a file if it is a symlink; but I've
-;;; been told that is a FreeBSD/Linux-only thing.  Meanwhile, this will
-;;; make our filenames a lot less predictable.
-;;; (The man file for open() says O_EXCL should treat even a symlink as
-;;; an existing file.  I wonder if it really does that.)
-;;; Also, no more dependence on ASCII character ordering.
-;;; -- mrd 20021101
-(defun generate-random-string (&optional (len 6))
-  (let* ((characters "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789")
-        (num (length characters))
-        (string (make-string len)))
-    (dotimes (i len string)
-      (setf (char string i)
-           (char characters (random num))))))
-
-(defun pick-temporary-file-name (&optional
-                                (base "/tmp/sbcl-tmp-~D~A"))
-  (let ((code (generate-random-string)))
-    (loop
-      (let ((name (format nil base (sb-unix:unix-getpid) code)))
-       (multiple-value-bind (fd errno)
-           (sb-unix:unix-open name
-                              (logior sb-unix:o_wronly
-                                      sb-unix:o_creat
-                                      sb-unix:o_excl)
-                              #o666)
-         (cond ((not (null fd))
-                (sb-unix:unix-close fd)
-                (return name))
-               ((not (= errno sb-unix:eexist))
-                (simple-file-perror "couldn't create temporary file ~S"
-                                    name
-                                    errno))
-               (t
-                (setf code (generate-random-string)))))))))
-
 ;;; On any OS where we don't support foreign object file loading, any
 ;;; query of a foreign symbol value is answered with "no definition
 ;;; known", i.e. NIL.
 ;;; work on any ELF system with dlopen(3) and dlsym(3)
 ;;; It also works on OpenBSD, which isn't ELF, but is otherwise modern
 ;;; enough to have a fairly well working dlopen/dlsym implementation.
-#-(or linux sunos FreeBSD OpenBSD NetBSD darwin)
-(macrolet ((define-unsupported-fun (fun-name)
+(macrolet ((define-unsupported-fun (fun-name &optional (error-message "unsupported on this system"))
             `(defun ,fun-name (&rest rest)
-               "unsupported on this system"
+               ,error-message
                 (declare (ignore rest))
                (error 'unsupported-operator :name ',fun-name))))
-  (define-unsupported-fun load-1-foreign)
-  (define-unsupported-fun load-foreign))
-#+(or linux sunos FreeBSD OpenBSD NetBSD darwin)
-(progn
+  #-(or linux sunos FreeBSD OpenBSD NetBSD darwin)
+  (define-unsupported-fun load-shared-object)
+  #+(or linux sunos FreeBSD OpenBSD NetBSD darwin)
+  (progn
 
-;;; flags for dlopen()
-(defconstant rtld-lazy 1)              ; lazy function call binding?
-(defconstant rtld-now 2)               ; immediate function call binding?
-(defconstant rtld-global #x100)                ; symbols of loaded obj file
-                                       ; (and its dependencies) made
-                                       ; visible (as though the
-                                       ; obj file were linked directly
-                                       ; into the program)?
+    (define-unsupported-fun load-foreign "Unsupported as of SBCL 0.8.13.")
+    (define-unsupported-fun load-1-foreign "Unsupported as of SBCL 0.8.13. Please use LOAD-SHARED-OBJECT.")
 
 ;;; a list of handles returned from dlopen(3) (or possibly some
 ;;; bogus value temporarily during initialization)
-(defvar *handles-from-dlopen* nil)
+    (defvar *handles-from-dlopen* nil)
 
 ;;; Dynamically loaded stuff isn't there upon restoring from a save.
 ;;; Clearing the variable this way was originally done primarily for
 ;;; dan 2001.05.10 suspects that objection (1) is bogus for
 ;;; dlsym()-enabled systems
 
-(push (lambda () (setq *handles-from-dlopen* nil))
-      *after-save-initializations*)
+    (push (lambda () (setq *handles-from-dlopen* nil))
+         *after-save-initializations*)
 
-(defvar *dso-linker* "/usr/bin/ld")
-(defvar *dso-linker-options*
-  #-darwin '("-shared" "-o")
-  #+darwin '("-bundle" "-o"))
-
-(sb-alien:define-alien-routine dlopen system-area-pointer
-  (file sb-alien:c-string) (mode sb-alien:int))
-(sb-alien:define-alien-routine dlsym system-area-pointer
-  (lib system-area-pointer)
-  (name sb-alien:c-string))
-(sb-alien:define-alien-routine dlerror sb-alien:c-string)
+    (sb-alien:define-alien-routine dlopen system-area-pointer
+      (file sb-alien:c-string) (mode sb-alien:int))
+    (sb-alien:define-alien-routine dlsym system-area-pointer
+      (lib system-area-pointer)
+      (name sb-alien:c-string))
+    (sb-alien:define-alien-routine dlerror sb-alien:c-string)
 
 ;;; Ensure that we've opened our own binary so we can dynamically resolve 
 ;;; symbols in the C runtime.  
 ;;;
 ;;; FIXME: It would work just as well to do it once at startup, actually.
 ;;; Then at least we know it's done.    -dan 2001.05.10
-(defun ensure-runtime-symbol-table-opened ()
-  (unless *handles-from-dlopen*
-    ;; Prevent recursive call if dlopen() isn't defined.
-    (setf *handles-from-dlopen* (int-sap 0))
-    (setf *handles-from-dlopen* (list (dlopen nil rtld-lazy)))
-    (when (zerop (sb-sys:sap-int (first *handles-from-dlopen*)))
-      (error "can't open our own binary's symbol table: ~S" (dlerror)))))
-
-(defun load-1-foreign (file)
-  "the primitive upon which the more general LOAD-FOREIGN is built: load
-  a single foreign object file
-
-  To use LOAD-1-FOREIGN, at the Unix command line do this:
+    (defun ensure-runtime-symbol-table-opened ()
+      (unless *handles-from-dlopen*
+       ;; Prevent recursive call if dlopen() isn't defined.
+       (setf *handles-from-dlopen* (int-sap 0))
+       (setf *handles-from-dlopen* (list (dlopen nil rtld-lazy)))
+       (when (zerop (sb-sys:sap-int (first *handles-from-dlopen*)))
+         (error "can't open our own binary's symbol table: ~S" (dlerror)))))
+
+    (defun load-shared-object (file)
+      "Load a shared library/dynamic shared object file/general
+  dlopenable alien container.
+
+  To use LOAD-SHARED-OBJECT, at the Unix command line do this:
     echo 'int summish(int x, int y) { return 1 + x + y; }' > /tmp/ffi-test.c
     make /tmp/ffi-test.o # i.e. cc -c -o /tmp/ffi-test.o /tmp/ffi-test.c
     ld -shared -o /tmp/ffi-test.so /tmp/ffi-test.o
   then in SBCL do this:
-    (LOAD-1-FOREIGN \"/tmp/ffi-test.so\")
+    (LOAD-SHARED-OBJECT \"/tmp/ffi-test.so\")
     (DEFINE-ALIEN-ROUTINE SUMMISH INT (X INT) (Y INT))
   Now running (SUMMISH 10 20) should return 31.
 "
-  (ensure-runtime-symbol-table-opened)
-  ;; Note: We use RTLD-GLOBAL so that it can find all the symbols
-  ;; previously loaded. We use RTLD-NOW so that dlopen() will fail if
-  ;; not all symbols are defined.
-  (let* ((real-file (or (unix-namestring file) file))
-         (sap (dlopen real-file (logior rtld-now rtld-global))))
-       (if (zerop (sap-int sap))
-          (error "can't open object ~S: ~S" real-file (dlerror))
-          (pushnew sap *handles-from-dlopen* :test #'sap=)))
-  (values))
-
-(defun get-dynamic-foreign-symbol-address (symbol)
-  (ensure-runtime-symbol-table-opened)
-  ;; Find the symbol in any of the loaded object files. Search in
-  ;; reverse order of loading, so that later loadings take precedence.
-  ;;
-  ;; FIXME: The way that we use PUSHNEW SAP in LOAD-1-FOREIGN means
-  ;; that the list isn't guaranteed to be in reverse order of loading,
-  ;; at least not if a file is loaded more than once. Is this the
-  ;; right thing? (In what cases does it matter?)
-  (dolist (handle (reverse *handles-from-dlopen*))
-    ;; KLUDGE: We implicitly exclude the possibility that the variable
-    ;; could actually be NULL, but the man page for dlsym(3) 
-    ;; recommends doing a more careful test. -- WHN 20000825
-    (let ((possible-result (sap-int (dlsym handle symbol))))
-      (unless (zerop possible-result)
-       (return possible-result)))))
-
-;;; Dan Barlow's quick summary from IRC 2003-06-21:
-;;;   fwiw, load-foreign does random stuff with ld so that you can use
-;;;   it with static libraries
-;;;   if you have shared objects, load-1-foreign will do fine
-;;; and
-;;;   I think my position on this matter is consistent with Tim Moore's:
-;;;   use (cmucl equivalent of) load-1-foreign, load-foreign is arse
-;;;   though he may say ass
-(defun load-foreign (files
-                    &key
-                    (libraries '("-lc"))
-                    ;; FIXME: The old documentation said
-                    ;;   The BASE-FILE argument is used to specify a
-                    ;;   file to use as the starting place for
-                    ;;   defined symbols. The default is the C start
-                    ;;   up code for Lisp.
-                    ;; But the code ignored the BASE-FILE argument.
-                    ;; The comment above
-                    ;;   (DECLARE (IGNORE BASE-FILE))
-                    ;; said
-                    ;;   dlopen() remembers the name of an object,
-                    ;;   when dlopen()ing the same name twice, the
-                    ;;   old object is reused.
-                    ;; So I deleted all reference to BASE-FILE,
-                    ;; including the now-bogus reference to the
-                    ;; BASE-FILE argument in the documentation. But
-                    ;; are there any other subtleties of the new code
-                    ;; which need to be documented in its place?
-                    (env nil env-p)
-                    (environment (if env-p
-                                     (unix-environment-sbcl-from-cmu env)
-                                     (posix-environ))
-                                 environment-p))
-  #+sb-doc
-  "LOAD-FOREIGN loads a list of C object files into a running Lisp. The FILES
-  argument should be a single file or a list of files. The files may be
-  specified as namestrings or as pathnames. The libraries argument should be a
-  list of library files as would be specified to ld. They will be searched in
-  the order given. The default is just \"-lc\", i.e., the C library. The
-  ENVIRONMENT argument is a list of SIMPLE-STRINGs corresponding to the Unix
-  environment (\"man environ\") definitions for the invocation of the linker.
-  The default is the environment that Lisp is itself running in. Instead of
-  using the ENVIRONMENT argument, it is also possible to use the ENV argument,
-  using the older, lossy CMU CL representation."
-  (when (and env-p environment-p)
-    (error "can't specify :ENV and :ENVIRONMENT simultaneously"))
-  (let ((output-file (pick-temporary-file-name
-                     (concatenate 'string "/tmp/~D~A" (string (gensym)))))
-       (error-output (make-string-output-stream)))
-
-    (/show "running" *dso-linker*)
-    (force-output)
-    (unwind-protect
-       (let ((proc (sb-ext:run-program
-                    *dso-linker*
-                    (append *dso-linker-options*
-                            (list output-file)
-                            (append (mapcar (lambda (name)
-                                              (unix-namestring name nil))
-                                            (if (atom files)
-                                                (list files)
-                                              files))
-                                    libraries))
-                    :environment environment
-                    :input nil
-                    :output error-output
-                    :error :output)))
-         (unless proc
-           (error "could not run ~A" *dso-linker*))
-         (unless (zerop (sb-ext:process-exit-code proc))
-           (sb-sys:serve-all-events 0)
-           (error "~A failed:~%~A" *dso-linker*
-                  (get-output-stream-string error-output)))
-         (load-1-foreign output-file))
-      #-sb-show (sb-unix:unix-unlink output-file)
-      #+sb-show (/show "not unlinking" output-file)))) ; so we can look at it
-
-) ; PROGN
+      (ensure-runtime-symbol-table-opened)
+      ;; Note: We use RTLD-GLOBAL so that it can find all the symbols
+      ;; previously loaded. We use RTLD-NOW so that dlopen() will fail if
+      ;; not all symbols are defined.
+      (let* ((real-file (or (unix-namestring file) file))
+            (sap (dlopen real-file (logior rtld-now rtld-global))))
+       (if (zerop (sap-int sap))
+           (error "can't open object ~S: ~S" real-file (dlerror))
+           (pushnew sap *handles-from-dlopen* :test #'sap=)))
+      (values))
+
+    (defun get-dynamic-foreign-symbol-address (symbol)
+      (ensure-runtime-symbol-table-opened)
+      ;; Find the symbol in any of the loaded object files. Search in
+      ;; reverse order of loading, so that later loadings take precedence.
+      ;;
+      ;; FIXME: The way that we use PUSHNEW SAP in LOAD-SHARED-OBJECT means
+      ;; that the list isn't guaranteed to be in reverse order of loading,
+      ;; at least not if a file is loaded more than once. Is this the
+      ;; right thing? (In what cases does it matter?)
+      (dolist (handle (reverse *handles-from-dlopen*))
+       ;; KLUDGE: We implicitly exclude the possibility that the variable
+       ;; could actually be NULL, but the man page for dlsym(3) 
+       ;; recommends doing a more careful test. -- WHN 20000825
+       (let ((possible-result (sap-int (dlsym handle symbol))))
+         (unless (zerop possible-result)
+           (return possible-result)))))
+
+    ))                                 ; PROGN, MACROLET