/[cmucl]/src/code/foreign.lisp
ViewVC logotype

Diff of /src/code/foreign.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.46.2.2 by rtoy, Mon Jun 14 14:44:25 2004 UTC revision 1.60 by rtoy, Fri Jan 21 15:44:58 2011 UTC
# Line 11  Line 11 
11  ;;;  ;;;
12  (in-package "SYSTEM")  (in-package "SYSTEM")
13    
14    (intl:textdomain "cmucl")
15    
16  (in-package "ALIEN")  (in-package "ALIEN")
17  (export '(load-foreign))  (export '(load-foreign))
18  (in-package "SYSTEM")  (in-package "SYSTEM")
# Line 28  Line 30 
30  (defconstant foreign-segment-size  #x02000000)  (defconstant foreign-segment-size  #x02000000)
31    
32  (defvar *previous-linked-object-file* nil)  (defvar *previous-linked-object-file* nil)
33  #-(or openbsd linux irix)  #-(or linux bsd svr4 irix)
34  (defvar *foreign-segment-free-pointer* foreign-segment-start)  (defvar *foreign-segment-free-pointer* foreign-segment-start)
35    
36  (defun pick-temporary-file-name (&optional (base "/tmp/tmp~D~C"))  (defun pick-temporary-file-name (&optional (base "/tmp/tmp~D~C"))
# Line 44  Line 46 
46                   (unix:unix-close fd)                   (unix:unix-close fd)
47                   (return name))                   (return name))
48                  ((not (= errno unix:eexist))                  ((not (= errno unix:eexist))
49                   (error "Could not create temporary file ~S: ~A"                   (error (intl:gettext "Could not create temporary file ~S: ~A")
50                          name (unix:get-unix-error-msg errno)))                          name (unix:get-unix-error-msg errno)))
51    
52                  ((= code (char-code #\Z))                  ((= code (char-code #\Z))
# Line 73  Line 75 
75           (addr (int-sap *foreign-segment-free-pointer*))           (addr (int-sap *foreign-segment-free-pointer*))
76           (new-ptr (+ *foreign-segment-free-pointer* memory-needed)))           (new-ptr (+ *foreign-segment-free-pointer* memory-needed)))
77      (when (> new-ptr (+ foreign-segment-start foreign-segment-size))      (when (> new-ptr (+ foreign-segment-start foreign-segment-size))
78        (error "Not enough memory left."))        (error (intl:gettext "Not enough memory left.")))
79      (setf *foreign-segment-free-pointer* new-ptr)      (setf *foreign-segment-free-pointer* new-ptr)
80      (allocate-system-memory-at addr memory-needed)      (allocate-system-memory-at addr memory-needed)
81      addr))      addr))
# Line 86  Line 88 
88  ;;; The following definitions are taken from  ;;; The following definitions are taken from
89  ;;; /usr/include/sys/elf_common.h and /usr/include/sys/elf32.h.  ;;; /usr/include/sys/elf_common.h and /usr/include/sys/elf32.h.
90  ;;;  ;;;
91  #+(or linux bsd svr4)  #+(or linux (and bsd (not darwin)) svr4)
92  (progn  (progn
93  (alien:def-alien-type elf-address      (alien:unsigned 32))  (alien:def-alien-type elf-address      (alien:unsigned 32))
94  (alien:def-alien-type elf-half-word    (alien:unsigned 16))  (alien:def-alien-type elf-half-word    (alien:unsigned 16))
# Line 165  Line 167 
167    (make-array 4 :element-type '(unsigned-byte 8)    (make-array 4 :element-type '(unsigned-byte 8)
168                  :initial-contents '(127 69 76 70))) ; 0x7f-E-L-F                  :initial-contents '(127 69 76 70))) ; 0x7f-E-L-F
169  (defun elf-p (h)  (defun elf-p (h)
170    "Make sure the header starts with the ELF magic value."    _N"Make sure the header starts with the ELF magic value."
171    (dotimes (i 4 t)    (dotimes (i 4 t)
172      (unless (= (alien:deref h i) (aref +elf-magic+ i))      (unless (= (alien:deref h i) (aref +elf-magic+ i))
173        (return nil))))        (return nil))))
174    
175  (defun elf-osabi (h)  (defun elf-osabi (h)
176    "Return the `osabi' field in the padding of the ELF file."    _N"Return the `osabi' field in the padding of the ELF file."
177    (alien:deref h ei-osabi))    (alien:deref h ei-osabi))
178    
179  (defun elf-osabi-name (id)  (defun elf-osabi-name (id)
# Line 194  Line 196 
196      (t (format nil "Unknown ABI (~D)" id))))      (t (format nil "Unknown ABI (~D)" id))))
197    
198  (defun elf-executable-p (n)  (defun elf-executable-p (n)
199    "Given a file type number, determine whether the file is executable."    _N"Given a file type number, determine whether the file is executable."
200    (= n et-executable))    (= n et-executable))
201    
202  (defun file-shared-library-p (pathname)  (defun file-shared-library-p (pathname)
# Line 206  Line 208 
208          (unix:unix-read fd (alien:alien-sap header) (alien:alien-size eheader :bytes))          (unix:unix-read fd (alien:alien-sap header) (alien:alien-size eheader :bytes))
209          (when (elf-p (alien:slot header 'elf-ident))          (when (elf-p (alien:slot header 'elf-ident))
210            (eql et-shared-object (alien:slot header 'elf-type)))))))            (eql et-shared-object (alien:slot header 'elf-type)))))))
211  ) ;; #+(or linux bsd svr4)  ) ;; #+(or linux (and bsd (not darwin)) svr4)
212    
213    
214    
215    ;; Darwin loading of foreign code.  This uses the dlopen shims and thus
216    ;; appears like ELF to the rest of the code in this file.  However testing
217    ;; for shared libs obviously needs to test for Mach-O dylibs, and not
218    ;; ELF shared libraries...
219    #+darwin
220    (progn
221    
222    (alien:def-alien-type machheader
223      (alien:struct nil
224        (magic       (alien:unsigned 32))
225        (cputype     (alien:signed 32))
226        (cpusubtype  (alien:signed 32))
227        (filetype    (alien:unsigned 32))
228        (ncmds       (alien:unsigned 32))
229        (sizeofcmds  (alien:unsigned 32))
230        (flags       (alien:unsigned 32))))
231    
232    ;; values for magic
233    (defconstant mh-magic   #xfeedface)
234    
235    ;; values for filetype
236    (defconstant mh-object        #x1)
237    (defconstant mh-execute       #x2)
238    (defconstant mh-fvmlib        #x3)
239    (defconstant mh-core          #x4)
240    (defconstant mh-preload       #x5)
241    (defconstant mh-dylib         #x6)
242    (defconstant mh-dylinker      #x7)
243    (defconstant mh-bundle        #x8)
244    (defconstant mh-dylib-stub    #x9)
245    
246    ;;; Support for loading multi-arch ("fat") shared libraries.
247    (alien:def-alien-type fat-header
248      (alien:struct nil
249        (magic       (alien:unsigned 32))
250        (nfat-arch   (alien:unsigned 32))))
251    
252    (alien:def-alien-type fat-arch
253      (alien:struct nil
254        (cputype     (alien:signed 32))
255        (cpusubtype  (alien:signed 32))
256        (offset      (alien:unsigned 32))
257        (size        (alien:unsigned 32))
258        (align       (alien:unsigned 32))))
259    
260    (defconstant fat-header-magic #xcafebabe)
261    
262    (defun mach-o-p (h)
263      _N"Make sure the header starts with the mach-o magic value."
264      (eql (alien:slot h 'magic) mh-magic))
265    
266    ;;; Read an unsigned 32-bit big-endian number from STREAM.
267    (defun read-u32-be (stream)
268      (let ((n 0))
269        (setf (ldb (byte 8 24) n) (read-byte stream))
270        (setf (ldb (byte 8 16) n) (read-byte stream))
271        (setf (ldb (byte 8 8)  n) (read-byte stream))
272        (setf (ldb (byte 8 0)  n) (read-byte stream))
273        n))
274    
275    ;;; Read the 32-bit magic number from STREAM then rewind it.
276    (defun read-object-file-magic (stream)
277      (let ((pos (file-position stream)))
278        (prog1
279            (read-u32-be stream)
280          (file-position stream pos))))
281    
282    ;;; XXX For a Darwin/x86 port, these functions will need to swap the
283    ;;; byte order of the structure members. Apple's documentation states
284    ;;; that all the fields of FAT-HEADER and FAT-ARCH are big-endian.
285    (defun read-mach-header (stream sap)
286      (unix:unix-read (lisp::fd-stream-fd stream) sap
287                      (alien:alien-size machheader :bytes)))
288    
289    (defun read-fat-header (stream sap)
290      (unix:unix-read (lisp::fd-stream-fd stream) sap
291                      (alien:alien-size fat-header :bytes)))
292    
293    (defun read-fat-arch (stream sap)
294      (unix:unix-read (lisp::fd-stream-fd stream) sap
295                      (alien:alien-size fat-arch :bytes)))
296    
297    ;;; Return a list of offsets in STREAM which contain Mach-O headers.
298    ;;; For single-architecture binaries, this will return (0), emulating
299    ;;; the previous behavior of loading the header from the start of the
300    ;;; file.  For fat binaries, there will be one offset in the result
301    ;;; list for each architecture present in the file.
302    (defun read-mach-header-offsets (stream)
303      (let ((magic (read-object-file-magic stream)))
304        (cond ((eql magic mh-magic)
305               (list 0))
306              ((eql magic fat-header-magic)
307               (alien:with-alien ((fat-header fat-header)
308                                  (fat-arch fat-arch))
309                 (read-fat-header stream (alien:alien-sap fat-header))
310                 (loop
311                    for i from 0 below (alien:slot fat-header 'nfat-arch)
312                    do (read-fat-arch stream (alien:alien-sap fat-arch))
313                    collect (alien:slot fat-arch 'offset))))
314              (t nil))))
315    
316    ;;; Return true if the Mach-O HEADER represents a shared library.
317    (defun shared-mach-header-p (header)
318      (and (eql (alien:slot header 'magic) mh-magic)
319           (or (eql (alien:slot header 'filetype) mh-dylib)
320               (eql (alien:slot header 'filetype) mh-bundle))))
321    
322    (defun file-shared-library-p (pathname)
323      (with-open-file (obj pathname
324                           :direction :input
325                           :element-type '(unsigned-byte 8))
326        (let ((offsets (read-mach-header-offsets obj)))
327          (when offsets
328            (alien:with-alien ((header machheader))
329              (loop
330                 for offset in offsets
331                 do (file-position obj offset)
332                    (read-mach-header obj (alien:alien-sap header))
333                 thereis (shared-mach-header-p header)))))))
334    ) ; #+darwin
335    
336    
337    
# Line 232  Line 357 
357    exit 0    exit 0
358    ||#    ||#
359    
360    (format t ";;; Loading object file...~%")    (format t (intl:gettext ";;; Loading object file...~%"))
361    (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)    (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
362      (unless fd      (unless fd
363        (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno)))        (error (intl:gettext "Could not open ~S: ~A") name (unix:get-unix-error-msg errno)))
364      (unwind-protect      (unwind-protect
365          (alien:with-alien ((header eheader))          (alien:with-alien ((header eheader))
366            (unix:unix-read fd            (unix:unix-read fd
367                            (alien:alien-sap header)                            (alien:alien-sap header)
368                            (alien:alien-size eheader :bytes))                            (alien:alien-size eheader :bytes))
369            (unless (elf-p (alien:slot header 'elf-ident))            (unless (elf-p (alien:slot header 'elf-ident))
370              (error (format nil "~A is not an ELF file." name)))              (error (format nil (intl:gettext "~A is not an ELF file.") name)))
371    
372            (let ((osabi (elf-osabi (alien:slot header 'elf-ident)))            (let ((osabi (elf-osabi (alien:slot header 'elf-ident)))
373                  (expected-osabi #+NetBSD elfosabi-netbsd                  (expected-osabi #+NetBSD elfosabi-netbsd
374                                  #+FreeBSD elfosabi-freebsd))                                  #+FreeBSD elfosabi-freebsd))
375              (unless (= osabi expected-osabi)              (unless (= osabi expected-osabi)
376                (error "~A is not a ~A executable, it's a ~A executable."                (error (intl:gettext "~A is not a ~A executable, it's a ~A executable.")
377                       name                       name
378                       (elf-osabi-name expected-osabi)                       (elf-osabi-name expected-osabi)
379                       (elf-osabi-name osabi))))                       (elf-osabi-name osabi))))
380    
381            (unless (elf-executable-p (alien:slot header 'elf-type))            (unless (elf-executable-p (alien:slot header 'elf-type))
382              (error (format nil "~A is not executable." name)))              (error (format nil (intl:gettext "~A is not executable.") name)))
383    
384            (alien:with-alien ((program-header pheader))            (alien:with-alien ((program-header pheader))
385              (unix:unix-read fd              (unix:unix-read fd
# Line 269  Line 394 
394        (unix:unix-close fd))))        (unix:unix-close fd))))
395    
396  (defun parse-symbol-table (name)  (defun parse-symbol-table (name)
397    "Parse symbol table file created by load-foreign script.  Modified    _N"Parse symbol table file created by load-foreign script.  Modified
398  to skip undefined symbols which don't have an address."  to skip undefined symbols which don't have an address."
399    (format t ";;; Parsing symbol table...~%")    (format t (intl:gettext ";;; Parsing symbol table...~%"))
400    (let ((symbol-table (make-hash-table :test #'equal)))    (let ((symbol-table (make-hash-table :test #'equal)))
401      (with-open-file (file name)      (with-open-file (file name)
402        (loop        (loop
# Line 298  to skip undefined symbols which don't ha Line 423  to skip undefined symbols which don't ha
423  ;;; expected results. It is probably good enough for now.  ;;; expected results. It is probably good enough for now.
424  #+(or (and FreeBSD (not ELF)) (and sparc (not svr4)))  #+(or (and FreeBSD (not ELF)) (and sparc (not svr4)))
425  (defun load-object-file (name)  (defun load-object-file (name)
426    (format t ";;; Loading object file...~%")    (format t (intl:gettext ";;; Loading object file...~%"))
427    (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)    (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
428      (unless fd      (unless fd
429        (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno)))        (error (intl:gettext "Could not open ~S: ~A") name (unix:get-unix-error-msg errno)))
430      (unwind-protect      (unwind-protect
431          (alien:with-alien ((header exec))          (alien:with-alien ((header exec))
432            (unix:unix-read fd            (unix:unix-read fd
# Line 401  to skip undefined symbols which don't ha Line 526  to skip undefined symbols which don't ha
526    
527  #+hppa  #+hppa
528  (defun load-object-file (name)  (defun load-object-file (name)
529    (format t ";;; Loading object file...~%")    (format t (intl:gettext ";;; Loading object file...~%"))
530    (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)    (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
531      (unless fd      (unless fd
532        (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno)))        (error (intl:gettext "Could not open ~S: ~A") name (unix:get-unix-error-msg errno)))
533      (unwind-protect      (unwind-protect
534          (alien:with-alien ((header (alien:struct som_exec_auxhdr)))          (alien:with-alien ((header (alien:struct som_exec_auxhdr)))
535            (unix:unix-lseek fd (alien:alien-size (alien:struct header) :bytes)            (unix:unix-lseek fd (alien:alien-size (alien:struct header) :bytes)
# Line 443  to skip undefined symbols which don't ha Line 568  to skip undefined symbols which don't ha
568  #-(or linux bsd solaris irix)  #-(or linux bsd solaris irix)
569  (progn  (progn
570  (defun parse-symbol-table (name)  (defun parse-symbol-table (name)
571    (format t ";;; Parsing symbol table...~%")    (format t (intl:gettext ";;; Parsing symbol table...~%"))
572    (let ((symbol-table (make-hash-table :test #'equal)))    (let ((symbol-table (make-hash-table :test #'equal)))
573      (with-open-file (file name)      (with-open-file (file name)
574        (loop        (loop
# Line 470  to skip undefined symbols which don't ha Line 595  to skip undefined symbols which don't ha
595                              #+hpux "library:cmucl.orig")                              #+hpux "library:cmucl.orig")
596                             (env ext:*environment-list*)                             (env ext:*environment-list*)
597                             (verbose *load-verbose*))                             (verbose *load-verbose*))
598    "Load-foreign loads a list of C object files into a running Lisp.  The files    _N"Load-foreign loads a list of C object files into a running Lisp.  The files
599    argument should be a single file or a list of files.  The files may be    argument should be a single file or a list of files.  The files may be
600    specified as namestrings or as pathnames.  The libraries argument should be a    specified as namestrings or as pathnames.  The libraries argument should be a
601    list of library files as would be specified to ld.  They will be searched in    list of library files as would be specified to ld.  They will be searched in
# Line 485  to skip undefined symbols which don't ha Line 610  to skip undefined symbols which don't ha
610          (files (if (atom files) (list files) files)))          (files (if (atom files) (list files) files)))
611    
612      (when verbose      (when verbose
613        (format t ";;; Running library:load-foreign.csh...~%")        (format t (intl:gettext ";;; Running library:load-foreign.csh...~%"))
614        (force-output))        (force-output))
615      #+hpux      #+hpux
616      (dolist (f files)      (dolist (f files)
# Line 494  to skip undefined symbols which don't ha Line 619  to skip undefined symbols which don't ha
619                    (or (eql sysid cpu-pa-risc1-0)                    (or (eql sysid cpu-pa-risc1-0)
620                        (and (>= sysid cpu-pa-risc1-1)                        (and (>= sysid cpu-pa-risc1-1)
621                             (<= sysid cpu-pa-risc-max))))                             (<= sysid cpu-pa-risc-max))))
622            (error "Object file is wrong format, so can't load-foreign:~            (error (intl:gettext "Object file is wrong format, so can't load-foreign:~
623                    ~%  ~S"                    ~%  ~S")
624                   f))                   f))
625          (unless (eql (read-byte stream) reloc-magic)          (unless (eql (read-byte stream) reloc-magic)
626            (error "Object file is not relocatable, so can't load-foreign:~            (error (intl:gettext "Object file is not relocatable, so can't load-foreign:~
627                    ~%  ~S"                    ~%  ~S")
628                   f))))                   f))))
629    
630      (let ((proc (ext:run-program      (let ((proc (ext:run-program
# Line 527  to skip undefined symbols which don't ha Line 652  to skip undefined symbols which don't ha
652                   :output error-output                   :output error-output
653                   :error :output)))                   :error :output)))
654        (unless proc        (unless proc
655          (error "Could not run library:load-foreign.csh"))          (error (intl:gettext "Could not run library:load-foreign.csh")))
656        (unless (zerop (ext:process-exit-code proc))        (unless (zerop (ext:process-exit-code proc))
657          (system:serve-all-events 0)          (system:serve-all-events 0)
658          (error "library:load-foreign.csh failed:~%~A"          (error (intl:gettext "library:load-foreign.csh failed:~%~A")
659                 (get-output-stream-string error-output)))                 (get-output-stream-string error-output)))
660        (load-object-file output-file)        (load-object-file output-file)
661        (parse-symbol-table symbol-table-file)        (parse-symbol-table symbol-table-file)
# Line 540  to skip undefined symbols which don't ha Line 665  to skip undefined symbols which don't ha
665          (when old-file          (when old-file
666            (unix:unix-unlink old-file)))))            (unix:unix-unlink old-file)))))
667    (when verbose    (when verbose
668      (format t ";;; Done.~%")      (format t (intl:gettext ";;; Done.~%"))
669      (force-output)))      (force-output)))
670    
671    
# Line 558  to skip undefined symbols which don't ha Line 683  to skip undefined symbols which don't ha
683  (progn  (progn
684    
685  (defconstant rtld-lazy 1  (defconstant rtld-lazy 1
686    "Lazy function call binding")    _N"Lazy function call binding")
687  (defconstant rtld-now 2  (defconstant rtld-now 2
688    "Immediate function call binding")    _N"Immediate function call binding")
689  #+(and linux glibc2)  #+(and linux glibc2)
690  (defconstant rtld-binding-mask #x3  (defconstant rtld-binding-mask #x3
691    "Mask of binding time value")    _N"Mask of binding time value")
692    
693  (defconstant rtld-global #-irix #x100 #+irix 4  (defconstant rtld-global #-irix #x100 #+irix 4
694    "If set the symbols of the loaded object and its dependencies are    _N"If set the symbols of the loaded object and its dependencies are
695     made visible as if the object were linked directly into the program")     made visible as if the object were linked directly into the program")
696    
697  (defvar *global-table* nil)  (defvar *global-table* nil)
# Line 603  to skip undefined symbols which don't ha Line 728  to skip undefined symbols which don't ha
728      (setf *global-table* (acons (int-sap 0) nil nil))      (setf *global-table* (acons (int-sap 0) nil nil))
729      (setf *global-table* (acons (dlopen nil rtld-lazy) nil nil))      (setf *global-table* (acons (dlopen nil rtld-lazy) nil nil))
730      (when (zerop (system:sap-int (caar *global-table*)))      (when (zerop (system:sap-int (caar *global-table*)))
731        (error "Can't open global symbol table: ~S" (dlerror)))))        (error (intl:gettext "Can't open global symbol table: ~S") (dlerror)))))
732    
733  (defun load-object-file (file)  (defun convert-object-file-path (path)
734      ;; Convert path to something that dlopen might like, which means
735      ;; translating logical pathnames and converting search-lists to the
736      ;; first path that exists.
737      (cond ((lisp::logical-pathname-p (pathname path))
738             (translate-logical-pathname path))
739            ((ignore-errors (ext:search-list-defined-p (pathname path)))
740             (ext:enumerate-search-list (s (pathname path)
741                                           path)
742               (when (probe-file s)
743                 (return s))))
744            (t
745             path)))
746    
747    (defun load-object-file (file &optional (recordp t))
748    (ensure-lisp-table-opened)    (ensure-lisp-table-opened)
749    ; rtld global: so it can find all the symbols previously loaded    ; rtld global: so it can find all the symbols previously loaded
750    ; rtld now: that way dlopen will fail if not all symbols are defined.    ; rtld now: that way dlopen will fail if not all symbols are defined.
751    (let* ((filename (namestring file ))    (let* ((filename (namestring (convert-object-file-path file)))
752           (sap (dlopen filename (logior rtld-now rtld-global))))           (sap (dlopen filename (logior rtld-now rtld-global))))
753      (cond ((zerop (sap-int sap))      (cond ((zerop (sap-int sap))
754             (let ((err-string (dlerror))             (let ((err-string (dlerror))
# Line 617  to skip undefined symbols which don't ha Line 756  to skip undefined symbols which don't ha
756               ;; For some reason dlerror always seems to return NIL,               ;; For some reason dlerror always seems to return NIL,
757               ;; which isn't very informative.               ;; which isn't very informative.
758               (when (zerop (sap-int sap))               (when (zerop (sap-int sap))
759                 (error "Can't open object ~S: ~S" file err-string))                 (return-from load-object-file
760                     (values nil (format nil  (intl:gettext "Can't open object ~S: ~S") file err-string))))
761               (dlclose sap)               (dlclose sap)
762               (error "LOAD-OBJECT-FILE: Unresolved symbols in file ~S: ~S"               (return-from load-object-file
763                      file err-string)))                 (values nil
764            ((null (assoc sap *global-table* :test #'sap=))                         (format nil (intl:gettext "LOAD-OBJECT-FILE: Unresolved symbols in file ~S: ~S")
765                                   file err-string)))))
766              ((and recordp (null (assoc sap *global-table* :test #'sap=)))
767             (setf *global-table* (acons sap file *global-table*)))             (setf *global-table* (acons sap file *global-table*)))
768            (t nil))))            (t nil))))
769    
# Line 644  to skip undefined symbols which don't ha Line 786  to skip undefined symbols which don't ha
786    (loop for lib-entry in (reverse *global-table*)    (loop for lib-entry in (reverse *global-table*)
787          for (sap . lib-path) = lib-entry          for (sap . lib-path) = lib-entry
788          when lib-path          when lib-path
789          do (let ((new-sap (dlopen (namestring lib-path)       do
790                                    (logior rtld-now rtld-global))))         (loop
791               (when (zerop (sap-int new-sap))            (restart-case
792                 ;; We're going down                (let ((new-sap (dlopen (namestring (convert-object-file-path lib-path))
793                 (error "Couldn't open library ~S: ~S" lib-path (dlerror)))                                       (logior rtld-now rtld-global))))
794               (setf (car lib-entry) new-sap)))                  (cond ((zerop (sap-int new-sap))
795                           ;; We're going down
796                           (error (intl:gettext "Couldn't open library ~S: ~S") lib-path (dlerror)))
797                          (t
798                           (format t (intl:gettext "Reloaded library ~S~%") lib-path)
799                           (force-output)))
800    
801                    (setf (car lib-entry) new-sap)
802                    (return))
803                (continue ()
804                  :report (lambda (stream)
805                            (write-string (intl:gettext "Ignore library and continue") stream))
806                  (return))
807                (try-again ()
808                  :report (lambda (stream)
809                            (write-string (intl:gettext "Try reloading again") stream))
810                  )
811                (new-library ()
812                  :report (lambda (stream)
813                            (write-string (intl:gettext "Choose new library path") stream))
814                  (format *query-io* (intl:gettext "Enter new library path: "))
815                  (setf lib-path (read))))))
816    (alien:alien-funcall (alien:extern-alien "os_resolve_data_linkage"    (alien:alien-funcall (alien:extern-alien "os_resolve_data_linkage"
817                                             (alien:function c-call:void))))                                             (alien:function c-call:void))))
818    
# Line 669  to skip undefined symbols which don't ha Line 832  to skip undefined symbols which don't ha
832                             (base-file nil)                             (base-file nil)
833                             (env ext:*environment-list*)                             (env ext:*environment-list*)
834                             (verbose *load-verbose*))                             (verbose *load-verbose*))
835    "Load C object files into the running Lisp. The FILES argument    _N"Load C object files into the running Lisp. The FILES argument
836  should be a single file or a list of files. The files may be specified  should be a single file or a list of files. The files may be specified
837  as namestrings or as pathnames. The LIBRARIES argument should be a  as namestrings or as pathnames. The LIBRARIES argument should be a
838  list of library files as would be specified to ld. They will be  list of library files as would be specified to ld. They will be
# Line 679  the starting place for defined symbols. Line 842  the starting place for defined symbols.
842  code for Lisp. The ENV argument is the Unix environment variable  code for Lisp. The ENV argument is the Unix environment variable
843  definitions for the invocation of the linker. The default is the  definitions for the invocation of the linker. The default is the
844  environment passed to Lisp."  environment passed to Lisp."
845    ;; Note: dlopen remembers the name of an object, when dlopenin    ;; Note: dlopen remembers the name of an object, when dlopen()ing
846    ;; the same name twice, the old objects is reused.    ;; the same name twice, the old object is reused.
847    (declare (ignore base-file))    (declare (ignore base-file))
848    ;; if passed a single shared object that can be loaded directly via    ;; if passed a single shared object that can be loaded directly via
849    ;; dlopen(), do that instead of using the linker    ;; dlopen(), do that instead of using the linker
850    (cond ((and (atom files)    (when (atom files)
851                (probe-file files)      (when verbose
852                (file-shared-library-p files))        (format t (intl:gettext ";;; Opening as shared library ~A ...~%") files))
853           (when verbose      (multiple-value-bind (ok error-string)
854             (format t ";;; Opening shared library ~A ...~%" files))          (load-object-file files)
855           (load-object-file files)        (cond (ok
856           (when verbose               (when verbose
857             (format t ";;; Done.~%")))                 (format t (intl:gettext ";;; Done.~%"))
858          (t                 (force-output))
859           (let ((output-file (pick-temporary-file-name               (return-from load-foreign))
860                               (concatenate 'string "/tmp/~D~C" (string (gensym)))))              (error-string
861                 (error-output (make-string-output-stream)))               (format t "~A~%" error-string)
862                 (force-output))))
863    
864        ;; If we get here, we couldn't open the file as a shared library.
865        ;; Try again assuming it's an object file.
866        (when verbose
867          (format t (intl:gettext ";;; Trying as object file ~A...~%") files)))
868    
869    
870      (let ((output-file (pick-temporary-file-name
871                          (concatenate 'string "/tmp/~D~C" (string (gensym)))))
872            (error-output (make-string-output-stream)))
873    
874             (when verbose      (when verbose
875               (format t ";;; Running ~A...~%" *dso-linker*)        (format t (intl:gettext ";;; Running ~A...~%") *dso-linker*)
876               (force-output))        (force-output))
877    
878             (let ((proc (ext:run-program      (let ((proc (ext:run-program
879                          *dso-linker*                   *dso-linker*
880                          (list*                   (list*
881                           #+(or solaris linux FreeBSD4) "-G"                    #+(or solaris linux) "-G"
882                           #+(or OpenBSD irix) "-shared"                    #+(or freebsd OpenBSD NetBSD irix) "-shared"
883                           "-o"                    #+darwin "-dylib"
884                           output-file                    #+darwin "-arch"
885                           ;; Cause all specified libs to be loaded in full                    #+darwin "i386"
886                           #+(or OpenBSD linux FreeBSD4) "--whole-archive"                    "-o"
887                           #+solaris "-z" #+solaris "allextract"                    output-file
888                           (append (mapcar                    ;; Cause all specified libs to be loaded in full
889                                    #'(lambda (name)                    #+(or freebsd OpenBSD linux NetBSD) "--whole-archive"
890                                        (or (unix-namestring name)                    #+solaris "-z" #+solaris "allextract"
891                                            (error 'simple-file-error                    #+darwin "-all_load"
892                                                   :pathname name                    (append (mapcar
893                                                   :format-control                             #'(lambda (name)
894                                                   "File does not exist: ~A."                                 (or (unix-namestring name)
895                                                   :format-arguments                                     (error 'simple-file-error
896                                                   (list name))))                                            :pathname name
897                                    (if (atom files)                                            :format-control
898                                        (list files)                                            (intl:gettext "File does not exist: ~A.")
899                                        files))                                            :format-arguments
900                                   ;; Return to default ld behaviour for libs                                            (list name))))
901                                   (list                             (if (atom files)
902                                    #+(or OpenBSD linux FreeBSD4)                                 (list files)
903                                    "--no-whole-archive"                                 files))
904                                    #+solaris "-z" #+solaris "defaultextract")                            ;; Return to default ld behaviour for libs
905                                   libraries))                            (list
906                          ;; on Linux/AMD64, we need to tell the platform linker to use the 32-bit                             #+(or freebsd OpenBSD linux NetBSD)
907                          ;; linking mode instead of the default 64-bit mode. This can be done either                             "--no-whole-archive"
908                          ;; via the LDEMULATION environment variable, or via the "-m" command-line                             #+solaris "-z" #+solaris "defaultextract")
909                          ;; option. Here we assume that LDEMULATION will be ignored by the platform                            libraries))
910                          ;; linker on Linux/i386 platforms.                   ;; on Linux/AMD64, we need to tell the platform linker to use
911                          :env `(#+(and x86 linux) (:ldemulation . "elf_i386") ,@env)                   ;; the 32-bit linking mode instead of the default 64-bit mode.
912                          :input nil                   ;; This can be done either via the LDEMULATION environment
913                          :output error-output                   ;; variable, or via the "-m" command-line option. Here we
914                          :error :output)))                   ;; assume that LDEMULATION will be ignored by the platform
915               (unless proc                   ;; linker on Linux/i386 platforms.
916                 (error "Could not run ~A" *dso-linker*))                   :env `(#+(and x86 linux) (:ldemulation . "elf_i386") ,@env)
917               (unless (zerop (ext:process-exit-code proc))                   :input nil
918                 (system:serve-all-events 0)                   :output error-output
919                 (error "~A failed:~%~A" *dso-linker*                   :error :output)))
920                        (get-output-stream-string error-output)))        (unless proc
921               (load-object-file output-file)          (error (intl:gettext "Could not run ~A") *dso-linker*))
922               (unix:unix-unlink output-file)))        (unless (zerop (ext:process-exit-code proc))
923           (when verbose          (system:serve-all-events 0)
924             (format t ";;; Done.~%")          (error (intl:gettext "~A failed:~%~A") *dso-linker*
925             (force-output)))))                 (get-output-stream-string error-output)))
926          (load-object-file output-file nil)
927          (unix:unix-unlink output-file))
928        (when verbose
929          (format t (intl:gettext ";;; Done.~%"))
930          (force-output))))
931    
932    #+linkage-table
933    (pushnew #'reinitialize-global-table ext:*after-save-initializations*)
934  ) ;; #+(or linux bsd solaris irix)  ) ;; #+(or linux bsd solaris irix)

Legend:
Removed from v.1.46.2.2  
changed lines
  Added in v.1.60

  ViewVC Help
Powered by ViewVC 1.1.5