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

Contents of /src/code/foreign.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.47 - (hide annotations)
Tue Jun 1 16:11:29 2004 UTC (9 years, 10 months ago) by emarsden
Branch: MAIN
CVS Tags: snapshot-2004-06
Changes since 1.46: +2 -2 lines
Fix for EXT:LOAD-FOREIGN: LDEMULATION environment variable passed to linker
via EXT:RUN-PROGRAM should be a keyword, not a string.

From Immanuel Litzroth.
1 wlott 1.3 ;;; -*- Package: SYSTEM -*-
2     ;;;
3 ram 1.1 ;;; **********************************************************************
4 ram 1.5 ;;; This code was written as part of the CMU Common Lisp project at
5     ;;; Carnegie Mellon University, and has been placed in the public domain.
6     ;;;
7     (ext:file-comment
8 emarsden 1.47 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/foreign.lisp,v 1.47 2004/06/01 16:11:29 emarsden Exp $")
9 ram 1.5 ;;;
10 ram 1.1 ;;; **********************************************************************
11 wlott 1.3 ;;;
12     (in-package "SYSTEM")
13 ram 1.1
14 ram 1.11 (in-package "ALIEN")
15 wlott 1.3 (export '(load-foreign))
16 wlott 1.4 (in-package "SYSTEM")
17 ram 1.11 (import 'alien:load-foreign)
18 wlott 1.13
19     #+sparc (defconstant foreign-segment-start #xe0000000)
20     #+sparc (defconstant foreign-segment-size #x00100000)
21    
22 ram 1.16 #+hppa (defconstant foreign-segment-start #x10C00000)
23     #+hppa (defconstant foreign-segment-size #x00400000)
24    
25 pmai 1.35 #+(and bsd x86)
26 dtc 1.29 (defconstant foreign-segment-start #x0E000000)
27 pmai 1.35 #+(and bsd x86)
28 dtc 1.29 (defconstant foreign-segment-size #x02000000)
29 ram 1.21
30 wlott 1.3 (defvar *previous-linked-object-file* nil)
31 pmai 1.40 #-(or openbsd linux irix)
32 wlott 1.3 (defvar *foreign-segment-free-pointer* foreign-segment-start)
33 ram 1.1
34 wlott 1.3 (defun pick-temporary-file-name (&optional (base "/tmp/tmp~D~C"))
35     (let ((code (char-code #\A)))
36     (loop
37 wlott 1.8 (let ((name (format nil base (unix:unix-getpid) (code-char code))))
38 wlott 1.3 (multiple-value-bind
39     (fd errno)
40 wlott 1.8 (unix:unix-open name
41     (logior unix:o_wronly unix:o_creat unix:o_excl)
42 wlott 1.3 #o666)
43     (cond ((not (null fd))
44 wlott 1.8 (unix:unix-close fd)
45 wlott 1.3 (return name))
46 wlott 1.8 ((not (= errno unix:eexist))
47 wlott 1.3 (error "Could not create temporary file ~S: ~A"
48 wlott 1.8 name (unix:get-unix-error-msg errno)))
49 wlott 1.3
50     ((= code (char-code #\Z))
51     (setf code (char-code #\a)))
52     ((= code (char-code #\z))
53     (return nil))
54     (t
55     (incf code))))))))
56 ram 1.1
57 pmai 1.40 #+(or (and FreeBSD (not elf)) (and sparc (not svr4)))
58 wlott 1.8 (alien:def-alien-type exec
59     (alien:struct nil
60     (magic c-call:unsigned-long)
61     (text c-call:unsigned-long)
62     (data c-call:unsigned-long)
63     (bss c-call:unsigned-long)
64     (syms c-call:unsigned-long)
65     (entry c-call:unsigned-long)
66     (trsize c-call:unsigned-long)
67     (drsize c-call:unsigned-long)))
68 ram 1.1
69 emarsden 1.45 #-(or linux bsd svr4)
70 wlott 1.3 (defun allocate-space-in-foreign-segment (bytes)
71 ram 1.6 (let* ((pagesize-1 (1- (get-page-size)))
72 wlott 1.3 (memory-needed (logandc2 (+ bytes pagesize-1) pagesize-1))
73     (addr (int-sap *foreign-segment-free-pointer*))
74 ram 1.15 (new-ptr (+ *foreign-segment-free-pointer* memory-needed)))
75 wlott 1.3 (when (> new-ptr (+ foreign-segment-start foreign-segment-size))
76     (error "Not enough memory left."))
77     (setf *foreign-segment-free-pointer* new-ptr)
78 wlott 1.10 (allocate-system-memory-at addr memory-needed)
79 wlott 1.3 addr))
80 ram 1.1
81 pw 1.30
82 emarsden 1.45 ;;; ELF object file loading. Note that the conditionalization is
83     ;;; assuming that all of Linux/x86, Linux/Alpha, FreeBSD/x86,
84     ;;; OpenBSD/x86, and Solaris ports support ELF.
85 pw 1.30 ;;;
86     ;;; The following definitions are taken from
87     ;;; /usr/include/sys/elf_common.h and /usr/include/sys/elf32.h.
88     ;;;
89 emarsden 1.45 #+(or linux bsd svr4)
90 pw 1.30 (progn
91     (alien:def-alien-type elf-address (alien:unsigned 32))
92     (alien:def-alien-type elf-half-word (alien:unsigned 16))
93     (alien:def-alien-type elf-offset (alien:unsigned 32))
94     (alien:def-alien-type elf-signed-word (alien:integer 32))
95     (alien:def-alien-type elf-word (alien:unsigned 32))
96     (alien:def-alien-type elf-size (alien:unsigned 32))
97    
98     (alien:def-alien-type eheader
99     ;;"Elf file header."
100     (alien:struct nil
101     (elf-ident (alien:array (alien:unsigned 8) 16))
102     (elf-type elf-half-word)
103     (elf-machine elf-half-word)
104     (elf-version elf-word)
105     (elf-entry elf-address)
106     (elf-program-header-offset elf-offset)
107     (elf-section-header-offset elf-offset)
108     (elf-flags elf-word)
109     (elf-header-size elf-half-word)
110     (elf-program-header-entry-size elf-half-word)
111     (elf-program-header-count elf-half-word)
112     (elf-section-header-entry-size elf-half-word)
113     (elf-section-header-count elf-half-word)
114     (elf-section-name-strings elf-half-word)))
115    
116 pmai 1.37 ;; Indices into the elf-ident array, as per SVR4 ABI
117     (defconstant ei-mag0 0) ; Magic number, byte 0
118     (defconstant ei-mag1 1) ; Magic number, byte 1
119     (defconstant ei-mag2 2) ; Magic number, byte 2
120     (defconstant ei-mag3 3) ; Magic number, byte 3
121     (defconstant ei-class 4) ; class of machine
122     (defconstant ei-data 5) ; data format
123     (defconstant ei-version 6) ; ELF format version
124     (defconstant ei-osabi 7) ; Operating system / ABI identification
125     (defconstant ei-abiversion 8) ; ABI version
126     (defconstant ei-pad 9) ; Start of padding
127     (defconstant ei-nident 16) ; Size of elf-ident array
128    
129 pw 1.30 ;; values for elf-type
130     (defconstant et-relocatable 1)
131     (defconstant et-executable 2)
132     (defconstant et-shared-object 3)
133     (defconstant et-core-file 4)
134    
135 pmai 1.37 ;; values for elf-ident[ei-osabi]
136     (defconstant elfosabi-sysv 0)
137     (defconstant elfosabi-hpux 1)
138     (defconstant elfosabi-netbsd 2)
139     (defconstant elfosabi-linux 3)
140     (defconstant elfosabi-hurd 4)
141     (defconstant elfosabi-86open 5)
142     (defconstant elfosabi-solaris 6)
143     (defconstant elfosabi-monterey 7)
144     (defconstant elfosabi-irix 8)
145     (defconstant elfosabi-freebsd 9)
146     (defconstant elfosabi-tru64 10)
147     (defconstant elfosabi-modesto 11)
148     (defconstant elfosabi-openbsd 12)
149     (defconstant elfosabi-arm 97)
150     (defconstant elfosabi-standalone 255)
151    
152 pw 1.30 (alien:def-alien-type pheader
153     ;;"Program header."
154     (alien:struct nil
155     (p-type elf-word) ; Entry type.
156     (p-offset elf-offset) ; File offset of contents.
157     (p-virtual-address elf-address) ; Virtual address in mem. image.
158     (p-physical-address elf-address) ; Physical address (not used).
159     (p-file-size elf-size) ; Size of contents in file.
160     (p-memory-size elf-size) ; Size of contents in memory.
161     (p-flags elf-word) ; Access permission flags.
162     (p-alignment elf-size))) ; Alignment in memory and file.
163    
164     (defconstant +elf-magic+
165     (make-array 4 :element-type '(unsigned-byte 8)
166     :initial-contents '(127 69 76 70))) ; 0x7f-E-L-F
167     (defun elf-p (h)
168     "Make sure the header starts with the ELF magic value."
169     (dotimes (i 4 t)
170     (unless (= (alien:deref h i) (aref +elf-magic+ i))
171     (return nil))))
172    
173 pmai 1.37 (defun elf-osabi (h)
174     "Return the `osabi' field in the padding of the ELF file."
175     (alien:deref h ei-osabi))
176    
177     (defun elf-osabi-name (id)
178     (cond
179     ((eql id elfosabi-sysv) "Unix System V ABI")
180     ((eql id elfosabi-hpux) "HP-UX")
181     ((eql id elfosabi-netbsd) "NetBSD")
182     ((eql id elfosabi-linux) "Linux")
183     ((eql id elfosabi-hurd) "GNU/Hurd")
184     ((eql id elfosabi-86open) "86Open common IA32 ABI")
185     ((eql id elfosabi-solaris) "Solaris")
186     ((eql id elfosabi-monterey) "Monterey")
187     ((eql id elfosabi-irix) "IRIX")
188     ((eql id elfosabi-freebsd) "FreeBSD")
189     ((eql id elfosabi-tru64) "Tru64 Unix")
190     ((eql id elfosabi-modesto) "Novell Modesto")
191     ((eql id elfosabi-openbsd) "OpenBSD")
192     ((eql id elfosabi-arm) "ARM")
193     ((eql id elfosabi-standalone) "Standalone/Embedded")
194     (t (format nil "Unknown ABI (~D)" id))))
195 pw 1.30
196     (defun elf-executable-p (n)
197 emarsden 1.45 "Given a file type number, determine whether the file is executable."
198 pw 1.30 (= n et-executable))
199    
200 emarsden 1.45 (defun file-shared-library-p (pathname)
201     (with-open-file (obj pathname
202     :direction :input
203     :element-type '(unsigned-byte 8))
204     (let ((fd (lisp::fd-stream-fd obj)))
205     (alien:with-alien ((header eheader))
206     (unix:unix-read fd (alien:alien-sap header) (alien:alien-size eheader :bytes))
207     (when (elf-p (alien:slot header 'elf-ident))
208     (eql et-shared-object (alien:slot header 'elf-type)))))))
209     ) ;; #+(or linux bsd svr4)
210    
211    
212    
213     ;; "old-style" loading of foreign code. This involves calling a
214     ;; platform-specific script that is installed as
215     ;; library:load-foreign.csh to convert the object files into a form
216     ;; that is suitable for being stuffed into memory at runtime.
217     #-(or linux bsd svr4)
218     (progn
219 pw 1.30 (defun load-object-file (name)
220     ;; NAME designates a tempory file created by ld via "load-foreign.csh".
221     ;; Its contents are in a form suitable for stuffing into memory for
222     ;; execution. This function extracts the location and size of the
223     ;; relevant bits and reads them into memory.
224    
225     #|| library:load-foreign.csh
226     #!/bin/csh -fx
227     ld -N -R $argv[1] -Ttext $argv[2] -o $argv[3] $argv[5-]
228     if ($status != 0) exit 1
229    
230     nm -gp $argv[3] > $argv[4]
231     if ($status != 0) exit 2
232     exit 0
233     ||#
234    
235     (format t ";;; Loading object file...~%")
236     (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
237     (unless fd
238     (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno)))
239     (unwind-protect
240     (alien:with-alien ((header eheader))
241     (unix:unix-read fd
242     (alien:alien-sap header)
243     (alien:alien-size eheader :bytes))
244     (unless (elf-p (alien:slot header 'elf-ident))
245 pmai 1.37 (error (format nil "~A is not an ELF file." name)))
246 pw 1.30
247 pmai 1.37 (let ((osabi (elf-osabi (alien:slot header 'elf-ident)))
248     (expected-osabi #+NetBSD elfosabi-netbsd
249     #+FreeBSD elfosabi-freebsd))
250     (unless (= osabi expected-osabi)
251     (error "~A is not a ~A executable, it's a ~A executable."
252     name
253     (elf-osabi-name expected-osabi)
254     (elf-osabi-name osabi))))
255 pw 1.30
256     (unless (elf-executable-p (alien:slot header 'elf-type))
257     (error (format nil "~A is not executable." name)))
258    
259     (alien:with-alien ((program-header pheader))
260     (unix:unix-read fd
261     (alien:alien-sap program-header)
262     (alien:alien-size pheader :bytes))
263     (let* ((addr (system::allocate-space-in-foreign-segment
264     (alien:slot program-header 'p-memory-size))))
265     (unix:unix-lseek
266     fd (alien:slot program-header 'p-offset) unix:l_set)
267     (unix:unix-read
268     fd addr (alien:slot program-header 'p-file-size)))))
269     (unix:unix-close fd))))
270    
271     (defun parse-symbol-table (name)
272     "Parse symbol table file created by load-foreign script. Modified
273     to skip undefined symbols which don't have an address."
274     (format t ";;; Parsing symbol table...~%")
275     (let ((symbol-table (make-hash-table :test #'equal)))
276     (with-open-file (file name)
277     (loop
278     (let ((line (read-line file nil nil)))
279     (unless line
280     (return))
281     (unless (eql (aref line 0) #\space) ; Skip undefined symbols....
282     (let* ((symbol (subseq line 11))
283     (address (parse-integer line :end 8 :radix 16))
284 pmai 1.35 (kind (aref line 9)) ; filter out .o file names
285 pw 1.30 (old-address (gethash symbol lisp::*foreign-symbols*)))
286     (unless (or (null old-address) (= address old-address)
287 pmai 1.35 (char= kind #\F))
288 pw 1.30 (warn "~S moved from #x~8,'0X to #x~8,'0X.~%"
289     symbol old-address address))
290     (setf (gethash symbol symbol-table) address))))))
291     (setf lisp::*foreign-symbols* symbol-table)))
292 emarsden 1.45 ) ;; #-(or linux bsd svr4)
293    
294    
295 pw 1.30
296 ram 1.21 ;;; pw-- This seems to work for FreeBSD. The MAGIC field is not tested
297     ;;; for correct file format so it may croak if ld fails to produce the
298     ;;; expected results. It is probably good enough for now.
299 pmai 1.40 #+(or (and FreeBSD (not ELF)) (and sparc (not svr4)))
300 wlott 1.3 (defun load-object-file (name)
301     (format t ";;; Loading object file...~%")
302 wlott 1.8 (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
303 wlott 1.3 (unless fd
304 wlott 1.8 (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno)))
305 wlott 1.3 (unwind-protect
306 wlott 1.8 (alien:with-alien ((header exec))
307     (unix:unix-read fd
308     (alien:alien-sap header)
309     (alien:alien-size exec :bytes))
310 wlott 1.3 (let* ((len-of-text-and-data
311 wlott 1.8 (+ (alien:slot header 'text) (alien:slot header 'data)))
312 wlott 1.3 (memory-needed
313 wlott 1.8 (+ len-of-text-and-data (alien:slot header 'bss)))
314 wlott 1.3 (addr (allocate-space-in-foreign-segment memory-needed)))
315 wlott 1.8 (unix:unix-read fd addr len-of-text-and-data)))
316     (unix:unix-close fd))))
317 ram 1.1
318 pw 1.30
319 ram 1.16 #+hppa
320     (alien:def-alien-type nil
321     (alien:struct sys_clock
322     (secs c-call:unsigned-int)
323     (nanosecs c-call:unsigned-int)))
324     #+hppa
325     (alien:def-alien-type nil
326     (alien:struct header
327     (system_id c-call:short)
328     (a_magic c-call:short)
329     (version_id c-call:unsigned-int)
330     (file_time (alien:struct sys_clock))
331     (entry_space c-call:unsigned-int)
332     (entry_subspace c-call:unsigned-int)
333     (entry_offset c-call:unsigned-int)
334     (aux_header_location c-call:unsigned-int)
335     (aux_header_size c-call:unsigned-int)
336     (som_length c-call:unsigned-int)
337     (presumed_dp c-call:unsigned-int)
338     (space_location c-call:unsigned-int)
339     (space_total c-call:unsigned-int)
340     (subspace_location c-call:unsigned-int)
341     (subspace_total c-call:unsigned-int)
342     (loader_fixup_location c-call:unsigned-int)
343     (loader_fixup_total c-call:unsigned-int)
344     (space_strings_location c-call:unsigned-int)
345     (space_strings_size c-call:unsigned-int)
346     (init_array_location c-call:unsigned-int)
347     (init_array_total c-call:unsigned-int)
348     (compiler_location c-call:unsigned-int)
349     (compiler_total c-call:unsigned-int)
350     (symbol_location c-call:unsigned-int)
351     (symbol_total c-call:unsigned-int)
352     (fixup_request_location c-call:unsigned-int)
353     (fixup_request_total c-call:unsigned-int)
354     (symbol_strings_location c-call:unsigned-int)
355     (symbol_strings_size c-call:unsigned-int)
356     (unloadable_sp_location c-call:unsigned-int)
357     (unloadable_sp_size c-call:unsigned-int)
358     (checksum c-call:unsigned-int)))
359    
360     #+hppa
361     (alien:def-alien-type nil
362     (alien:struct aux_id
363     #|
364     (mandatory c-call:unsigned-int 1)
365     (copy c-call:unsigned-int 1)
366     (append c-call:unsigned-int 1)
367     (ignore c-call:unsigned-int 1)
368     (reserved c-call:unsigned-int 12)
369     (type c-call:unsigned-int 16)
370     |#
371     (dummy c-call:unsigned-int)
372     (length c-call:unsigned-int)))
373     #+hppa
374     (alien:def-alien-type nil
375     (alien:struct som_exec_auxhdr
376     (som_auxhdr (alien:struct aux_id))
377     (exec_tsize c-call:long)
378     (exec_tmem c-call:long)
379     (exec_tfile c-call:long)
380     (exec_dsize c-call:long)
381     (exec_dmem c-call:long)
382     (exec_dfile c-call:long)
383     (exec_bsize c-call:long)
384     (exec_entry c-call:long)
385     (exec_flags c-call:long)
386     (exec_bfill c-call:long)))
387    
388     #+hppa
389     (alien:def-alien-routine ("bzero" unix-bzero) c-call:void
390     (s alien:system-area-pointer)
391     (n c-call:unsigned-long))
392    
393     #+hppa
394 ram 1.19 (defconstant reloc-magic #x106)
395     #+hppa
396 pw 1.24 (defconstant cpu-pa-risc1-0 #x20b)
397     #+hppa
398 ram 1.19 (defconstant cpu-pa-risc1-1 #x210)
399 pw 1.24 #+hppa
400     (defconstant cpu-pa-risc-max #x2ff)
401 ram 1.19
402     #+hppa
403 ram 1.16 (defun load-object-file (name)
404     (format t ";;; Loading object file...~%")
405     (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
406     (unless fd
407     (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno)))
408     (unwind-protect
409     (alien:with-alien ((header (alien:struct som_exec_auxhdr)))
410     (unix:unix-lseek fd (alien:alien-size (alien:struct header) :bytes)
411     unix:l_set)
412     (unix:unix-read fd
413     (alien:alien-sap header)
414     (alien:alien-size (alien:struct som_exec_auxhdr)
415     :bytes))
416     (let* ((tmem (alien:slot header 'exec_tmem))
417     (tsize (alien:slot header 'exec_tsize))
418     (dmem (alien:slot header 'exec_dmem))
419     (dsize (alien:slot header 'exec_dsize))
420     (bsize (alien:slot header 'exec_bsize))
421     (memory-needed (+ tsize dsize bsize (* 2 4096)))
422     (addr (allocate-space-in-foreign-segment memory-needed)))
423     (unix-bzero addr memory-needed) ;force valid
424     (unix:unix-lseek fd (alien:slot header 'exec_tfile) unix:l_set)
425     (unix:unix-read fd (system:int-sap tmem) tsize)
426     (unix:unix-lseek fd (alien:slot header 'exec_dfile) unix:l_set)
427     (unix:unix-read fd (system:int-sap dmem) dsize)
428     (unix-bzero (system:int-sap (+ dmem dsize)) bsize)
429     ;;(format t "tmem ~X tsize ~X dmem ~X dsize ~X bsize ~X~%"
430     ;; tmem tsize dmem dsize bsize)
431     ;;(format t "tfile ~X dfile ~X~%"
432     ;; (alien:slot header 'exec_tfile)
433     ;; (alien:slot header 'exec_dfile))
434     (alien:alien-funcall (alien:extern-alien
435     "sanctify_for_execution"
436     (alien:function c-call:void
437     alien:system-area-pointer
438     c-call:unsigned-long))
439     addr (+ (- dmem tmem) dsize bsize))
440     ))
441 wlott 1.8 (unix:unix-close fd))))
442 ram 1.1
443 emarsden 1.45 #-(or linux bsd solaris irix)
444     (progn
445 wlott 1.3 (defun parse-symbol-table (name)
446     (format t ";;; Parsing symbol table...~%")
447     (let ((symbol-table (make-hash-table :test #'equal)))
448     (with-open-file (file name)
449     (loop
450     (let ((line (read-line file nil nil)))
451     (unless line
452     (return))
453     (let* ((symbol (subseq line 11))
454     (address (parse-integer line :end 8 :radix 16))
455 pmai 1.35 #+BSD (kind (aref line 9)) ; filter out .o file names
456 wlott 1.3 (old-address (gethash symbol lisp::*foreign-symbols*)))
457 ram 1.21 (unless (or (null old-address) (= address old-address)
458 pmai 1.35 #+BSD (char= kind #\F))
459 wlott 1.3 (warn "~S moved from #x~8,'0X to #x~8,'0X.~%"
460     symbol old-address address))
461     (setf (gethash symbol symbol-table) address)))))
462     (setf lisp::*foreign-symbols* symbol-table)))
463 ram 1.1
464 ram 1.11 (defun load-foreign (files &key
465 ram 1.1 (libraries '("-lc"))
466 ram 1.12 (base-file
467 ram 1.19 #-hpux
468 ram 1.12 (merge-pathnames *command-line-utility-name*
469 ram 1.19 "path:")
470 wlott 1.20 #+hpux "library:cmucl.orig")
471 toy 1.33 (env ext:*environment-list*)
472 moore 1.41 (verbose *load-verbose*))
473 ram 1.11 "Load-foreign loads a list of C object files into a running Lisp. The files
474     argument should be a single file or a list of files. The files may be
475     specified as namestrings or as pathnames. The libraries argument should be a
476     list of library files as would be specified to ld. They will be searched in
477     the order given. The default is just \"-lc\", i.e., the C library. The
478     base-file argument is used to specify a file to use as the starting place for
479     defined symbols. The default is the C start up code for Lisp. The env
480     argument is the Unix environment variable definitions for the invocation of
481     the linker. The default is the environment passed to Lisp."
482 wlott 1.3 (let ((output-file (pick-temporary-file-name))
483     (symbol-table-file (pick-temporary-file-name))
484 ram 1.19 (error-output (make-string-output-stream))
485     (files (if (atom files) (list files) files)))
486 ram 1.7
487 toy 1.33 (when verbose
488     (format t ";;; Running library:load-foreign.csh...~%")
489     (force-output))
490 ram 1.19 #+hpux
491     (dolist (f files)
492     (with-open-file (stream f :element-type '(unsigned-byte 16))
493 pw 1.24 (unless (let ((sysid (read-byte stream)))
494     (or (eql sysid cpu-pa-risc1-0)
495     (and (>= sysid cpu-pa-risc1-1)
496     (<= sysid cpu-pa-risc-max))))
497 ram 1.19 (error "Object file is wrong format, so can't load-foreign:~
498     ~% ~S"
499     f))
500     (unless (eql (read-byte stream) reloc-magic)
501     (error "Object file is not relocatable, so can't load-foreign:~
502     ~% ~S"
503     f))))
504    
505 wlott 1.14 (let ((proc (ext:run-program
506     "library:load-foreign.csh"
507     (list* (or *previous-linked-object-file*
508     (namestring (truename base-file)))
509     (format nil "~X"
510     *foreign-segment-free-pointer*)
511     output-file
512     symbol-table-file
513 dtc 1.32 (append (mapcar
514     #'(lambda (name)
515     (or (unix-namestring name)
516     (error 'simple-file-error
517     :pathname name
518     :format-control
519     "File does not exist: ~A."
520     :format-arguments
521     (list name))))
522    
523     files)
524 wlott 1.14 libraries))
525     :env env
526     :input nil
527     :output error-output
528     :error :output)))
529 wlott 1.3 (unless proc
530 ram 1.11 (error "Could not run library:load-foreign.csh"))
531 wlott 1.3 (unless (zerop (ext:process-exit-code proc))
532     (system:serve-all-events 0)
533 ram 1.11 (error "library:load-foreign.csh failed:~%~A"
534     (get-output-stream-string error-output)))
535 wlott 1.3 (load-object-file output-file)
536     (parse-symbol-table symbol-table-file)
537 wlott 1.8 (unix:unix-unlink symbol-table-file)
538 wlott 1.3 (let ((old-file *previous-linked-object-file*))
539     (setf *previous-linked-object-file* output-file)
540     (when old-file
541 wlott 1.8 (unix:unix-unlink old-file)))))
542 toy 1.33 (when verbose
543     (format t ";;; Done.~%")
544     (force-output)))
545 ram 1.17
546    
547     (export '(alternate-get-global-address))
548    
549 ram 1.21 (defun alternate-get-global-address (symbol)
550     (declare (type simple-string symbol)
551     (ignore symbol))
552     0)
553 emarsden 1.45 ) ;; #-(or linux bsd solaris irix)
554    
555 ram 1.17
556 emarsden 1.45 ;; Modern dlopen()-based loading of shared libraries
557     #+(or linux bsd solaris irix)
558 ram 1.17 (progn
559    
560 dtc 1.28 (defconstant rtld-lazy 1
561     "Lazy function call binding")
562     (defconstant rtld-now 2
563     "Immediate function call binding")
564     #+(and linux glibc2)
565     (defconstant rtld-binding-mask #x3
566     "Mask of binding time value")
567    
568     (defconstant rtld-global #-irix #x100 #+irix 4
569     "If set the symbols of the loaded object and its dependencies are
570     made visible as if the object were linked directly into the program")
571 dtc 1.27
572     (defvar *global-table* nil)
573     ;;; Dynamically loaded stuff isn't there upon restoring from a
574     ;;; save--this is primarily for irix, which resolves tzname at
575     ;;; runtime, resulting in *global-table* being set in the saved core
576     ;;; image, resulting in havoc upon restart.
577 moore 1.41 #-linkage-table
578 pw 1.25 (pushnew #'(lambda () (setq *global-table* nil))
579 dtc 1.27 ext:*after-save-initializations*)
580    
581 pw 1.24 (defvar *dso-linker*
582     #+solaris "/usr/ccs/bin/ld"
583 emarsden 1.45 #-solaris "/usr/bin/ld")
584 ram 1.17
585     (alien:def-alien-routine dlopen system-area-pointer
586 dtc 1.28 (file c-call:c-string) (mode c-call:int))
587 ram 1.17 (alien:def-alien-routine dlsym system-area-pointer
588     (lib system-area-pointer)
589 dtc 1.28 (name c-call:c-string))
590 ram 1.17 (alien:def-alien-routine dlclose void (lib system-area-pointer))
591     (alien:def-alien-routine dlerror c-call:c-string)
592    
593 dtc 1.27 ;;; Ensure we've opened our own binary so can resolve global variables
594     ;;; in the lisp image that come from libraries. This used to happen
595     ;;; only in alternate-get-global-address, and only if no libraries
596     ;;; were dlopened already, but that didn't work if something was
597     ;;; dlopened before any problem global vars were used. So now we do
598     ;;; this in any function that can add to the global-table, as well as
599     ;;; in alternate-get-global-address.
600 pw 1.25 (defun ensure-lisp-table-opened ()
601     (unless *global-table*
602     ;; Prevent recursive call if dlopen isn't defined
603 moore 1.42 (setf *global-table* (acons (int-sap 0) nil nil))
604     (setf *global-table* (acons (dlopen nil rtld-lazy) nil nil))
605     (when (zerop (system:sap-int (caar *global-table*)))
606 pw 1.25 (error "Can't open global symbol table: ~S" (dlerror)))))
607    
608 ram 1.17 (defun load-object-file (file)
609 pw 1.25 (ensure-lisp-table-opened)
610 ram 1.17 ; rtld global: so it can find all the symbols previously loaded
611     ; rtld now: that way dlopen will fail if not all symbols are defined.
612 moore 1.41 (let* ((filename (namestring file ))
613     (sap (dlopen filename (logior rtld-now rtld-global))))
614     (cond ((zerop (sap-int sap))
615 gerd 1.44 (let ((err-string (dlerror))
616     (sap (dlopen filename (logior rtld-lazy rtld-global))))
617     ;; For some reason dlerror always seems to return NIL,
618     ;; which isn't very informative.
619     (when (zerop (sap-int sap))
620     (error "Can't open object ~S: ~S" file err-string))
621     (dlclose sap)
622     (error "LOAD-OBJECT-FILE: Unresolved symbols in file ~S: ~S"
623     file err-string)))
624 moore 1.41 ((null (assoc sap *global-table* :test #'sap=))
625     (setf *global-table* (acons sap file *global-table*)))
626     (t nil))))
627    
628     ;;; Clear close all dlopened libraries and clear out the entries in
629     ;;; *global-table*, prior to doing a save-lisp.
630    
631     (defun close-global-table ()
632     (loop for lib-entry in *global-table*
633     for (sap) = lib-entry
634     do (progn
635     (dlclose sap)
636     ;; Probably not necessary, but neater than leaving around
637     ;; stale handles in the saved image.
638     (setf (car lib-entry) (int-sap 0)))))
639    
640     ;;; Open all the libraries in *global-table*
641     (defun reinitialize-global-table ()
642     (loop for lib-entry in *global-table*
643     for (sap . lib-path) = lib-entry
644     for new-sap = (dlopen (namestring lib-path)
645     (logior rtld-now rtld-global))
646     do (progn
647     (when (zerop (sap-int new-sap))
648     ;; We're going down
649     (error "Couldn't open library ~S: ~S" lib-path (dlerror)))
650     (setf (car lib-entry) new-sap)))
651     (alien:alien-funcall (alien:extern-alien "os_resolve_data_linkage"
652     (alien:function c-call:void))))
653 ram 1.17
654     (defun alternate-get-global-address (symbol)
655 pw 1.25 (ensure-lisp-table-opened)
656 emarsden 1.45 ;; find the symbol in any of the loaded objects,
657 ram 1.17 ;; search in reverse order of loading, later loadings
658     ;; take precedence
659     (let ((result 0))
660     (do ((table *global-table* (cdr table)))
661     ((or (null (car table)) (not (zerop result))))
662 pw 1.43 (setq result (sap-int (dlsym (caar table) symbol))))
663 ram 1.17 (values result)))
664    
665     (defun load-foreign (files &key
666     (libraries '("-lc"))
667     (base-file nil)
668 toy 1.33 (env ext:*environment-list*)
669     (verbose *load-verbose*))
670 emarsden 1.45 "Load C object files into the running Lisp. The FILES argument
671     should be a single file or a list of files. The files may be specified
672     as namestrings or as pathnames. The LIBRARIES argument should be a
673     list of library files as would be specified to ld. They will be
674     searched in the order given. The default is just \"-lc\", i.e., the C
675     library. The BASE-FILE argument is used to specify a file to use as
676     the starting place for defined symbols. The default is the C start up
677     code for Lisp. The ENV argument is the Unix environment variable
678     definitions for the invocation of the linker. The default is the
679     environment passed to Lisp."
680 ram 1.17 ;; Note: dlopen remembers the name of an object, when dlopenin
681     ;; the same name twice, the old objects is reused.
682     (declare (ignore base-file))
683 emarsden 1.45 ;; if passed a single shared object that can be loaded directly via
684     ;; dlopen(), do that instead of using the linker
685     (cond ((and (atom files)
686     (probe-file files)
687     (file-shared-library-p files))
688     (when verbose
689     (format t ";;; Opening shared library ~A ...~%" files))
690     (load-object-file files)
691     (when verbose
692     (format t ";;; Done.~%")))
693     (t
694     (let ((output-file (pick-temporary-file-name
695     (concatenate 'string "/tmp/~D~C" (string (gensym)))))
696     (error-output (make-string-output-stream)))
697 moore 1.41
698 emarsden 1.45 (when verbose
699     (format t ";;; Running ~A...~%" *dso-linker*)
700     (force-output))
701 toy 1.33
702 emarsden 1.45 (let ((proc (ext:run-program
703     *dso-linker*
704     (list*
705     #+(or solaris linux FreeBSD4) "-G"
706     #+(or OpenBSD irix) "-shared"
707     "-o"
708     output-file
709     ;; Cause all specified libs to be loaded in full
710     #+(or OpenBSD linux FreeBSD4) "--whole-archive"
711     #+solaris "-z" #+solaris "allextract"
712     (append (mapcar
713     #'(lambda (name)
714     (or (unix-namestring name)
715     (error 'simple-file-error
716     :pathname name
717     :format-control
718     "File does not exist: ~A."
719     :format-arguments
720     (list name))))
721     (if (atom files)
722     (list files)
723     files))
724     ;; Return to default ld behaviour for libs
725     (list
726     #+(or OpenBSD linux FreeBSD4)
727     "--no-whole-archive"
728     #+solaris "-z" #+solaris "defaultextract")
729     libraries))
730 emarsden 1.46 ;; on Linux/AMD64, we need to tell the platform linker to use the 32-bit
731     ;; linking mode instead of the default 64-bit mode. This can be done either
732     ;; via the LDEMULATION environment variable, or via the "-m" command-line
733     ;; option. Here we assume that LDEMULATION will be ignored by the platform
734     ;; linker on Linux/i386 platforms.
735 emarsden 1.47 :env `(#+(and x86 linux) (:ldemulation . "elf_i386") ,@env)
736 emarsden 1.45 :input nil
737     :output error-output
738     :error :output)))
739     (unless proc
740     (error "Could not run ~A" *dso-linker*))
741     (unless (zerop (ext:process-exit-code proc))
742     (system:serve-all-events 0)
743     (error "~A failed:~%~A" *dso-linker*
744     (get-output-stream-string error-output)))
745     (load-object-file output-file)
746     (unix:unix-unlink output-file)))
747     (when verbose
748     (format t ";;; Done.~%")
749     (force-output)))))
750    
751     ) ;; #+(or linux bsd solaris irix)

  ViewVC Help
Powered by ViewVC 1.1.5