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

Contents of /src/code/foreign.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.46.2.1 - (show annotations)
Wed Jun 2 15:14:10 2004 UTC (9 years, 10 months ago) by rtoy
Branch: release-19a-branch
CVS Tags: release-19a-pre2
Changes since 1.46: +2 -2 lines
Merge in HEAD fixes for LDEMULATION.
1 ;;; -*- Package: SYSTEM -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; 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 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/foreign.lisp,v 1.46.2.1 2004/06/02 15:14:10 rtoy Exp $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 (in-package "SYSTEM")
13
14 (in-package "ALIEN")
15 (export '(load-foreign))
16 (in-package "SYSTEM")
17 (import 'alien:load-foreign)
18
19 #+sparc (defconstant foreign-segment-start #xe0000000)
20 #+sparc (defconstant foreign-segment-size #x00100000)
21
22 #+hppa (defconstant foreign-segment-start #x10C00000)
23 #+hppa (defconstant foreign-segment-size #x00400000)
24
25 #+(and bsd x86)
26 (defconstant foreign-segment-start #x0E000000)
27 #+(and bsd x86)
28 (defconstant foreign-segment-size #x02000000)
29
30 (defvar *previous-linked-object-file* nil)
31 #-(or openbsd linux irix)
32 (defvar *foreign-segment-free-pointer* foreign-segment-start)
33
34 (defun pick-temporary-file-name (&optional (base "/tmp/tmp~D~C"))
35 (let ((code (char-code #\A)))
36 (loop
37 (let ((name (format nil base (unix:unix-getpid) (code-char code))))
38 (multiple-value-bind
39 (fd errno)
40 (unix:unix-open name
41 (logior unix:o_wronly unix:o_creat unix:o_excl)
42 #o666)
43 (cond ((not (null fd))
44 (unix:unix-close fd)
45 (return name))
46 ((not (= errno unix:eexist))
47 (error "Could not create temporary file ~S: ~A"
48 name (unix:get-unix-error-msg errno)))
49
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
57 #+(or (and FreeBSD (not elf)) (and sparc (not svr4)))
58 (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
69 #-(or linux bsd svr4)
70 (defun allocate-space-in-foreign-segment (bytes)
71 (let* ((pagesize-1 (1- (get-page-size)))
72 (memory-needed (logandc2 (+ bytes pagesize-1) pagesize-1))
73 (addr (int-sap *foreign-segment-free-pointer*))
74 (new-ptr (+ *foreign-segment-free-pointer* memory-needed)))
75 (when (> new-ptr (+ foreign-segment-start foreign-segment-size))
76 (error "Not enough memory left."))
77 (setf *foreign-segment-free-pointer* new-ptr)
78 (allocate-system-memory-at addr memory-needed)
79 addr))
80
81
82 ;;; 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 ;;;
86 ;;; The following definitions are taken from
87 ;;; /usr/include/sys/elf_common.h and /usr/include/sys/elf32.h.
88 ;;;
89 #+(or linux bsd svr4)
90 (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 ;; 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 ;; 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 ;; 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 (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 (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
196 (defun elf-executable-p (n)
197 "Given a file type number, determine whether the file is executable."
198 (= n et-executable))
199
200 (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 (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 (error (format nil "~A is not an ELF file." name)))
246
247 (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
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 (kind (aref line 9)) ; filter out .o file names
285 (old-address (gethash symbol lisp::*foreign-symbols*)))
286 (unless (or (null old-address) (= address old-address)
287 (char= kind #\F))
288 (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 ) ;; #-(or linux bsd svr4)
293
294
295
296 ;;; 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 #+(or (and FreeBSD (not ELF)) (and sparc (not svr4)))
300 (defun load-object-file (name)
301 (format t ";;; Loading object file...~%")
302 (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
303 (unless fd
304 (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno)))
305 (unwind-protect
306 (alien:with-alien ((header exec))
307 (unix:unix-read fd
308 (alien:alien-sap header)
309 (alien:alien-size exec :bytes))
310 (let* ((len-of-text-and-data
311 (+ (alien:slot header 'text) (alien:slot header 'data)))
312 (memory-needed
313 (+ len-of-text-and-data (alien:slot header 'bss)))
314 (addr (allocate-space-in-foreign-segment memory-needed)))
315 (unix:unix-read fd addr len-of-text-and-data)))
316 (unix:unix-close fd))))
317
318
319 #+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 (defconstant reloc-magic #x106)
395 #+hppa
396 (defconstant cpu-pa-risc1-0 #x20b)
397 #+hppa
398 (defconstant cpu-pa-risc1-1 #x210)
399 #+hppa
400 (defconstant cpu-pa-risc-max #x2ff)
401
402 #+hppa
403 (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 (unix:unix-close fd))))
442
443 #-(or linux bsd solaris irix)
444 (progn
445 (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 #+BSD (kind (aref line 9)) ; filter out .o file names
456 (old-address (gethash symbol lisp::*foreign-symbols*)))
457 (unless (or (null old-address) (= address old-address)
458 #+BSD (char= kind #\F))
459 (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
464 (defun load-foreign (files &key
465 (libraries '("-lc"))
466 (base-file
467 #-hpux
468 (merge-pathnames *command-line-utility-name*
469 "path:")
470 #+hpux "library:cmucl.orig")
471 (env ext:*environment-list*)
472 (verbose *load-verbose*))
473 "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 (let ((output-file (pick-temporary-file-name))
483 (symbol-table-file (pick-temporary-file-name))
484 (error-output (make-string-output-stream))
485 (files (if (atom files) (list files) files)))
486
487 (when verbose
488 (format t ";;; Running library:load-foreign.csh...~%")
489 (force-output))
490 #+hpux
491 (dolist (f files)
492 (with-open-file (stream f :element-type '(unsigned-byte 16))
493 (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 (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 (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 (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 libraries))
525 :env env
526 :input nil
527 :output error-output
528 :error :output)))
529 (unless proc
530 (error "Could not run library:load-foreign.csh"))
531 (unless (zerop (ext:process-exit-code proc))
532 (system:serve-all-events 0)
533 (error "library:load-foreign.csh failed:~%~A"
534 (get-output-stream-string error-output)))
535 (load-object-file output-file)
536 (parse-symbol-table symbol-table-file)
537 (unix:unix-unlink symbol-table-file)
538 (let ((old-file *previous-linked-object-file*))
539 (setf *previous-linked-object-file* output-file)
540 (when old-file
541 (unix:unix-unlink old-file)))))
542 (when verbose
543 (format t ";;; Done.~%")
544 (force-output)))
545
546
547 (export '(alternate-get-global-address))
548
549 (defun alternate-get-global-address (symbol)
550 (declare (type simple-string symbol)
551 (ignore symbol))
552 0)
553 ) ;; #-(or linux bsd solaris irix)
554
555
556 ;; Modern dlopen()-based loading of shared libraries
557 #+(or linux bsd solaris irix)
558 (progn
559
560 (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
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 #-linkage-table
578 (pushnew #'(lambda () (setq *global-table* nil))
579 ext:*after-save-initializations*)
580
581 (defvar *dso-linker*
582 #+solaris "/usr/ccs/bin/ld"
583 #-solaris "/usr/bin/ld")
584
585 (alien:def-alien-routine dlopen system-area-pointer
586 (file c-call:c-string) (mode c-call:int))
587 (alien:def-alien-routine dlsym system-area-pointer
588 (lib system-area-pointer)
589 (name c-call:c-string))
590 (alien:def-alien-routine dlclose void (lib system-area-pointer))
591 (alien:def-alien-routine dlerror c-call:c-string)
592
593 ;;; 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 (defun ensure-lisp-table-opened ()
601 (unless *global-table*
602 ;; Prevent recursive call if dlopen isn't defined
603 (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 (error "Can't open global symbol table: ~S" (dlerror)))))
607
608 (defun load-object-file (file)
609 (ensure-lisp-table-opened)
610 ; 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 (let* ((filename (namestring file ))
613 (sap (dlopen filename (logior rtld-now rtld-global))))
614 (cond ((zerop (sap-int sap))
615 (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 ((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
654 (defun alternate-get-global-address (symbol)
655 (ensure-lisp-table-opened)
656 ;; find the symbol in any of the loaded objects,
657 ;; 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 (setq result (sap-int (dlsym (caar table) symbol))))
663 (values result)))
664
665 (defun load-foreign (files &key
666 (libraries '("-lc"))
667 (base-file nil)
668 (env ext:*environment-list*)
669 (verbose *load-verbose*))
670 "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 ;; 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 ;; 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
698 (when verbose
699 (format t ";;; Running ~A...~%" *dso-linker*)
700 (force-output))
701
702 (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 ;; 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 :env `(#+(and x86 linux) (:ldemulation . "elf_i386") ,@env)
736 :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