/[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.53 by rtoy, Wed Sep 21 11:32:43 2005 UTC revision 1.54 by rtoy, Wed Apr 26 20:49:23 2006 UTC
# Line 728  to skip undefined symbols which don't ha Line 728  to skip undefined symbols which don't ha
728      (when (zerop (system:sap-int (caar *global-table*)))      (when (zerop (system:sap-int (caar *global-table*)))
729        (error "Can't open global symbol table: ~S" (dlerror)))))        (error "Can't open global symbol table: ~S" (dlerror)))))
730    
731  (defun load-object-file (file)  (defun convert-object-file-path (path)
732      ;; Convert path to something that dlopen might like, which means
733      ;; translating logical pathnames and converting search-lists to the
734      ;; first path that exists.
735      (cond ((lisp::logical-pathname-p (pathname path))
736             (translate-logical-pathname path))
737            ((ignore-errors (ext:search-list-defined-p (pathname path)))
738             (ext:enumerate-search-list (s (pathname path)
739                                           path)
740               (when (probe-file s)
741                 (return s))))
742            (t
743             path)))
744    
745    (defun load-object-file (file &optional (recordp t))
746    (ensure-lisp-table-opened)    (ensure-lisp-table-opened)
747    ; rtld global: so it can find all the symbols previously loaded    ; rtld global: so it can find all the symbols previously loaded
748    ; 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.
749    (let* ((filename (namestring (if (lisp::logical-pathname-p (pathname file))    (let* ((filename (namestring (convert-object-file-path file)))
                                    (translate-logical-pathname file)  
                                    file)))  
750           (sap (dlopen filename (logior rtld-now rtld-global))))           (sap (dlopen filename (logior rtld-now rtld-global))))
751      (cond ((zerop (sap-int sap))      (cond ((zerop (sap-int sap))
752             (let ((err-string (dlerror))             (let ((err-string (dlerror))
# Line 742  to skip undefined symbols which don't ha Line 754  to skip undefined symbols which don't ha
754               ;; For some reason dlerror always seems to return NIL,               ;; For some reason dlerror always seems to return NIL,
755               ;; which isn't very informative.               ;; which isn't very informative.
756               (when (zerop (sap-int sap))               (when (zerop (sap-int sap))
757                 (error "Can't open object ~S: ~S" file err-string))                 (return-from load-object-file
758                     (values nil (format nil  "Can't open object ~S: ~S" file err-string))))
759               (dlclose sap)               (dlclose sap)
760               (error "LOAD-OBJECT-FILE: Unresolved symbols in file ~S: ~S"               (return-from load-object-file
761                      file err-string)))                 (values nil
762            ((null (assoc sap *global-table* :test #'sap=))                         (format nil "LOAD-OBJECT-FILE: Unresolved symbols in file ~S: ~S"
763                                   file err-string)))))
764              ((and recordp (null (assoc sap *global-table* :test #'sap=)))
765             (setf *global-table* (acons sap file *global-table*)))             (setf *global-table* (acons sap file *global-table*)))
766            (t nil))))            (t nil))))
767    
# Line 769  to skip undefined symbols which don't ha Line 784  to skip undefined symbols which don't ha
784    (loop for lib-entry in (reverse *global-table*)    (loop for lib-entry in (reverse *global-table*)
785          for (sap . lib-path) = lib-entry          for (sap . lib-path) = lib-entry
786          when lib-path          when lib-path
787          do (let ((new-sap (dlopen (namestring lib-path)       do
788                                    (logior rtld-now rtld-global))))         (loop
789               (when (zerop (sap-int new-sap))            (restart-case
790                 ;; We're going down                (let ((new-sap (dlopen (namestring (convert-object-file-path lib-path))
791                 (error "Couldn't open library ~S: ~S" lib-path (dlerror)))                                       (logior rtld-now rtld-global))))
792               (setf (car lib-entry) new-sap)))                  (cond ((zerop (sap-int new-sap))
793                           ;; We're going down
794                           (error "Couldn't open library ~S: ~S" lib-path (dlerror)))
795                          (t
796                           (format t "Reloaded library ~S~%" lib-path)
797                           (force-output)))
798    
799                    (setf (car lib-entry) new-sap)
800                    (return))
801                (continue ()
802                  :report "Ignore library and continue"
803                  (return))
804                (try-again ()
805                  :report "Try reloading again"
806                  )
807                (new-library ()
808                  :report "Choose new library path"
809                  (format *query-io* "Enter new library path: ")
810                  (setf lib-path (read))))))
811    (alien:alien-funcall (alien:extern-alien "os_resolve_data_linkage"    (alien:alien-funcall (alien:extern-alien "os_resolve_data_linkage"
812                                             (alien:function c-call:void))))                                             (alien:function c-call:void))))
813    
# Line 809  environment passed to Lisp." Line 842  environment passed to Lisp."
842    (declare (ignore base-file))    (declare (ignore base-file))
843    ;; if passed a single shared object that can be loaded directly via    ;; if passed a single shared object that can be loaded directly via
844    ;; dlopen(), do that instead of using the linker    ;; dlopen(), do that instead of using the linker
845    (cond ((and (atom files)    (when (atom files)
846                (probe-file files)      (when verbose
847                (file-shared-library-p files))        (format t ";;; Opening as shared library ~A ...~%" files))
848           (when verbose      (multiple-value-bind (ok &optional error-string)
849             (format t ";;; Opening shared library ~A ...~%" files))          (load-object-file files)
850           (load-object-file files)        (cond (ok
851           (when verbose               (when verbose
852             (format t ";;; Done.~%")))                 (format t ";;; Done.~%")
853          (t                 (force-output))
854           (let ((output-file (pick-temporary-file-name               (return-from load-foreign))
855                               (concatenate 'string "/tmp/~D~C" (string (gensym)))))              (error-string
856                 (error-output (make-string-output-stream)))               (format t "~A~%" error-string)
857                 (force-output))))
858    
859        ;; If we get here, we couldn't open the file as a shared library.
860        ;; Try again assuming it's an object file.
861        (when verbose
862          (format t ";;; Trying as object file ~A...~%" files)))
863    
864    
865      (let ((output-file (pick-temporary-file-name
866                          (concatenate 'string "/tmp/~D~C" (string (gensym)))))
867            (error-output (make-string-output-stream)))
868    
869             (when verbose      (when verbose
870               (format t ";;; Running ~A...~%" *dso-linker*)        (format t ";;; Running ~A...~%" *dso-linker*)
871               (force-output))        (force-output))
872    
873             (let ((proc (ext:run-program      (let ((proc (ext:run-program
874                          *dso-linker*                   *dso-linker*
875                          (list*                   (list*
876                           #+(or solaris linux FreeBSD4) "-G"                    #+(or solaris linux FreeBSD4) "-G"
877                           #+(or OpenBSD NetBSD irix) "-shared"                    #+(or OpenBSD NetBSD irix) "-shared"
878                           #+darwin "-dylib"                    #+darwin "-dylib"
879                           "-o"                    "-o"
880                           output-file                    output-file
881                           ;; Cause all specified libs to be loaded in full                    ;; Cause all specified libs to be loaded in full
882                           #+(or OpenBSD linux FreeBSD4 NetBSD) "--whole-archive"                    #+(or OpenBSD linux FreeBSD4 NetBSD) "--whole-archive"
883                           #+solaris "-z" #+solaris "allextract"                    #+solaris "-z" #+solaris "allextract"
884                           #+darwin "-all_load"                    #+darwin "-all_load"
885                           (append (mapcar                    (append (mapcar
886                                    #'(lambda (name)                             #'(lambda (name)
887                                        (or (unix-namestring name)                                 (or (unix-namestring name)
888                                            (error 'simple-file-error                                     (error 'simple-file-error
889                                                   :pathname name                                            :pathname name
890                                                   :format-control                                            :format-control
891                                                   "File does not exist: ~A."                                            "File does not exist: ~A."
892                                                   :format-arguments                                            :format-arguments
893                                                   (list name))))                                            (list name))))
894                                    (if (atom files)                             (if (atom files)
895                                        (list files)                                 (list files)
896                                        files))                                 files))
897                                   ;; Return to default ld behaviour for libs                            ;; Return to default ld behaviour for libs
898                                   (list                            (list
899                                    #+(or OpenBSD linux FreeBSD4 NetBSD)                             #+(or OpenBSD linux FreeBSD4 NetBSD)
900                                    "--no-whole-archive"                             "--no-whole-archive"
901                                    #+solaris "-z" #+solaris "defaultextract")                             #+solaris "-z" #+solaris "defaultextract")
902                                   libraries))                            libraries))
903                          ;; on Linux/AMD64, we need to tell the platform linker to use the 32-bit                   ;; on Linux/AMD64, we need to tell the platform linker to use the 32-bit
904                          ;; linking mode instead of the default 64-bit mode. This can be done either                   ;; linking mode instead of the default 64-bit mode. This can be done either
905                          ;; via the LDEMULATION environment variable, or via the "-m" command-line                   ;; via the LDEMULATION environment variable, or via the "-m" command-line
906                          ;; option. Here we assume that LDEMULATION will be ignored by the platform                   ;; option. Here we assume that LDEMULATION will be ignored by the platform
907                          ;; linker on Linux/i386 platforms.                   ;; linker on Linux/i386 platforms.
908                          :env `(#+(and x86 linux) (:ldemulation . "elf_i386") ,@env)                   :env `(#+(and x86 linux) (:ldemulation . "elf_i386") ,@env)
909                          :input nil                   :input nil
910                          :output error-output                   :output error-output
911                          :error :output)))                   :error :output)))
912               (unless proc        (unless proc
913                 (error "Could not run ~A" *dso-linker*))          (error "Could not run ~A" *dso-linker*))
914               (unless (zerop (ext:process-exit-code proc))        (unless (zerop (ext:process-exit-code proc))
915                 (system:serve-all-events 0)          (system:serve-all-events 0)
916                 (error "~A failed:~%~A" *dso-linker*          (error "~A failed:~%~A" *dso-linker*
917                        (get-output-stream-string error-output)))                 (get-output-stream-string error-output)))
918               (load-object-file output-file)        (load-object-file output-file nil)
919               (unix:unix-unlink output-file)))        (unix:unix-unlink output-file))
920           (when verbose      (when verbose
921             (format t ";;; Done.~%")        (format t ";;; Done.~%")
922             (force-output)))))        (force-output))))
923    
924    #+linkage-table
925    (pushnew #'reinitialize-global-table ext:*after-save-initializations*)
926  ) ;; #+(or linux bsd solaris irix)  ) ;; #+(or linux bsd solaris irix)

Legend:
Removed from v.1.53  
changed lines
  Added in v.1.54

  ViewVC Help
Powered by ViewVC 1.1.5