Changeset 14656


Ignore:
Timestamp:
Feb 22, 2011, 11:34:32 AM (9 years ago)
Author:
gb
Message:

lispequ.lisp: make SHLIB fields available to DESCRIBE/INSPECT.
l0-cfm-support.lisp, linux-files.lisp: shared library changes (mostly

Darwin-related).

Location:
trunk/source
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/level-0/l0-cfm-support.lisp

    r14649 r14656  
    135135    (not (zerop count))))
    136136
    137 (defun shared-library-with-name (name &optional (is-unloaded nil))
     137(defun shared-library-with-name (name)
    138138  (let* ((namelen (length name)))
    139139    (dolist (lib *shared-libraries*)
    140140      (let* ((libname (shlib.soname lib)))
    141         (when (and (%simple-string= name libname 0 0 namelen (length libname))
    142                    (or (not is-unloaded) (and (null (shlib.map lib))
    143                                               (null (shlib.base lib)))))
     141        (when (%simple-string= name libname 0 0 namelen (length libname))
    144142          (return lib))))))
    145143
     
    365363(progn
    366364
    367 (defun shared-library-with-header (header)
     365(defun shared-library-with-handle (handle)
    368366  (dolist (lib *shared-libraries*)
    369     (when (eql (shlib.map lib) header)
     367    (when (eql (shlib.handle lib) handle)
    370368      (return lib))))
    371369
    372 (defun shared-library-with-module (module)
    373   (dolist (lib *shared-libraries*)
    374     (when (eql (shlib.base lib) module)
    375       (return lib))))
    376 
    377 
    378 
    379 ;;;   
    380 ;;; maybe we could fix this up name to get the "real name"
    381 ;;; this is might be possible for dylibs but probably not for modules
    382 ;;; for now soname and pathname are just the name that the user passed in
    383 ;;; if the library is "discovered" later, it is the name the system gave
    384 ;;; to it -- usually a full pathname
    385 ;;;
    386 ;;; header and module are ptr types
    387 ;;;
    388 (defun shared-library-from-header-module-or-name (header module name)
    389   ;; first try to find the library based on its address
    390   (let ((found-lib (if (%null-ptr-p module)
    391                        (shared-library-with-header header)
    392                      (shared-library-with-module module))))
    393    
    394     (unless found-lib
    395       ;; check if the library name is still on our list but has been unloaded
    396       (setq found-lib (shared-library-with-name name t))
    397       (if found-lib
    398         (setf (shlib.map found-lib) header
    399               (shlib.base found-lib) module)
    400         ;; otherwise add it to the list
    401         (push (setq found-lib (%cons-shlib name name header module))
    402               *shared-libraries*)))
    403     found-lib))
    404 
    405 
    406 (defun open-shared-library-internal (name)
    407   (rlet ((type :signed))
    408     (let ((result (with-cstrs ((cname name))
    409                     (ff-call (%kernel-import target::kernel-import-GetSharedLibrary)
    410                              :address cname
    411                              :address type
    412                              :address))))
    413         (cond
    414          ((= 1 (pref type :signed))
    415           ;; dylib
    416           (shared-library-from-header-module-or-name result (%null-ptr) name))
    417          ((= 2 (pref type :signed))
    418           ;; bundle
    419           (shared-library-from-header-module-or-name (%null-ptr) result name))
    420          ((= 0 (pref type :signed))
    421           ;; neither a dylib nor bundle was found
    422           (values nil (%get-cstring result)))
    423          (t (values nil "unknown error"))))))
    424 
    425 
    426 
    427 ;;;
    428 ;;; When restarting from a saved image
    429 ;;;
    430 (defun reopen-user-libraries ()
    431   (dolist (lib *shared-libraries*)
    432     (setf (shlib.map lib) nil
    433           (shlib.base lib) nil))
    434   (loop
    435       (let* ((win nil)
    436              (lose nil))
    437         (dolist (lib *shared-libraries*)
    438           (let* ((header (shlib.map lib))
    439                  (module (shlib.base lib)))
    440             (unless (and header module)
    441               (rlet ((type :signed))
    442                 (let ((result (with-cstrs ((cname (shlib.soname lib)))
    443                                 (ff-call (%kernel-import target::kernel-import-GetSharedLibrary)
    444                                          :address cname
    445                                          :address type
    446                                          :address))))
    447                   (cond
    448                    ((= 1 (pref type :signed))
    449                     ;; dylib
    450                     (setf (shlib.map lib) result
    451                           (shlib.base lib) (%null-ptr)
    452                           win t))
    453                    ((= 2 (pref type :signed))
    454                     ;; bundle
    455                     (setf (shlib.map lib) (%null-ptr)
    456                           (shlib.base lib) result
    457                           win t))
    458                    (t
    459                     ;; neither a dylib nor bundle was found
    460                     (setq lose t))))))))
    461         (when (or (not lose) (not win)) (return)))))
     370
     371
     372
     373
     374
     375
     376
    462377
    463378;;; end darwin-target
     
    721636(defvar *ns-is-symbol-name-defined-in-image*)
    722637(defvar *dladdr-entry* 0)
     638(defvar *dlopen-entry* 0)
     639(defvar *dlerror-entry* 0)
    723640
    724641(defun setup-lookup-calls ()
    725   #+notyet
    726   (setq *dladdr-entry* (foreign-symbol-entry "_dladdr"))
    727   (setq *dyld-image-count* (foreign-symbol-entry "__dyld_image_count"))
    728   (setq *dyld-get-image-header* (foreign-symbol-entry "__dyld_get_image_header"))
    729   (setq *dyld-get-image-name* (foreign-symbol-entry "__dyld_get_image_name"))
    730   (setq *nslookup-symbol-in-image* (foreign-symbol-entry "_NSLookupSymbolInImage"))
    731   (setq *nsaddress-of-symbol* (foreign-symbol-entry "_NSAddressOfSymbol"))
    732   (setq *nsmodule-for-symbol* (foreign-symbol-entry "_NSModuleForSymbol"))
    733   (setq *ns-is-symbol-name-defined-in-image* (foreign-symbol-entry "_NSIsSymbolNameDefinedInImage")))
     642  (setq *dladdr-entry* (foreign-symbol-entry "dladdr"))
     643  (setq *dlopen-entry* (foreign-symbol-entry "dlopen"))
     644  (setq *dlerror-entry* (foreign-symbol-entry "dlerror"))
     645  (setq *dyld-image-count* (foreign-symbol-entry "_dyld_image_count"))
     646  (setq *dyld-get-image-header* (foreign-symbol-entry "_dyld_get_image_header"))
     647  (setq *dyld-get-image-name* (foreign-symbol-entry "_dyld_get_image_name"))
     648)
    734649
    735650(setup-lookup-calls)
    736651
     652(defun open-shared-library-internal (name)
     653  (with-cstrs ((cname name))
     654    (let* ((handle (ff-call *dlopen-entry*
     655                            :address cname
     656                            :int (logior #$RTLD_GLOBAL #$RTLD_NOW)
     657                            :address)))
     658      (if (%null-ptr-p handle)
     659        (values nil (%get-cstring (ff-call *dlerror-entry* :address)))
     660        (let* ((lib (shared-library-with-handle handle)))
     661          (unless lib
     662            (setq lib (%cons-shlib name name nil nil))
     663            (setf (shlib.handle lib) handle))
     664          (incf (shlib.opencount lib))
     665          (values lib nil))))))
     666
    737667;;;
    738 ;;; given an entry address (a number) and a symbol name (lisp string)
    739 ;;; find the associated dylib or module
    740 ;;; if the dylib or module is not found in *shared-libraries* list it is added
    741 ;;; if not found in the OS list it returns nil
     668;;; When restarting from a saved image
    742669;;;
    743 ;;; got this error before putting in the call to
    744 ;;; NSIsObjectNameDefinedInImage dyld: /usr/local/lisp/ccl/dppccl dead
    745 ;;; lock (dyld operation attempted in a thread already doing a dyld
    746 ;;; operation)
    747 ;;;
    748 
    749 (defun legacy-shlib-containing-address (addr name)
    750   (when *ns-is-symbol-name-defined-in-image*
    751     (dotimes (i (ff-call *dyld-image-count* :unsigned-fullword))
    752       (let ((header (ff-call *dyld-get-image-header* :unsigned-fullword i :address)))
    753         (when (and (not (%null-ptr-p header))
    754                    (or (eql (pref header :mach_header.filetype) #$MH_DYLIB)
    755                        (eql (pref header :mach_header.filetype) #$MH_BUNDLE)))
    756           ;; make sure the image is either a bundle or a dylib
    757           ;; (otherwise we will crash, likely OS bug, tested OS X 10.1.5)
    758           (with-cstrs ((cname name))
    759             ;; also we must check is symbol name is defined in the
    760             ;; image otherwise in certain cases there is a crash,
    761             ;; another likely OS bug happens in the case where a
    762             ;; bundle imports a dylib and then we call
    763             ;; nslookupsymbolinimage on the bundle image
    764             (when (/= 0
    765                       (ff-call *ns-is-symbol-name-defined-in-image* :address header
    766                                :address cname :unsigned))
    767               (let ((symbol (ff-call *nslookup-symbol-in-image* :address header :address cname
    768                                      :unsigned-fullword #$NSLOOKUPSYMBOLINIMAGE_OPTION_RETURN_ON_ERROR
    769                                      :address)))
    770                 (unless (%null-ptr-p symbol)
    771                   ;; compare the found address to the address we are looking for
    772                   (let ((foundaddr (ff-call *nsaddress-of-symbol* :address symbol :address)))
    773                     ;; (format t "Foundaddr ~s~%" foundaddr)
    774                     ;; (format t "Compare to addr ~s~%" addr)
    775                     (when (eql foundaddr addr)
    776                       (let* ((imgname (ff-call *dyld-get-image-name* :unsigned-fullword i :address))
    777                              (libname (unless (%null-ptr-p imgname) (%get-cstring imgname)))
    778                              (libmodule (%int-to-ptr 0))
    779                              (libheader (%int-to-ptr 0)))
    780                         (if (eql (pref header :mach_header.filetype) #$MH_BUNDLE)
    781                           (setf libmodule (ff-call *nsmodule-for-symbol* :address symbol :address))
    782                           (setf libheader header))
    783                         ;; make sure that this shared library is on *shared-libraries*
    784                         (return (shared-library-from-header-module-or-name libheader libmodule libname))))))))))))))
    785 
    786 (defun shlib-containing-address (address name)
    787   (if (zerop *dladdr-entry*)
    788     (legacy-shlib-containing-address address name)
    789     ;; Bootstrapping.  RLET might be clearer here.
    790     (%stack-block ((info (record-length #>Dl_info) :clear t))
    791       (unless (zerop (ff-call *dladdr-entry*
    792                               :address address
    793                               :address info
    794                               :signed-fullword))
    795         (let* ((addr (pref info #>Dl_info.dli_fbase)))
    796           (format t "~&name = ~s" (pref info  #>Dl_info.dli_fname))
    797          
    798           (dolist (lib *shared-libraries*)
    799             (when (eql (shlib.base lib) addr)
    800               (return lib))))))))
     670(defun reopen-user-libraries ()
     671  (dolist (lib *shared-libraries*)
     672    (setf (shlib.handle lib) nil
     673          (shlib.base lib) nil))
     674  (dolist (lib *shared-libraries*)
     675    (with-cstrs ((cname (shlib.soname lib)))
     676      (let* ((handle (ff-call *dlopen-entry*
     677                              :address cname
     678                              :int (logior #$RTLD_GLOBAL #$RTLD_NOW)
     679                              :address)))
     680        (unless (%null-ptr-p handle)
     681          (setf (shlib.handle lib) handle))))))
     682
     683(defun shlib-containing-address (address &optional name)
     684  (declare (ignore name))
     685  (%stack-block ((info (record-length #>Dl_info) :clear t))
     686    (unless (zerop (ff-call *dladdr-entry*
     687                            :address address
     688                            :address info
     689                            :signed-fullword))
     690      (let* ((addr (pref info #>Dl_info.dli_fbase))
     691             (name (%get-cstring (pref info #>Dl_info.dli_fname)))
     692             (namelen (length name)))
     693        (dolist (lib *shared-libraries*)
     694          (let* ((shlibname  (shlib.pathname lib))
     695                 (shlibnamelen (length shlibname)))
     696          (when (%simple-string= name shlibname 0 0 namelen shlibnamelen)
     697            (unless (shlib.base lib)
     698              (setf (shlib.base lib) addr
     699                    (shlib.soname lib) (soname-from-mach-header addr)))
     700            (return lib))))))))
    801701
    802702(defun shlib-containing-entry (entry &optional name)
     
    806706    (entry->addr entry addr)
    807707    (shlib-containing-address addr name)))
     708
     709(defun soname-from-mach-header (header)
     710  (do* ((p (%inc-ptr header
     711                     #+64-bit-target (record-length :mach_header_64)
     712                     #-64-bit-target (record-length :mach_header))
     713           (%inc-ptr p (pref p :load_command.cmdsize)))
     714        (i 0 (1+ i))
     715        (n (pref header
     716                 #+64-bit-target :mach_header_64.ncmds
     717                 #-64-bit-target :mach_header.ncmds)))
     718       ((= i n))
     719    (when (= #$LC_ID_DYLIB (pref p :load_command.cmd))
     720      (return (%get-cstring (%inc-ptr p (record-length :dylib_command)))))))
     721
     722                 
     723                     
     724                                                           
     725(defun init-shared-libraries ()
     726  (do* ((count (ff-call *dyld-image-count* :unsigned-fullword))
     727        (i 1 (1+ i)))
     728       ((= i count))
     729    (declare (fixnum i count))
     730    (let* ((addr (ff-call *dyld-get-image-header* :unsigned-fullword i :address))
     731           (nameptr (ff-call *dyld-get-image-name* :unsigned-fullword i :address))
     732           (name (%get-cstring nameptr ))
     733           (lib (%cons-shlib (soname-from-mach-header addr) name nil addr)))
     734      (setf (shlib.handle lib)
     735            (ff-call *dlopen-entry* :address nameptr :unsigned-fullword (logior #$RTLD_GLOBAL #$RTLD_NOLOAD)))
     736      (push lib *shared-libraries*))))
     737
     738(init-shared-libraries)
    808739
    809740;; end Darwin progn
  • trunk/source/level-1/linux-files.lisp

    r14648 r14656  
    10001000                    (error "Shared library ~s not found." lib))
    10011001                (require-type lib 'shlib)))
    1002          (handle (shlib.handle lib)))
     1002         (handle (shlib.handle lib))
     1003         (opencount (shlib.opencount lib)))
    10031004      (when handle
    1004         (let* ((found nil))
    1005           (do* ()
    1006                ((progn
    1007                   #-windows-target (#_dlclose handle)
    1008                   #+windows-target (#_FreeLibrary handle)
    1009                   (or (not (setq found
    1010                                  (%probe-shared-library lib)))
    1011                       (not completely)))))
    1012           (when (not found)
    1013             (setf (shlib.pathname lib) nil
    1014                   (shlib.base lib) nil
    1015                   (shlib.handle lib) nil
    1016                   (shlib.map lib) nil)
    1017             (unload-foreign-variables nil)
    1018             (unload-library-entrypoints nil))))))
     1005        (dotimes (i (if completely opencount 1))
     1006          (unless #-windows-target (eql 0 (#_dlclose handle))
     1007                  #+windows-target (not (eql 0(#_FreeLibrary handle)))
     1008                  (return))
     1009          (decf (shlib.opencount lib)))
     1010        (when (and (eql 0 (shlib.opencount lib))
     1011                   (not (%probe-shared-library lib)))
     1012          (setf (shlib.pathname lib) nil
     1013                (shlib.base lib) nil
     1014                (shlib.handle lib) nil
     1015                (shlib.map lib) nil)
     1016          (unload-foreign-variables nil)
     1017          (unload-library-entrypoints nil)))))
    10191018
    10201019
  • trunk/source/library/lispequ.lisp

    r13327 r14656  
    13891389
    13901390
    1391 (def-accessor-macros %svref
     1391(def-accessors (shlib) %svref
    13921392    nil                                 ;'shlib
    13931393  shlib.soname
Note: See TracChangeset for help on using the changeset viewer.