From f2b840dbc0a52bbbe545a3708709fa22a58268a0 Mon Sep 17 00:00:00 2001
From: emarsden <emarsden>
Date: Thu, 22 Apr 2004 12:12:04 +0000
Subject: [PATCH] Change the behaviour of EXT:LOAD-FOREIGN when called with a
 single shared library: call SYS::LOAD-OBJECT-FILE directly, without invoking
 the linker as previously. This should make it possible to support the
 reloading of dependent shared libraries upon startup of a saved image.

The new behaviour requires a function FILE-SHARED-LIBRARY-P to be defined. I
have provided an implementation that works for ELF platforms. This has been
tested with Linux/x86 and Solaris/SPARC, but is also enabled by
conditionalization for :bsd (should include FreeBSD and OpenBSD).

Also removed pmax support. IRIX and HPPA platforms will need to provide a
definition for F-S-L-P.
---
 code/foreign.lisp | 248 ++++++++++++++++++++--------------------------
 1 file changed, 109 insertions(+), 139 deletions(-)

diff --git a/code/foreign.lisp b/code/foreign.lisp
index d737b04df..9bd9e5931 100644
--- a/code/foreign.lisp
+++ b/code/foreign.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/foreign.lisp,v 1.44 2003/05/26 14:16:58 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/foreign.lisp,v 1.45 2004/04/22 12:12:04 emarsden Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -19,9 +19,6 @@
 #+sparc (defconstant foreign-segment-start #xe0000000)
 #+sparc (defconstant foreign-segment-size  #x00100000)
 
-#+pmax (defconstant foreign-segment-start #x00C00000)
-#+pmax (defconstant foreign-segment-size  #x00400000)
-
 #+hppa (defconstant foreign-segment-start #x10C00000)
 #+hppa (defconstant foreign-segment-size  #x00400000)
 
@@ -69,7 +66,7 @@
     (trsize c-call:unsigned-long)
     (drsize c-call:unsigned-long)))
 
-#-(or OpenBSD linux svr4)
+#-(or linux bsd svr4)
 (defun allocate-space-in-foreign-segment (bytes)
   (let* ((pagesize-1 (1- (get-page-size)))
 	 (memory-needed (logandc2 (+ bytes pagesize-1) pagesize-1))
@@ -82,14 +79,14 @@
     addr))
 
 
-;;;
-;;;  Elf object file loading for statically linked CMUCL under
-;;;  FreeBSD.
+;;; ELF object file loading. Note that the conditionalization is
+;;; assuming that all of Linux/x86, Linux/Alpha, FreeBSD/x86,
+;;; OpenBSD/x86, and Solaris ports support ELF. 
 ;;;
 ;;; The following definitions are taken from
 ;;; /usr/include/sys/elf_common.h and /usr/include/sys/elf32.h.
 ;;;
-#+(or NetBSD (and FreeBSD elf (not FreeBSD4)))
+#+(or linux bsd svr4)
 (progn
 (alien:def-alien-type elf-address      (alien:unsigned 32))
 (alien:def-alien-type elf-half-word    (alien:unsigned 16))
@@ -197,9 +194,28 @@
     (t (format nil "Unknown ABI (~D)" id))))
 
 (defun elf-executable-p (n)
-  "Given a file type number, determine if the file is executable."
+  "Given a file type number, determine whether the file is executable."
   (= n et-executable))
 
+(defun file-shared-library-p (pathname)
+  (with-open-file (obj pathname
+                       :direction :input
+                       :element-type '(unsigned-byte 8))
+    (let ((fd (lisp::fd-stream-fd obj)))
+      (alien:with-alien ((header eheader))
+        (unix:unix-read fd (alien:alien-sap header) (alien:alien-size eheader :bytes))
+        (when (elf-p (alien:slot header 'elf-ident))
+          (eql et-shared-object (alien:slot header 'elf-type)))))))
+) ;; #+(or linux bsd svr4)
+
+
+
+;; "old-style" loading of foreign code. This involves calling a
+;; platform-specific script that is installed as
+;; library:load-foreign.csh to convert the object files into a form
+;; that is suitable for being stuffed into memory at runtime. 
+#-(or linux bsd svr4)
+(progn
 (defun load-object-file (name)
   ;; NAME designates a tempory file created by ld via "load-foreign.csh".
   ;; Its contents are in a form suitable for stuffing into memory for
@@ -273,8 +289,9 @@ to skip undefined symbols which don't have an address."
 		      symbol old-address address))
 	      (setf (gethash symbol symbol-table) address))))))
     (setf lisp::*foreign-symbols* symbol-table)))
-)
-
+) ;; #-(or linux bsd svr4)
+
+
 
 ;;; pw-- This seems to work for FreeBSD. The MAGIC field is not tested
 ;;; for correct file format so it may croak if ld fails to produce the
@@ -299,67 +316,6 @@ to skip undefined symbols which don't have an address."
       (unix:unix-close fd))))
 
 
-#+pmax
-(alien:def-alien-type filehdr
-  (alien:struct nil
-    (magic c-call:unsigned-short)
-    (nscns c-call:unsigned-short)
-    (timdat c-call:long)
-    (symptr c-call:long)
-    (nsyms c-call:long)
-    (opthdr c-call:unsigned-short)
-    (flags c-call:unsigned-short)))
-
-#+pmax
-(alien:def-alien-type aouthdr
-  (alien:struct nil
-    (magic c-call:short)
-    (vstamp c-call:short)
-    (tsize c-call:long)
-    (dsize c-call:long)
-    (bsize c-call:long)
-    (entry c-call:long)
-    (text_start c-call:long)
-    (data_start c-call:long)))
-
-#+pmax
-(defconstant filhsz 20)
-#+pmax
-(defconstant aouthsz 56)
-#+pmax
-(defconstant scnhsz 40)
-
-#+pmax
-(defun load-object-file (name)
-  (format t ";;; Loading object file...~%")
-  (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
-    (unless fd
-      (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno)))
-    (unwind-protect
-	(alien:with-alien ((filehdr filehdr)
-			   (aouthdr aouthdr))
-	  (unix:unix-read fd
-			  (alien:alien-sap filehdr)
-			  (alien:alien-size filehdr :bytes))
-	  (unix:unix-read fd
-			  (alien:alien-sap aouthdr)
-			  (alien:alien-size aouthdr :bytes))
-	  (let* ((len-of-text-and-data
-		  (+ (alien:slot aouthdr 'tsize) (alien:slot aouthdr 'dsize)))
-		 (memory-needed
-		  (+ len-of-text-and-data (alien:slot aouthdr 'bsize)))
-		 (addr (allocate-space-in-foreign-segment memory-needed))
-		 (pad-size-1 (if (< (alien:slot aouthdr 'vstamp) 23) 7 15)))
-	    (unix:unix-lseek fd
-			     (logandc2 (+ filhsz aouthsz
-					  (* scnhsz
-					     (alien:slot filehdr 'nscns))
-					  pad-size-1)
-				       pad-size-1)
-			     unix:l_set)
-	    (unix:unix-read fd addr len-of-text-and-data)))
-      (unix:unix-close fd))))
-
 #+hppa
 (alien:def-alien-type nil
     (alien:struct sys_clock
@@ -484,7 +440,8 @@ to skip undefined symbols which don't have an address."
             ))
       (unix:unix-close fd))))
 
-#-(or OpenBSD linux solaris irix NetBSD (and FreeBSD elf))
+#-(or linux bsd solaris irix)
+(progn
 (defun parse-symbol-table (name)
   (format t ";;; Parsing symbol table...~%")
   (let ((symbol-table (make-hash-table :test #'equal)))
@@ -504,7 +461,6 @@ to skip undefined symbols which don't have an address."
 	    (setf (gethash symbol symbol-table) address)))))
     (setf lisp::*foreign-symbols* symbol-table)))
 
-#-(or OpenBSD linux irix solaris)
 (defun load-foreign (files &key
 			   (libraries '("-lc"))
 			   (base-file
@@ -590,13 +546,15 @@ to skip undefined symbols which don't have an address."
 
 (export '(alternate-get-global-address))
 
-#-(or OpenBSD linux solaris irix)
 (defun alternate-get-global-address (symbol)
   (declare (type simple-string symbol)
 	   (ignore symbol))
   0)
+) ;; #-(or linux bsd solaris irix)
+
 
-#+(or OpenBSD linux solaris irix FreeBSD4)
+;; Modern dlopen()-based loading of shared libraries
+#+(or linux bsd solaris irix)
 (progn
 
 (defconstant rtld-lazy 1
@@ -622,7 +580,7 @@ to skip undefined symbols which don't have an address."
 
 (defvar *dso-linker*
   #+solaris "/usr/ccs/bin/ld"
-  #+(or OpenBSD linux irix FreeBSD4) "/usr/bin/ld")
+  #-solaris "/usr/bin/ld")
 
 (alien:def-alien-routine dlopen system-area-pointer
   (file c-call:c-string) (mode c-call:int))
@@ -695,7 +653,7 @@ to skip undefined symbols which don't have an address."
 
 (defun alternate-get-global-address (symbol)
   (ensure-lisp-table-opened)
-  ;; find the symbol in any of the loaded obbjects,
+  ;; find the symbol in any of the loaded objects,
   ;; search in reverse order of loading, later loadings
   ;; take precedence
   (let ((result 0))
@@ -709,68 +667,80 @@ to skip undefined symbols which don't have an address."
 			   (base-file nil)
 			   (env ext:*environment-list*)
 		           (verbose *load-verbose*))
-  "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
-  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.  The env
-  argument is the Unix environment variable definitions for the invocation of
-  the linker.  The default is the environment passed to Lisp."
+  "Load C object files into the 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 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. The ENV argument is the Unix environment variable
+definitions for the invocation of the linker. The default is the
+environment passed to Lisp."
   ;; Note: dlopen remembers the name of an object, when dlopenin
   ;; the same name twice, the old objects is reused.
   (declare (ignore base-file))
-  (let ((output-file (pick-temporary-file-name
-		      (concatenate 'string "/tmp/~D~C" (string (gensym)))))
-	(error-output (make-string-output-stream)))
+  ;; if passed a single shared object that can be loaded directly via
+  ;; dlopen(), do that instead of using the linker
+  (cond ((and (atom files)
+              (probe-file files)
+              (file-shared-library-p files))
+         (when verbose
+           (format t ";;; Opening shared library ~A ...~%" files))
+         (load-object-file files)
+         (when verbose
+           (format t ";;; Done.~%")))
+        (t
+         (let ((output-file (pick-temporary-file-name
+                             (concatenate 'string "/tmp/~D~C" (string (gensym)))))
+               (error-output (make-string-output-stream)))
  
-    (when verbose
-      (format t ";;; Running ~A...~%" *dso-linker*)
-      (force-output))
+           (when verbose
+             (format t ";;; Running ~A...~%" *dso-linker*)
+             (force-output))
     
-    (let ((proc (ext:run-program
-		 *dso-linker*
-		 (list*
-		        #+(or solaris linux FreeBSD4) "-G"
-			#+(or OpenBSD irix) "-shared"
-			"-o"
-			output-file
-			;; Cause all specified libs to be loaded in full
-			#+(or OpenBSD linux FreeBSD4) "--whole-archive"
-			#+solaris "-z" #+solaris "allextract"
-			(append (mapcar
-				 #'(lambda (name)
-				     (or (unix-namestring name)
-					 (error 'simple-file-error
-						:pathname name
-						:format-control
-						"File does not exist: ~A."
-						:format-arguments
-						(list name))))
-				 (if (atom files)
-				     (list files)
-				     files))
-				;; Return to default ld behaviour for libs
-				(list
-				 #+(or OpenBSD linux FreeBSD4)
-				 "--no-whole-archive"
-				 #+solaris "-z" #+solaris "defaultextract")
-				libraries))
-		 :env env
-		 :input nil
-		 :output error-output
-		 :error :output)))
-      (unless proc
-       (error "Could not run ~A" *dso-linker*))
-      (unless (zerop (ext:process-exit-code proc))
-	(system:serve-all-events 0)
-        (error "~A failed:~%~A" *dso-linker*
-	       (get-output-stream-string error-output)))
-      (load-object-file output-file)
-      (unix:unix-unlink output-file)
-      ))
-  (when verbose
-    (format t ";;; Done.~%")
-    (force-output)))
-)
+           (let ((proc (ext:run-program
+                        *dso-linker*
+                        (list*
+                         #+(or solaris linux FreeBSD4) "-G"
+                         #+(or OpenBSD irix) "-shared"
+                         "-o"
+                         output-file
+                         ;; Cause all specified libs to be loaded in full
+                         #+(or OpenBSD linux FreeBSD4) "--whole-archive"
+                         #+solaris "-z" #+solaris "allextract"
+                         (append (mapcar
+                                  #'(lambda (name)
+                                      (or (unix-namestring name)
+                                          (error 'simple-file-error
+                                                 :pathname name
+                                                 :format-control
+                                                 "File does not exist: ~A."
+                                                 :format-arguments
+                                                 (list name))))
+                                  (if (atom files)
+                                      (list files)
+                                      files))
+                                 ;; Return to default ld behaviour for libs
+                                 (list
+                                  #+(or OpenBSD linux FreeBSD4)
+                                  "--no-whole-archive"
+                                  #+solaris "-z" #+solaris "defaultextract")
+                                 libraries))
+                        :env env
+                        :input nil
+                        :output error-output
+                        :error :output)))
+             (unless proc
+               (error "Could not run ~A" *dso-linker*))
+             (unless (zerop (ext:process-exit-code proc))
+               (system:serve-all-events 0)
+               (error "~A failed:~%~A" *dso-linker*
+                      (get-output-stream-string error-output)))
+             (load-object-file output-file)
+             (unix:unix-unlink output-file)))
+         (when verbose
+           (format t ";;; Done.~%")
+           (force-output)))))
+
+) ;; #+(or linux bsd solaris irix)
-- 
GitLab