/[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.22 by dtc, Mon May 5 23:13:52 1997 UTC revision 1.22.2.2 by pw, Tue Jun 23 11:21:57 1998 UTC
# Line 241  Line 241 
241  #+hppa  #+hppa
242  (defconstant reloc-magic #x106)  (defconstant reloc-magic #x106)
243  #+hppa  #+hppa
244    (defconstant cpu-pa-risc1-0 #x20b)
245    #+hppa
246  (defconstant cpu-pa-risc1-1 #x210)  (defconstant cpu-pa-risc1-1 #x210)
247    #+hppa
248    (defconstant cpu-pa-risc-max #x2ff)
249    
250  #+hppa  #+hppa
251  (defun load-object-file (name)  (defun load-object-file (name)
# Line 284  Line 288 
288              ))              ))
289        (unix:unix-close fd))))        (unix:unix-close fd))))
290    
291  #-(or linux solaris)  #-(or linux solaris irix)
292  (defun parse-symbol-table (name)  (defun parse-symbol-table (name)
293    (format t ";;; Parsing symbol table...~%")    (format t ";;; Parsing symbol table...~%")
294    (let ((symbol-table (make-hash-table :test #'equal)))    (let ((symbol-table (make-hash-table :test #'equal)))
# Line 332  Line 336 
336      #+hpux      #+hpux
337      (dolist (f files)      (dolist (f files)
338        (with-open-file (stream f :element-type '(unsigned-byte 16))        (with-open-file (stream f :element-type '(unsigned-byte 16))
339          (unless (eql (read-byte stream) cpu-pa-risc1-1)          (unless (let ((sysid (read-byte stream)))
340                      (or (eql sysid cpu-pa-risc1-0)
341                          (and (>= sysid cpu-pa-risc1-1)
342                               (<= sysid cpu-pa-risc-max))))
343            (error "Object file is wrong format, so can't load-foreign:~            (error "Object file is wrong format, so can't load-foreign:~
344                    ~%  ~S"                    ~%  ~S"
345                   f))                   f))
# Line 375  Line 382 
382    
383  (export '(alternate-get-global-address))  (export '(alternate-get-global-address))
384    
385  #-(or freebsd solaris linux)  #-(or solaris linux irix)
386  (defun alternate-get-global-address (symbol)  (defun alternate-get-global-address (symbol)
387    (declare (type simple-string symbol)    (declare (type simple-string symbol)
388             (ignore symbol))             (ignore symbol))
389    0)    0)
390    
391  #+(or linux solaris)  #+(or linux solaris irix)
392  (progn  (progn
393    
394  (defconstant rtld-lazy 1)  (defconstant rtld-lazy 1
395  (defconstant rtld-now 2)    "Lazy function call binding")
396  (defconstant rtld-global #o400)  (defconstant rtld-now 2
397  (defvar *global-table* NIL)    "Immediate function call binding")
398    #+(and linux glibc2)
399    (defconstant rtld-binding-mask #x3
400      "Mask of binding time value")
401    
402    (defconstant rtld-global #-irix #x100 #+irix 4
403      "If set the symbols of the loaded object and its dependencies are
404       made visible as if the object were linked directly into the program")
405    
406    (defvar *global-table* nil)
407    ;;; Dynamically loaded stuff isn't there upon restoring from a
408    ;;; save--this is primarily for irix, which resolves tzname at
409    ;;; runtime, resulting in *global-table* being set in the saved core
410    ;;; image, resulting in havoc upon restart.
411    (pushnew #'(lambda () (setq *global-table* nil))
412             ext:*after-save-initializations*)
413    
414    (defvar *dso-linker*
415      #+solaris "/usr/ccs/bin/ld"
416      #+(or linux irix) "/usr/bin/ld")
417    
418  (alien:def-alien-routine dlopen system-area-pointer  (alien:def-alien-routine dlopen system-area-pointer
419    (str c-call:c-string) (i c-call:int))    (file c-call:c-string) (mode c-call:int))
420  (alien:def-alien-routine dlsym system-area-pointer  (alien:def-alien-routine dlsym system-area-pointer
421    (lib system-area-pointer)    (lib system-area-pointer)
422    (str c-call:c-string))    (name c-call:c-string))
423  (alien:def-alien-routine dlclose void (lib system-area-pointer))  (alien:def-alien-routine dlclose void (lib system-area-pointer))
424  (alien:def-alien-routine dlerror c-call:c-string)  (alien:def-alien-routine dlerror c-call:c-string)
425    
426    ;;; Ensure we've opened our own binary so can resolve global variables
427    ;;; in the lisp image that come from libraries. This used to happen
428    ;;; only in alternate-get-global-address, and only if no libraries
429    ;;; were dlopened already, but that didn't work if something was
430    ;;; dlopened before any problem global vars were used. So now we do
431    ;;; this in any function that can add to the global-table, as well as
432    ;;; in alternate-get-global-address.
433    (defun ensure-lisp-table-opened ()
434      (unless *global-table*
435        ;; Prevent recursive call if dlopen isn't defined
436        (setf *global-table* (int-sap 0))
437        (setf *global-table* (list (dlopen nil rtld-lazy)))
438        (when (zerop (system:sap-int (car *global-table*)))
439          (error "Can't open global symbol table: ~S" (dlerror)))))
440    
441  (defun load-object-file (file)  (defun load-object-file (file)
442      (ensure-lisp-table-opened)
443    ; rtld global: so it can find all the symbols previously loaded    ; rtld global: so it can find all the symbols previously loaded
444    ; 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.
445    (let ((sap (dlopen file (logior rtld-now rtld-global))))    (let ((sap (dlopen file (logior rtld-now rtld-global))))
446         (if (zerop (sap-int sap))         (if (zerop (sap-int sap))
447             (error "Can't open object ~S: ~S" file (dlerror))             (error "Can't open object ~S: ~S" file (dlerror))
448             (pushnew sap *global-table*))))             (pushnew sap *global-table* :test #'sap=))))
449    
450  (defun alternate-get-global-address (symbol)  (defun alternate-get-global-address (symbol)
451    (unless *global-table*    (ensure-lisp-table-opened)
           ;; Prevent recursive call when dlopen isn't defined.  
           (setq *global-table* (int-sap 0))  
           ;; Load standard object  
           (setq *global-table* (list (dlopen nil rtld-lazy)))  
           (if (zerop (system:sap-int (car *global-table*)))  
               (error "Can't open global symbol table: ~S" (dlerror))))  
452    ;; find the symbol in any of the loaded obbjects,    ;; find the symbol in any of the loaded obbjects,
453    ;; search in reverse order of loading, later loadings    ;; search in reverse order of loading, later loadings
454    ;; take precedence    ;; take precedence
# Line 439  Line 475 
475    ;; the same name twice, the old objects is reused.    ;; the same name twice, the old objects is reused.
476    (declare (ignore base-file))    (declare (ignore base-file))
477    (let ((output-file (pick-temporary-file-name    (let ((output-file (pick-temporary-file-name
478                        (concatenate 'string "/tmp/~D~S" (string (gensym)))))                        (concatenate 'string "/tmp/~D~C" (string (gensym)))))
479          (error-output (make-string-output-stream)))          (error-output (make-string-output-stream)))
480    
481      #-linux (format t ";;; Running /usr/ccs/bin/ld...~%")      (format t ";;; Running ~A...~%" *dso-linker*)
     #+linux (format t ";;; Running /usr/bin/ld...~%")  
482      (force-output)      (force-output)
483      (let ((proc (ext:run-program      (let ((proc (ext:run-program
484                   #-linux "/usr/ccs/bin/ld"                   *dso-linker*
                  #+linux "/usr/bin/ld"  
485                   (list*                   (list*
486                          "-G"                          #+(or solaris linux) "-G" #+irix "-shared"
487                          "-o"                          "-o"
488                          output-file                          output-file
489                          (append (mapcar #'(lambda (name)                          (append (mapcar #'(lambda (name)
# Line 463  Line 497 
497                   :output error-output                   :output error-output
498                   :error :output)))                   :error :output)))
499        (unless proc        (unless proc
500          (error  #+linux "Could not run /usr/bin/ld"         (error "Could not run ~A" *dso-linker*))
                 #-linux "Could not run /usr/ccs/bin/ld"))  
501        (unless (zerop (ext:process-exit-code proc))        (unless (zerop (ext:process-exit-code proc))
502          (system:serve-all-events 0)          (system:serve-all-events 0)
503          (error #-linux "/usr/ccs/bin/ld failed:~%~A"          (error "~A failed:~%~A" *dso-linker*
                #+linux "/usr/bin/ld failed:~%~A"  
504                 (get-output-stream-string error-output)))                 (get-output-stream-string error-output)))
505        (load-object-file output-file)        (load-object-file output-file)
506        (unix:unix-unlink output-file)        (unix:unix-unlink output-file)

Legend:
Removed from v.1.22  
changed lines
  Added in v.1.22.2.2

  ViewVC Help
Powered by ViewVC 1.1.5